mes/module/nyacc/bison.scm

216 lines
7.4 KiB
Scheme
Raw Normal View History

;;; 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 ---