107 lines
3.1 KiB
Scheme
107 lines
3.1 KiB
Scheme
|
;;; nyacc/import.scm
|
||
|
|
;;;
|
||
|
|
;;; Copyright (C) 2015 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
|
||
|
|
|
||
|
|
;; Convert guile lalr grammar to nyacc grammar.
|
||
|
|
|
||
|
|
;; What is *eoi* for?
|
||
|
|
|
||
|
|
(define-module (nyacc import)
|
||
|
|
#:export-syntax (lalr-parser)
|
||
|
|
#:export (guile-lalr->nyacc-lalr)
|
||
|
|
#:use-module ((srfi srfi-1) #:select (fold-right))
|
||
|
|
)
|
||
|
|
|
||
|
|
(define (convert-tree spec0)
|
||
|
|
(let* ((terms (cons '*eoi* (car spec0)))
|
||
|
|
(start (caadr spec0))
|
||
|
|
(wrap-symb
|
||
|
|
(lambda (s) (cons (if (memq s terms) 'terminal 'non-terminal) s))))
|
||
|
|
(let iter ((prl1 '()) ; new production rules
|
||
|
|
(prl0 (cdr spec0)) ; old production rules
|
||
|
|
(lhs #f) ; LHS
|
||
|
|
(rhs1-l #f) ; new RHS list
|
||
|
|
(rhs0-l #f)) ; old RHS list
|
||
|
|
(cond
|
||
|
|
((pair? rhs0-l) ;; convert RHS
|
||
|
|
(iter prl1 prl0 lhs
|
||
|
|
(cons
|
||
|
|
(fold-right ;; s1 ... : a => (('terminal . s) ... ('$$ . a))
|
||
|
|
(lambda (symb seed) (cons (wrap-symb symb) seed))
|
||
|
|
(list (list '$$ (cdar rhs0-l)))
|
||
|
|
(caar rhs0-l))
|
||
|
|
rhs1-l)
|
||
|
|
(cdr rhs0-l)))
|
||
|
|
((null? rhs0-l) ;; roll up LHS+RHSs to new rule
|
||
|
|
(iter (cons (cons lhs (reverse rhs1-l)) prl1) prl0 #f #f #f))
|
||
|
|
((pair? prl0) ;; next production rule
|
||
|
|
(iter prl1 (cdr prl0) (caar prl0) '() (cdar prl0)))
|
||
|
|
(else ;; return spec in preliminary form
|
||
|
|
(list
|
||
|
|
'lalr-spec
|
||
|
|
`(start ,start)
|
||
|
|
`(grammar ,(reverse prl1))))))))
|
||
|
|
|
||
|
|
(define-syntax parse-rhs-list
|
||
|
|
(syntax-rules (:)
|
||
|
|
((_ (<rhs0sym> ...) : <rhs0act> <rhs1> ...)
|
||
|
|
(cons (cons '(<rhs0sym> ...) '<rhs0act>)
|
||
|
|
(parse-rhs-list <rhs1> ...)))
|
||
|
|
((_) (list))))
|
||
|
|
|
||
|
|
(define-syntax parse-prod-list
|
||
|
|
(syntax-rules ()
|
||
|
|
((_ (<lhs> <rhs> ...) <prod1> ...)
|
||
|
|
(cons (cons '<lhs> (parse-rhs-list <rhs> ...))
|
||
|
|
(parse-prod-list <prod1> ...)))
|
||
|
|
((_) (list))))
|
||
|
|
|
||
|
|
|
||
|
|
(define-syntax lalr-parser
|
||
|
|
(syntax-rules ()
|
||
|
|
((_ <tokens> <prod0> ...)
|
||
|
|
(convert-tree
|
||
|
|
(cons '<tokens> (parse-prod-list <prod0> ...))))))
|
||
|
|
|
||
|
|
|
||
|
|
(define (guile-lalr->nyacc-lalr match-table spec)
|
||
|
|
(letrec
|
||
|
|
((mark (lambda (s) (if (symbol? s) `(quote ,s) s)))
|
||
|
|
(rmt (map (lambda (p) (cons (cdr p) (mark (car p)))) match-table))
|
||
|
|
(clean
|
||
|
|
(lambda (dt)
|
||
|
|
(cond
|
||
|
|
((null? dt) '())
|
||
|
|
((pair? dt)
|
||
|
|
(case (car dt)
|
||
|
|
((non-terminal) (cdr dt))
|
||
|
|
((terminal)
|
||
|
|
(cond
|
||
|
|
((assq-ref rmt (cdr dt)))
|
||
|
|
((symbol? (cdr dt)) (simple-format #f "~A" (cdr dt)))
|
||
|
|
(else (cdr dt))))
|
||
|
|
((start) dt)
|
||
|
|
(else
|
||
|
|
(cons (clean (car dt)) (clean (cdr dt))))))
|
||
|
|
(else
|
||
|
|
dt))))
|
||
|
|
)
|
||
|
|
(clean spec)))
|
||
|
|
|
||
|
|
|
||
|
|
;;; --- last line ---
|