Import Nyacc 0.72.0.
[mes.git] / module / nyacc / parse.scm
1 ;;; nyacc/parse.scm
2 ;;;
3 ;;; Copyright (C) 2014-2016 Matthew R. Wette
4 ;;;
5 ;;; This library is free software; you can redistribute it and/or
6 ;;; modify it under the terms of the GNU Lesser General Public
7 ;;; License as published by the Free Software Foundation; either
8 ;;; version 3 of the License, or (at your option) any later version.
9 ;;;
10 ;;; This library is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
13 ;;; Lesser General Public License for more details.
14 ;;;
15 ;;; You should have received a copy of the GNU Lesser General Public
16 ;;; License along with this library; if not, write to the Free Software
17 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
18
19 ;; make parser that provide list of la-toks to lexer:
20 ;; e.g., if comment not in latok, just throw away
21
22 (define-module (nyacc parse)
23   #:export (make-lalr-parser
24             make-lalr-ia-parser
25             )
26   #:use-module (nyacc util)
27   #:use-module ((srfi srfi-43) #:select (vector-map vector-for-each))
28   )
29
30 ;; @item (machine-hashed? mach) => #t|#f
31 ;; Indicate if the machine has been hashed.
32 (define (machine-hashed? mach)
33   (number? (caar (vector-ref (assq-ref mach 'pat-v) 0))))
34
35 ;; @item make-lalr-parser mach => parser
36 ;; This generates a procedure that takes one argument, a lexical analyzer:
37 ;; @example
38 ;; (parser lexical-analyzer [#:debug #t])
39 ;; @end example
40 ;; and is used as
41 ;; @example
42 ;; (define xyz-parse (make-lalr-parser xyz-mach))
43 ;; (with-input-from-file "sourcefile.xyz" (lambda () (xyz-parse (gen-lexer))))
44 ;; @end example
45 ;; The generated parser is reentrant.
46 (define* (make-lalr-parser mach)
47   (let* ((len-v (assq-ref mach 'len-v))
48          (rto-v (assq-ref mach 'rto-v)) ; reduce to
49          (pat-v (assq-ref mach 'pat-v))
50          (actn-v (assq-ref mach 'act-v)) ; unknown action vector
51          (mtab (assq-ref mach 'mtab))
52          (xact-v (if (procedure? (vector-ref actn-v 0)) actn-v
53                      (vector-map
54                       ;; Turn symbolic action into executable procedures:
55                       (lambda (ix f) (eval f (current-module)))
56                       (vector-map
57                        (lambda (ix actn) (wrap-action actn))
58                        actn-v))))
59          ;;
60          (dmsg (lambda (s t a) (fmtout "state ~S, token ~S\t=> ~S\n" s t a)))
61          (hashed (number? (caar (vector-ref pat-v 0)))) ; been hashified?
62          ;;(def (assq-ref mtab '$default))
63          (def (if hashed -1 '$default))
64          (end (assq-ref mtab '$end))
65          (err (assq-ref mtab '$error))
66          (comm (list (assq-ref mtab '$lone-comm) (assq-ref mtab '$code-comm)))
67          ;; predicate to test for shift action:
68          (shift? (if hashed
69                      (lambda (a) (positive? a))
70                      (lambda (a) (eq? 'shift (car a)))))
71          ;; On shift, transition to this state:
72          (shift-to (if hashed (lambda (x) x) (lambda (x) (cdr x))))
73          ;; Predicate to test for reduce action:
74          (reduce? (if hashed
75                       (lambda (a) (negative? a))
76                       (lambda (a) (eq? 'reduce (car a)))))
77          ;; On reduce, reduce this production-rule:
78          (reduce-pr (if hashed abs cdr))
79          ;; If error, make the right packet.
80          (other (if hashed 0 '(other . 0)))
81          )
82
83     (lambda* (lexr #:key debug)
84       (let iter ((state (list 0))       ; state stack
85                  (stack (list '$@))     ; sval stack
86                  (nval #f)              ; prev reduce to non-term val
87                  (lval (lexr)))         ; lexical value (from lex'er)
88
89         (let* ((tval (car (if nval nval lval))) ; token (syntax value)
90                (sval (cdr (if nval nval lval))) ; semantic value
91                (stxl (vector-ref pat-v (car state))) ; state transition xtra
92                (oact #f) ;; if not shift/reduce, then accept, error or skip
93                (stx (cond ;; state transition
94                      ((assq-ref stxl tval)) ; shift/reduce in table
95                      ((memq tval comm) (set! oact 'skip) other)
96                      ((assq-ref stxl err)) ; error recovery
97                      ((assq-ref stxl def))  ; default action
98                      (else (set! oact 'error) other))))
99
100           (if debug (dmsg (car state) (if nval tval sval) stx))
101           (cond
102            ((shift? stx)
103             ;; We could check here to determine if next transition only has a
104             ;; default reduction and, if so, go ahead and process the reduction
105             ;; without reading another input token.  Needed for interactive.
106             (iter (cons (shift-to stx) state) (cons sval stack)
107                   #f (if nval lval (lexr))))
108            ((reduce? stx)
109             (let* ((gx (reduce-pr stx)) (gl (vector-ref len-v gx))
110                    ($$ (apply (vector-ref xact-v gx) stack)))
111               (iter (list-tail state gl) 
112                     (list-tail stack gl)
113                     (cons (vector-ref rto-v gx) $$)
114                     lval)))
115            (else ;; other action: skip, error, or accept
116             (case oact
117               ((skip) (iter state stack nval (lexr)))
118               ((error)
119                (let ((fn (or (port-filename (current-input-port)) "(unknown)"))
120                      (ln (1+ (port-line (current-input-port)))))
121                  (fmterr "~A:~A: parse failed at state ~A, on input ~S\n"
122                          fn ln (car state) sval)
123                  #f))
124               (else ;; accept
125                (car stack))))))))))
126
127 ;; @item make-lalr-ia-parser mach
128 ;; Make an interactive parser.   This will automatically process default
129 ;; redunctions if that is the only choice, and does not wait for '$end to
130 ;; return.  This needs algorithm verification.  Makes some assumptions that
131 ;; need to be verified.
132 (define* (make-lalr-ia-parser mach)
133   (let* ((len-v (assq-ref mach 'len-v))
134          (rto-v (assq-ref mach 'rto-v)) ; reduce to
135          (pat-v (assq-ref mach 'pat-v))
136          (actn-v (assq-ref mach 'act-v)) ; unknown action vector
137          (mtab (assq-ref mach 'mtab))
138          (xact-v (if (procedure? (vector-ref actn-v 0)) actn-v
139                      (vector-map
140                       ;; Turn symbolic action into executable procedures:
141                       (lambda (ix f) (eval f (current-module)))
142                       (vector-map
143                        (lambda (ix actn) (wrap-action actn))
144                        actn-v))))
145          ;;
146          (dmsg (lambda (s t a) (fmtout "state ~S, token ~S\t=> ~S\n" s t a)))
147          (hashed (number? (caar (vector-ref pat-v 0)))) ; been hashified?
148          ;;(def (assq-ref (assq-ref mach 'mtab) '$default))
149          (def (if hashed -1 '$default))
150          (end (assq-ref mtab '$end))
151          ;; predicate to test for shift action:
152          (shift? (if hashed
153                      (lambda (a) (positive? a))
154                      (lambda (a) (eq? 'shift (car a)))))
155          ;; On shift, transition to this state:
156          (shift-to (if hashed (lambda (x) x) (lambda (x) (cdr x))))
157          ;; predicate to test for reduce action:
158          (reduce? (if hashed
159                       (lambda (a) (negative? a))
160                       (lambda (a) (eq? 'reduce (car a)))))
161          ;; On reduce, reduce this production-rule:
162          ;;(reduce-pr (if hashed (lambda (a) (abs a)) (lambda (a) (cdr a))))
163          (reduce-pr (if hashed abs cdr))
164          ;; If no action found in transition list, then this:
165          (parse-error (if hashed #f (cons 'error 0)))
166          ;; predicate to test for error
167          (error? (if hashed
168                      (lambda (a) (eq? #f a))
169                      (lambda (a) (eq? 'error (car a)))))
170          )
171     (lambda* (lexr #:key debug)
172       (let iter ((state (list 0))       ; state stack
173                  (stack (list '$@))     ; sval stack
174                  (nval #f)              ; prev reduce to non-term val
175                  (lval #f))             ; lexical value (from lex'er)
176         (let ((stxl (vector-ref pat-v (car state))))
177           (cond
178            ((eqv? def (caar stxl))
179             (let* ((stx (cdar stxl))
180                    (gx (reduce-pr stx))
181                    (gl (vector-ref len-v gx))
182                    ($$ (apply (vector-ref xact-v gx) stack)))
183               (if debug (fmtout "state ~S, default => reduce ~S, goto ~S\n"
184                                 (car state) gx (list-ref state gl)))
185               (iter (list-tail state gl) (list-tail stack gl)
186                     (cons (vector-ref rto-v gx) $$) lval)))
187            ((eqv? end (caar stxl))      ; only '$end remains, return for i/a
188             (if debug (fmtout "in state ~S, looking at '$end => accept\n"
189                               (car state)))
190             (if (reduce? (cdar stxl))
191                 ;; Assuming this is the final reduction ...
192                 (apply (vector-ref xact-v (reduce-pr (cdar stxl))) stack)
193                 ;; Or already done ...
194                 (car stack)))
195            (else
196             (let* ((laval (or nval (or lval (lexr))))
197                    (tval (car laval)) (sval (cdr laval))
198                    (stx (or (assq-ref stxl tval)
199                             (assq-ref stxl def)
200                             parse-error)))
201               #;(if debug (fmtout "  lval=~S  laval=~S\n" lval laval))
202               (if debug (dmsg (car state) (if nval tval sval) stx))
203               (cond
204                ((error? stx)
205                 (let ((fn (or (port-filename (current-input-port)) "(???)"))
206                       (ln (1+ (port-line (current-input-port)))))
207                   (fmterr "~A:~A: parse failed at state ~A, on input ~S\n"
208                           fn ln (car state) sval))
209                 #f)
210                ((shift? stx)
211                 (iter (cons (shift-to stx) state) (cons sval stack)
212                       #f (if nval lval #f)))
213                ((reduce? stx)
214                 (let* ((gx (reduce-pr stx)) (gl (vector-ref len-v gx))
215                        ($$ (apply (vector-ref xact-v gx) stack)))
216                   (iter (list-tail state gl) 
217                         (list-tail stack gl)
218                         (cons (vector-ref rto-v gx) $$)
219                         (if nval lval laval)
220                         )))
221                (else ;; accept
222                 (car stack)))))))))))
223   
224 ;; @end itemize
225 ;;; --- last line ---