Import Nyacc 0.72.0.
[mes.git] / module / nyacc / import.scm
1 ;;; nyacc/import.scm
2 ;;;
3 ;;; Copyright (C) 2015 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 ;; Convert guile lalr grammar to nyacc grammar.
20
21 ;; What is *eoi* for?
22
23 (define-module (nyacc import)
24   #:export-syntax (lalr-parser)
25   #:export (guile-lalr->nyacc-lalr)
26   #:use-module ((srfi srfi-1) #:select (fold-right))
27   )
28
29 (define (convert-tree spec0)
30   (let* ((terms (cons '*eoi* (car spec0)))
31          (start (caadr spec0))
32          (wrap-symb
33           (lambda (s) (cons (if (memq s terms) 'terminal 'non-terminal) s))))
34     (let iter ((prl1 '())               ; new production rules
35                (prl0 (cdr spec0))       ; old production rules
36                (lhs #f)                 ; LHS
37                (rhs1-l #f)              ; new RHS list
38                (rhs0-l #f))             ; old RHS list
39       (cond
40        ((pair? rhs0-l) ;; convert RHS
41         (iter prl1 prl0 lhs
42               (cons
43                (fold-right ;; s1 ... : a => (('terminal . s) ... ('$$ . a))
44                 (lambda (symb seed) (cons (wrap-symb symb) seed))
45                 (list (list '$$ (cdar rhs0-l)))
46                 (caar rhs0-l))
47                rhs1-l)
48               (cdr rhs0-l)))
49        ((null? rhs0-l) ;; roll up LHS+RHSs to new rule
50         (iter (cons (cons lhs (reverse rhs1-l)) prl1) prl0 #f #f #f))
51        ((pair? prl0) ;; next production rule
52         (iter prl1 (cdr prl0) (caar prl0) '() (cdar prl0)))
53        (else ;; return spec in preliminary form
54         (list
55          'lalr-spec
56          `(start ,start)
57          `(grammar ,(reverse prl1))))))))
58
59 (define-syntax parse-rhs-list
60   (syntax-rules (:)
61     ((_ (<rhs0sym> ...) : <rhs0act> <rhs1> ...)
62      (cons (cons '(<rhs0sym> ...) '<rhs0act>)
63            (parse-rhs-list <rhs1> ...)))
64     ((_) (list))))
65
66 (define-syntax parse-prod-list
67   (syntax-rules ()
68     ((_ (<lhs> <rhs> ...) <prod1> ...)
69      (cons (cons '<lhs> (parse-rhs-list <rhs> ...))
70            (parse-prod-list <prod1> ...)))
71     ((_) (list))))
72
73
74 (define-syntax lalr-parser
75   (syntax-rules ()
76     ((_ <tokens> <prod0> ...)
77      (convert-tree
78       (cons '<tokens> (parse-prod-list <prod0> ...))))))
79
80
81 (define (guile-lalr->nyacc-lalr match-table spec)
82   (letrec
83       ((mark (lambda (s) (if (symbol? s) `(quote ,s) s)))
84        (rmt (map (lambda (p) (cons (cdr p) (mark (car p)))) match-table))
85        (clean
86         (lambda (dt)
87           (cond
88            ((null? dt) '())
89            ((pair? dt)
90             (case (car dt)
91               ((non-terminal) (cdr dt))
92               ((terminal)
93                (cond
94                 ((assq-ref rmt (cdr dt)))
95                 ((symbol? (cdr dt)) (simple-format #f "~A" (cdr dt)))
96                 (else (cdr dt))))
97               ((start) dt)
98               (else
99                (cons (clean (car dt)) (clean (cdr dt))))))
100            (else
101             dt))))
102        )
103     (clean spec)))
104
105
106 ;;; --- last line ---