226 lines
8.5 KiB
Scheme
226 lines
8.5 KiB
Scheme
;;; nyacc/parse.scm
|
|
;;;
|
|
;;; Copyright (C) 2014-2016 Matthew R. Wette
|
|
;;;
|
|
;;; This library is free software; you can redistribute it and/or
|
|
;;; modify it under the terms of the GNU Lesser General Public
|
|
;;; License as published by the Free Software Foundation; either
|
|
;;; version 3 of the License, or (at your option) any later version.
|
|
;;;
|
|
;;; This library is distributed in the hope that it will be useful,
|
|
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;;; Lesser General Public License for more details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU Lesser General Public
|
|
;;; License along with this library; if not, write to the Free Software
|
|
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
|
|
|
;; make parser that provide list of la-toks to lexer:
|
|
;; e.g., if comment not in latok, just throw away
|
|
|
|
(define-module (nyacc parse)
|
|
#:export (make-lalr-parser
|
|
make-lalr-ia-parser
|
|
)
|
|
#:use-module (nyacc util)
|
|
#:use-module ((srfi srfi-43) #:select (vector-map vector-for-each))
|
|
)
|
|
|
|
;; @item (machine-hashed? mach) => #t|#f
|
|
;; Indicate if the machine has been hashed.
|
|
(define (machine-hashed? mach)
|
|
(number? (caar (vector-ref (assq-ref mach 'pat-v) 0))))
|
|
|
|
;; @item make-lalr-parser mach => parser
|
|
;; This generates a procedure that takes one argument, a lexical analyzer:
|
|
;; @example
|
|
;; (parser lexical-analyzer [#:debug #t])
|
|
;; @end example
|
|
;; and is used as
|
|
;; @example
|
|
;; (define xyz-parse (make-lalr-parser xyz-mach))
|
|
;; (with-input-from-file "sourcefile.xyz" (lambda () (xyz-parse (gen-lexer))))
|
|
;; @end example
|
|
;; The generated parser is reentrant.
|
|
(define* (make-lalr-parser mach)
|
|
(let* ((len-v (assq-ref mach 'len-v))
|
|
(rto-v (assq-ref mach 'rto-v)) ; reduce to
|
|
(pat-v (assq-ref mach 'pat-v))
|
|
(actn-v (assq-ref mach 'act-v)) ; unknown action vector
|
|
(mtab (assq-ref mach 'mtab))
|
|
(xact-v (if (procedure? (vector-ref actn-v 0)) actn-v
|
|
(vector-map
|
|
;; Turn symbolic action into executable procedures:
|
|
(lambda (ix f) (eval f (current-module)))
|
|
(vector-map
|
|
(lambda (ix actn) (wrap-action actn))
|
|
actn-v))))
|
|
;;
|
|
(dmsg (lambda (s t a) (fmtout "state ~S, token ~S\t=> ~S\n" s t a)))
|
|
(hashed (number? (caar (vector-ref pat-v 0)))) ; been hashified?
|
|
;;(def (assq-ref mtab '$default))
|
|
(def (if hashed -1 '$default))
|
|
(end (assq-ref mtab '$end))
|
|
(err (assq-ref mtab '$error))
|
|
(comm (list (assq-ref mtab '$lone-comm) (assq-ref mtab '$code-comm)))
|
|
;; predicate to test for shift action:
|
|
(shift? (if hashed
|
|
(lambda (a) (positive? a))
|
|
(lambda (a) (eq? 'shift (car a)))))
|
|
;; On shift, transition to this state:
|
|
(shift-to (if hashed (lambda (x) x) (lambda (x) (cdr x))))
|
|
;; Predicate to test for reduce action:
|
|
(reduce? (if hashed
|
|
(lambda (a) (negative? a))
|
|
(lambda (a) (eq? 'reduce (car a)))))
|
|
;; On reduce, reduce this production-rule:
|
|
(reduce-pr (if hashed abs cdr))
|
|
;; If error, make the right packet.
|
|
(other (if hashed 0 '(other . 0)))
|
|
)
|
|
|
|
(lambda* (lexr #:key debug)
|
|
(let iter ((state (list 0)) ; state stack
|
|
(stack (list '$@)) ; sval stack
|
|
(nval #f) ; prev reduce to non-term val
|
|
(lval (lexr))) ; lexical value (from lex'er)
|
|
|
|
(let* ((tval (car (if nval nval lval))) ; token (syntax value)
|
|
(sval (cdr (if nval nval lval))) ; semantic value
|
|
(stxl (vector-ref pat-v (car state))) ; state transition xtra
|
|
(oact #f) ;; if not shift/reduce, then accept, error or skip
|
|
(stx (cond ;; state transition
|
|
((assq-ref stxl tval)) ; shift/reduce in table
|
|
((memq tval comm) (set! oact 'skip) other)
|
|
((assq-ref stxl err)) ; error recovery
|
|
((assq-ref stxl def)) ; default action
|
|
(else (set! oact 'error) other))))
|
|
|
|
(if debug (dmsg (car state) (if nval tval sval) stx))
|
|
(cond
|
|
((shift? stx)
|
|
;; We could check here to determine if next transition only has a
|
|
;; default reduction and, if so, go ahead and process the reduction
|
|
;; without reading another input token. Needed for interactive.
|
|
(iter (cons (shift-to stx) state) (cons sval stack)
|
|
#f (if nval lval (lexr))))
|
|
((reduce? stx)
|
|
(let* ((gx (reduce-pr stx)) (gl (vector-ref len-v gx))
|
|
($$ (apply (vector-ref xact-v gx) stack)))
|
|
(iter (list-tail state gl)
|
|
(list-tail stack gl)
|
|
(cons (vector-ref rto-v gx) $$)
|
|
lval)))
|
|
(else ;; other action: skip, error, or accept
|
|
(case oact
|
|
((skip) (iter state stack nval (lexr)))
|
|
((error)
|
|
(let ((fn (or (port-filename (current-input-port)) "(unknown)"))
|
|
(ln (1+ (port-line (current-input-port)))))
|
|
(fmterr "~A:~A: parse failed at state ~A, on input ~S\n"
|
|
fn ln (car state) sval)
|
|
#f))
|
|
(else ;; accept
|
|
(car stack))))))))))
|
|
|
|
;; @item make-lalr-ia-parser mach
|
|
;; Make an interactive parser. This will automatically process default
|
|
;; redunctions if that is the only choice, and does not wait for '$end to
|
|
;; return. This needs algorithm verification. Makes some assumptions that
|
|
;; need to be verified.
|
|
(define* (make-lalr-ia-parser mach)
|
|
(let* ((len-v (assq-ref mach 'len-v))
|
|
(rto-v (assq-ref mach 'rto-v)) ; reduce to
|
|
(pat-v (assq-ref mach 'pat-v))
|
|
(actn-v (assq-ref mach 'act-v)) ; unknown action vector
|
|
(mtab (assq-ref mach 'mtab))
|
|
(xact-v (if (procedure? (vector-ref actn-v 0)) actn-v
|
|
(vector-map
|
|
;; Turn symbolic action into executable procedures:
|
|
(lambda (ix f) (eval f (current-module)))
|
|
(vector-map
|
|
(lambda (ix actn) (wrap-action actn))
|
|
actn-v))))
|
|
;;
|
|
(dmsg (lambda (s t a) (fmtout "state ~S, token ~S\t=> ~S\n" s t a)))
|
|
(hashed (number? (caar (vector-ref pat-v 0)))) ; been hashified?
|
|
;;(def (assq-ref (assq-ref mach 'mtab) '$default))
|
|
(def (if hashed -1 '$default))
|
|
(end (assq-ref mtab '$end))
|
|
;; predicate to test for shift action:
|
|
(shift? (if hashed
|
|
(lambda (a) (positive? a))
|
|
(lambda (a) (eq? 'shift (car a)))))
|
|
;; On shift, transition to this state:
|
|
(shift-to (if hashed (lambda (x) x) (lambda (x) (cdr x))))
|
|
;; predicate to test for reduce action:
|
|
(reduce? (if hashed
|
|
(lambda (a) (negative? a))
|
|
(lambda (a) (eq? 'reduce (car a)))))
|
|
;; On reduce, reduce this production-rule:
|
|
;;(reduce-pr (if hashed (lambda (a) (abs a)) (lambda (a) (cdr a))))
|
|
(reduce-pr (if hashed abs cdr))
|
|
;; If no action found in transition list, then this:
|
|
(parse-error (if hashed #f (cons 'error 0)))
|
|
;; predicate to test for error
|
|
(error? (if hashed
|
|
(lambda (a) (eq? #f a))
|
|
(lambda (a) (eq? 'error (car a)))))
|
|
)
|
|
(lambda* (lexr #:key debug)
|
|
(let iter ((state (list 0)) ; state stack
|
|
(stack (list '$@)) ; sval stack
|
|
(nval #f) ; prev reduce to non-term val
|
|
(lval #f)) ; lexical value (from lex'er)
|
|
(let ((stxl (vector-ref pat-v (car state))))
|
|
(cond
|
|
((eqv? def (caar stxl))
|
|
(let* ((stx (cdar stxl))
|
|
(gx (reduce-pr stx))
|
|
(gl (vector-ref len-v gx))
|
|
($$ (apply (vector-ref xact-v gx) stack)))
|
|
(if debug (fmtout "state ~S, default => reduce ~S, goto ~S\n"
|
|
(car state) gx (list-ref state gl)))
|
|
(iter (list-tail state gl) (list-tail stack gl)
|
|
(cons (vector-ref rto-v gx) $$) lval)))
|
|
((eqv? end (caar stxl)) ; only '$end remains, return for i/a
|
|
(if debug (fmtout "in state ~S, looking at '$end => accept\n"
|
|
(car state)))
|
|
(if (reduce? (cdar stxl))
|
|
;; Assuming this is the final reduction ...
|
|
(apply (vector-ref xact-v (reduce-pr (cdar stxl))) stack)
|
|
;; Or already done ...
|
|
(car stack)))
|
|
(else
|
|
(let* ((laval (or nval (or lval (lexr))))
|
|
(tval (car laval)) (sval (cdr laval))
|
|
(stx (or (assq-ref stxl tval)
|
|
(assq-ref stxl def)
|
|
parse-error)))
|
|
#;(if debug (fmtout " lval=~S laval=~S\n" lval laval))
|
|
(if debug (dmsg (car state) (if nval tval sval) stx))
|
|
(cond
|
|
((error? stx)
|
|
(let ((fn (or (port-filename (current-input-port)) "(???)"))
|
|
(ln (1+ (port-line (current-input-port)))))
|
|
(fmterr "~A:~A: parse failed at state ~A, on input ~S\n"
|
|
fn ln (car state) sval))
|
|
#f)
|
|
((shift? stx)
|
|
(iter (cons (shift-to stx) state) (cons sval stack)
|
|
#f (if nval lval #f)))
|
|
((reduce? stx)
|
|
(let* ((gx (reduce-pr stx)) (gl (vector-ref len-v gx))
|
|
($$ (apply (vector-ref xact-v gx) stack)))
|
|
(iter (list-tail state gl)
|
|
(list-tail stack gl)
|
|
(cons (vector-ref rto-v gx) $$)
|
|
(if nval lval laval)
|
|
)))
|
|
(else ;; accept
|
|
(car stack)))))))))))
|
|
|
|
;; @end itemize
|
|
;;; --- last line ---
|