216 lines
7.4 KiB
Scheme
216 lines
7.4 KiB
Scheme
;;; nyacc/bison.scm
|
|
;;;
|
|
;;; Copyright (C) 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 General Public License
|
|
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
(define-module (nyacc bison)
|
|
#:export (make-lalr-machine/bison)
|
|
#:use-module (sxml simple)
|
|
#:use-module (sxml match)
|
|
#:use-module (sxml xpath)
|
|
#:use-module (ice-9 pretty-print)
|
|
#:use-module ((srfi srfi-1) #:select (fold))
|
|
#:use-module ((srfi srfi-43) #:select (vector-for-each vector-map))
|
|
#:use-module (nyacc export)
|
|
#:use-module (nyacc lalr) ; gen-match-table
|
|
)
|
|
|
|
;; @deffn chew-on-grammar tree lhs-v rhs-v terms => a-list
|
|
;; Generate a-list that maps bison rule index to NYACC rule index.
|
|
(define (chew-on-grammar tree lhs-v rhs-v terms) ;; bison-rule => nyacc-rule map
|
|
|
|
;; match rule index, if no match return @code{-1}
|
|
;; could be improved by starting with last rule number and wrapping
|
|
(define (match-rule lhs rhs)
|
|
(let iter ((ix 0))
|
|
(if (eqv? ix (vector-length lhs-v)) -1
|
|
(if (and (equal? lhs (elt->bison (vector-ref lhs-v ix) terms))
|
|
(equal? rhs (vector->list
|
|
(vector-map
|
|
(lambda (ix val) (elt->bison val terms))
|
|
(vector-ref rhs-v ix)))))
|
|
ix
|
|
(iter (1+ ix))))))
|
|
|
|
;; this is a fold
|
|
(define (rule->index-al tree seed)
|
|
(sxml-match tree
|
|
;; Skip first bison rule: always $accept.
|
|
((rule (@ (number "0")) (lhs "$accept") . ,rest)
|
|
(acons 0 0 seed))
|
|
;; This matches all others.
|
|
((rule (@ (number ,n)) (lhs ,lhs) (rhs (symbol ,rhs) ...))
|
|
(acons (string->number n) (match-rule lhs rhs) seed))
|
|
(,otherwise seed)))
|
|
|
|
(fold rule->index-al '() ((sxpath '(// rule)) tree)))
|
|
|
|
;; @deffn chew-on-automaton tree gx-al bs->ns => a-list
|
|
;; This digests the automaton and generated the @code{pat-v} and @code{kis-v}
|
|
;; vectors for the NYACC automaton.
|
|
(define (chew-on-automaton tree gx-al bs->ns)
|
|
|
|
(define st-numb
|
|
(let ((xsnum (sxpath '(@ number *text*))))
|
|
(lambda (state)
|
|
(string->number (car (xsnum state))))))
|
|
|
|
(define (do-state state)
|
|
(let* ((b-items ((sxpath '(// item)) state))
|
|
(n-items (fold
|
|
(lambda (tree seed)
|
|
(sxml-match tree
|
|
((item (@ (rule-number ,rns) (point ,pts)) . ,rest)
|
|
(let ((rn (string->number rns))
|
|
(pt (string->number pts)))
|
|
(if (and (positive? rn) (zero? pt)) seed
|
|
(acons (assq-ref gx-al rn) pt seed))))
|
|
(,otherwise (error "broken item")))) '() b-items))
|
|
(b-trans ((sxpath '(// transition)) state))
|
|
(n-trans (map
|
|
(lambda (tree)
|
|
(sxml-match tree
|
|
((transition (@ (symbol ,symb) (state ,dest)))
|
|
(cons* (bs->ns symb) 'shift (string->number dest)))
|
|
(,otherwise (error "broken tran")))) b-trans))
|
|
(b-redxs ((sxpath '(// reduction)) state))
|
|
(n-redxs (map
|
|
(lambda (tree)
|
|
(sxml-match tree
|
|
((reduction (@ (symbol ,symb) (rule "accept")))
|
|
(cons* (bs->ns symb) 'accept 0))
|
|
((reduction (@ (symbol ,symb) (rule ,rule)))
|
|
(cons* (bs->ns symb) 'reduce
|
|
(assq-ref gx-al (string->number rule))))
|
|
(,otherwise (error "broken redx" tree)))) b-redxs))
|
|
)
|
|
(list
|
|
(st-numb state)
|
|
(cons 'kis n-items)
|
|
(cons 'pat (append n-trans n-redxs)))))
|
|
|
|
(let ((xsf (sxpath '(itemset item (@ (rule-number (equal? "0"))
|
|
(point (equal? "2")))))))
|
|
(let iter ((data '()) (xtra #f) (states (cdr tree)))
|
|
(cond
|
|
((null? states) (cons xtra data))
|
|
((pair? (xsf (car states)))
|
|
(iter data (st-numb (car states)) (cdr states)))
|
|
(else
|
|
(iter (cons (do-state (car states)) data) xtra (cdr states)))))))
|
|
|
|
;; @deffn atomize symbol => string
|
|
;; This is copied from the module @code{(nyacc lalr)}.
|
|
(define (atomize terminal) ; from lalr.scm
|
|
(if (string? terminal)
|
|
(string->symbol (string-append "$:" terminal))
|
|
terminal))
|
|
|
|
;; @deffn make-bison->nyacc-symbol-mapper terminals non-terminals => proc
|
|
;; This generates a procedure to map bison symbol names, generated by the
|
|
;; NYACC @code{lalr->bison} procedure, (back) to nyacc symbols names.
|
|
(define (make-bison->nyacc-symbol-mapper terms non-ts)
|
|
(let ((bs->ns-al
|
|
(cons*
|
|
'("$default" . $default)
|
|
'("$end" . $end)
|
|
(map (lambda (symb) (cons (elt->bison symb terms) symb))
|
|
(append (map atomize terms) non-ts)))))
|
|
(lambda (name) (assoc-ref bs->ns-al name))))
|
|
|
|
;; fix-pa
|
|
;; fix parse action
|
|
(define (fix-pa pa xs)
|
|
(cond
|
|
((and (eqv? 'shift (cadr pa))
|
|
(> (cddr pa) xs))
|
|
(cons* (car pa) (cadr pa) (1- (cddr pa))))
|
|
((and (eqv? 'shift (cadr pa))
|
|
(= (cddr pa) xs))
|
|
(cons* (car pa) 'accept 0))
|
|
(else pa)))
|
|
|
|
;; @deffn fix-is is xs rhs-v
|
|
;; Convert xxx
|
|
(define (fix-is is xs rhs-v)
|
|
(let* ((gx (car is))
|
|
(rx (cdr is))
|
|
(gl (vector-length (vector-ref rhs-v gx))))
|
|
(if (= rx gl) (cons gx -1) is)))
|
|
|
|
;; @deffn spec->mac-sxml spec
|
|
;; Write bison-converted @var{spec} to file, run bison on it, and load
|
|
;; the bison-generated automaton as a SXML tree using the @code{-x} option.
|
|
(define (spec->mach-sxml spec)
|
|
(let* ((basename (tmpnam))
|
|
(bisname (string-append basename ".y"))
|
|
(xmlname (string-append basename ".xml"))
|
|
(tabname (string-append basename ".tab.c")))
|
|
(with-output-to-file bisname
|
|
(lambda () (lalr->bison spec)))
|
|
(system (string-append "bison" " --xml=" xmlname " --output=" tabname
|
|
" " bisname))
|
|
(let ((sx (call-with-input-file xmlname
|
|
(lambda (p) (xml->sxml p #:trim-whitespace? #t)))))
|
|
(delete-file bisname)
|
|
(delete-file xmlname)
|
|
(delete-file tabname)
|
|
sx)))
|
|
|
|
;; @deffn make-lalr-machine/bison spec => mach
|
|
;; Make a LALR automaton, consistent with that from @code{make-lalr-machine}
|
|
;; using external @code{bison} program.
|
|
(define (make-lalr-machine/bison spec)
|
|
(let* ((terminals (assq-ref spec 'terminals))
|
|
(non-terms (assq-ref spec 'non-terms))
|
|
(lhs-v (assq-ref spec 'lhs-v))
|
|
(rhs-v (assq-ref spec 'rhs-v))
|
|
(s0 (spec->mach-sxml spec))
|
|
(sG ((sxpath '(bison-xml-report grammar)) s0))
|
|
(sG (if (pair? sG) (car sG) sG))
|
|
(sA ((sxpath '(bison-xml-report automaton)) s0))
|
|
(sA (if (pair? sA) (car sA) sA))
|
|
(pG (chew-on-grammar sG lhs-v rhs-v terminals))
|
|
(bsym->nsym (make-bison->nyacc-symbol-mapper terminals non-terms))
|
|
(pA (chew-on-automaton sA pG bsym->nsym))
|
|
(xs (car pA))
|
|
(ns (caadr pA))
|
|
(pat-v (make-vector ns #f))
|
|
(kis-v (make-vector ns #f))
|
|
)
|
|
;;(pretty-print sA)
|
|
(for-each
|
|
(lambda (state)
|
|
(let* ((sx (car state))
|
|
(sx (if (>= sx xs) (1- sx) sx))
|
|
(pat (assq-ref (cdr state) 'pat))
|
|
(pat (map (lambda (pa) (fix-pa pa xs)) pat))
|
|
(kis (assq-ref (cdr state) 'kis))
|
|
(kis (map (lambda (is) (fix-is is xs rhs-v)) kis)))
|
|
(vector-set! pat-v sx pat)
|
|
(vector-set! kis-v sx kis)))
|
|
(cdr pA))
|
|
(gen-match-table
|
|
(cons*
|
|
(cons 'pat-v pat-v)
|
|
(cons 'kis-v kis-v)
|
|
(cons 'len-v (vector-map (lambda (i v) (vector-length v)) rhs-v))
|
|
(cons 'rto-v (vector-copy lhs-v))
|
|
spec))))
|
|
|
|
|
|
;; --- last line ---
|
|
|