mes/module/nyacc/bison.scm

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