Update (system base lalr) from upstream.

Suggested by Jan Nieuwenhuizen <janneke@gnu.org>.

* module/system/base/lalr.upstream.scm: Update from
  <https://github.com/schemeway/lalr-scm.git>, commit 4c4f149.

1 files changed, 59 insertions, 40 deletions

diff --git a/module/system/base/lalr.upstream.scm b/module/system/base/lalr.upstream.scm
index 217c43980..d2c087257 100755
--- a/module/system/base/lalr.upstream.scm
+++ b/module/system/base/lalr.upstream.scm
@@ -1,6 +1,7 @@
 ;;;
 ;;;; An Efficient and Portable LALR(1) Parser Generator for Scheme
 ;;;
+;; Copyright 2014  Jan Nieuwenhuizen <janneke@gnu.org>
 ;; Copyright 1993, 2010 Dominique Boucher
 ;;
 ;; This program is free software: you can redistribute it and/or
@@ -17,7 +18,7 @@
 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 
 
-(define *lalr-scm-version* "2.4.1")
+(define *lalr-scm-version* "2.5.0")
 
 
 (cond-expand 
@@ -33,7 +34,8 @@
   (def-macro (lalr-error msg obj) `(error ,msg ,obj))
 
   (define pprint pretty-print)
-  (define lalr-keyword? keyword?))
+  (define lalr-keyword? keyword?)
+  (define (note-source-location lvalue tok) lvalue))
  
  ;; -- 
  (bigloo
@@ -44,7 +46,8 @@
   (define lalr-keyword? keyword?)
   (def-macro (BITS-PER-WORD) 29)
   (def-macro (logical-or x . y) `(bit-or ,x ,@y))
-  (def-macro (lalr-error msg obj) `(error "lalr-parser" ,msg ,obj)))
+  (def-macro (lalr-error msg obj) `(error "lalr-parser" ,msg ,obj))
+  (define (note-source-location lvalue tok) lvalue))
  
  ;; -- Chicken
  (chicken
@@ -56,7 +59,8 @@
   (define lalr-keyword? symbol?)
   (def-macro (BITS-PER-WORD) 30)
   (def-macro (logical-or x . y) `(bitwise-ior ,x ,@y))
-  (def-macro (lalr-error msg obj) `(error ,msg ,obj)))
+  (def-macro (lalr-error msg obj) `(error ,msg ,obj))
+  (define (note-source-location lvalue tok) lvalue))
 
  ;; -- STKlos
  (stklos
@@ -67,7 +71,8 @@
   (define lalr-keyword? keyword?)
   (define-macro (BITS-PER-WORD) 30)
   (define-macro (logical-or x . y) `(bit-or ,x ,@y))
-  (define-macro (lalr-error msg obj) `(error 'lalr-parser ,msg ,obj)))
+  (define-macro (lalr-error msg obj) `(error 'lalr-parser ,msg ,obj))
+  (define (note-source-location lvalue tok) lvalue))
 
  ;; -- Guile
  (guile
@@ -78,7 +83,14 @@
   (define lalr-keyword? symbol?)
   (define-macro (BITS-PER-WORD) 30)
   (define-macro (logical-or x . y) `(logior ,x ,@y))
-  (define-macro (lalr-error msg obj) `(error ,msg ,obj)))
+  (define-macro (lalr-error msg obj) `(error ,msg ,obj))
+  (define (note-source-location lvalue tok)
+    (if (and (supports-source-properties? lvalue)
+             (not (source-property lvalue 'loc))
+             (lexical-token? tok))
+        (set-source-property! lvalue 'loc (lexical-token-source tok)))
+    lvalue))
+
 
  ;; -- Kawa
  (kawa
@@ -87,7 +99,8 @@
   (define logical-or logior)
   (define (lalr-keyword? obj) (keyword? obj))
   (define (pprint obj) (pretty-print obj))
-  (define (lalr-error msg obj) (error msg obj)))
+  (define (lalr-error msg obj) (error msg obj))
+  (define (note-source-location lvalue tok) lvalue))
 
  ;; -- SISC
  (sisc
@@ -98,8 +111,8 @@
   (define lalr-keyword? symbol?)
   (define-macro BITS-PER-WORD (lambda () 32))
   (define-macro logical-or (lambda (x . y) `(logor ,x ,@y)))
-  (define-macro (lalr-error msg obj) `(error "~a ~S:" ,msg ,obj)))
-	
+  (define-macro (lalr-error msg obj) `(error "~a ~S:" ,msg ,obj))
+  (define (note-source-location lvalue tok) lvalue))
        
  (else
   (error "Unsupported Scheme system")))
@@ -235,6 +248,11 @@
 
   (define driver-name     'lr-driver)
 
+  (define (glr-driver?)
+    (eq? driver-name 'glr-driver))
+  (define (lr-driver?)
+    (eq? driver-name 'lr-driver))
+
   (define (gen-tables! tokens gram )
     (initialize-all)
     (rewrite-grammar
@@ -1097,14 +1115,14 @@
 			  (add-conflict-message
 			   "%% Reduce/Reduce conflict (reduce " (- new-action) ", reduce " (- current-action) 
 			   ") on '" (get-symbol (+ symbol nvars)) "' in state " state)
-			  (if (eq? driver-name 'glr-driver)
+			  (if (glr-driver?)
 			      (set-cdr! (cdr actions) (cons new-action (cddr actions)))
 			      (set-car! (cdr actions) (max current-action new-action))))
 			;; --- shift/reduce conflict
 			;; can we resolve the conflict using precedences?
 			(case (resolve-conflict symbol (- current-action))
 			  ;; -- shift
-			  ((shift)   (if (eq? driver-name 'glr-driver)
+			  ((shift)   (if (glr-driver?)
 					 (set-cdr! (cdr actions) (cons new-action (cddr actions)))
 					 (set-car! (cdr actions) new-action)))
 			  ;; -- reduce
@@ -1113,11 +1131,12 @@
 			  (else      (add-conflict-message
 				      "%% Shift/Reduce conflict (shift " new-action ", reduce " (- current-action)
 				      ") on '" (get-symbol (+ symbol nvars)) "' in state " state)
-				     (if (eq? driver-name 'glr-driver)
+				     (if (glr-driver?)
 					 (set-cdr! (cdr actions) (cons new-action (cddr actions)))
 					 (set-car! (cdr actions) new-action))))))))
           
-	    (vector-set! action-table state (cons (list symbol new-action) state-actions)))))
+	    (vector-set! action-table state (cons (list symbol new-action) state-actions)))
+	))
 
     (define (add-action-for-all-terminals state action)
       (do ((i 1 (+ i 1)))
@@ -1131,7 +1150,9 @@
       (let ((red (vector-ref reduction-table i)))
 	(if (and red (>= (red-nreds red) 1))
 	    (if (and (= (red-nreds red) 1) (vector-ref consistent i))
-		(add-action-for-all-terminals i (- (car (red-rules red))))
+		(if (glr-driver?)
+		    (add-action-for-all-terminals i (- (car (red-rules red))))
+		    (add-action i 'default (- (car (red-rules red)))))
 		(let ((k (vector-ref lookaheads (+ i 1))))
 		  (let loop ((j (vector-ref lookaheads i)))
 		    (if (< j k)
@@ -1591,22 +1612,27 @@
 		     `(let* (,@(if act
 				   (let loop ((i 1) (l rhs))
 				     (if (pair? l)
-					 (let ((rest (cdr l)))
-					   (cons 
-					    `(,(string->symbol
-						(string-append
-						 "$"
-						 (number->string 
-						  (+ (- n i) 1))))
-					      ,(if (eq? driver-name 'lr-driver)
-						   `(vector-ref ___stack (- ___sp ,(- (* i 2) 1)))
-						   `(list-ref ___sp ,(+ (* (- i 1) 2) 1))))
-					    (loop (+ i 1) rest)))
+					 (let ((rest (cdr l))
+                                               (ns (number->string (+ (- n i) 1))))
+                                           (cons
+                                            `(tok ,(if (eq? driver-name 'lr-driver)
+                                                       `(vector-ref ___stack (- ___sp ,(- (* i 2) 1)))
+                                                       `(list-ref ___sp ,(+ (* (- i 1) 2) 1))))
+                                            (cons
+                                             `(,(string->symbol (string-append "$" ns))
+                                               (if (lexical-token? tok) (lexical-token-value tok) tok))
+                                             (cons
+                                              `(,(string->symbol (string-append "@" ns))
+                                                (if (lexical-token? tok) (lexical-token-source tok) tok))
+                                              (loop (+ i 1) rest)))))
 					 '()))
 				   '()))
 			,(if (= nt 0)
 			     '$1
-			     `(___push ,n ,nt ,(cdr p) ,@(if (eq? driver-name 'lr-driver) '() '(___sp)))))))))
+			     `(___push ,n ,nt ,(cdr p) ,@(if (eq? driver-name 'lr-driver) '() '(___sp)) 
+                                       ,(if (eq? driver-name 'lr-driver)
+                                            `(vector-ref ___stack (- ___sp ,(length rhs)))
+                                            `(list-ref ___sp ,(length rhs))))))))))
 
 	   gram/actions))))
 
@@ -1822,14 +1848,14 @@
     (if (>= ___sp (vector-length ___stack))
         (___growstack)))
   
-  (define (___push delta new-category lvalue)
+  (define (___push delta new-category lvalue tok)
     (set! ___sp (- ___sp (* delta 2)))
     (let* ((state     (vector-ref ___stack ___sp))
            (new-state (cdr (assoc new-category (vector-ref ___gtable state)))))
       (set! ___sp (+ ___sp 2))
       (___checkstack)
       (vector-set! ___stack ___sp new-state)
-      (vector-set! ___stack (- ___sp 1) lvalue)))
+      (vector-set! ___stack (- ___sp 1) (note-source-location lvalue tok))))
   
   (define (___reduce st)
     ((vector-ref ___rtable st) ___stack ___sp ___gtable ___push ___pushback))
@@ -1879,17 +1905,11 @@
         (lexical-token-category tok)
         tok))
 
-  (define (___value tok)
-    (if (lexical-token? tok)
-        (lexical-token-value tok)
-        tok))
-  
   (define (___run)
     (let loop ()
       (if ___input
           (let* ((state (vector-ref ___stack ___sp))
                  (i     (___category ___input))
-                 (attr  (___value ___input))
                  (act   (___action i (vector-ref ___atable state))))
             
             (cond ((not (symbol? i))
@@ -1918,7 +1938,7 @@
              
                   ;; Shift current token on top of the stack
                   ((>= act 0)
-                   (___shift act attr)
+                   (___shift act ___input)
                    (set! ___input (if (eq? i '*eoi*) '*eoi* #f))
                    (loop))
              
@@ -2003,11 +2023,11 @@
     (set! *parses* (cons parse *parses*)))
     
 
-  (define (push delta new-category lvalue stack)
+  (define (push delta new-category lvalue stack tok)
     (let* ((stack     (drop stack (* delta 2)))
            (state     (car stack))
            (new-state (cdr (assv new-category (vector-ref ___gtable state)))))
-        (cons new-state (cons lvalue stack))))
+        (cons new-state (cons (note-source-location lvalue tok) stack))))
   
   (define (reduce state stack)
     ((vector-ref ___rtable state) stack ___gtable push))
@@ -2025,8 +2045,7 @@
   (define (run)
     (let loop-tokens ()
       (consume)
-      (let ((symbol (token-category *input*))
-            (attr   (token-attribute *input*)))
+      (let ((symbol (token-category *input*)))
         (for-all-processes
          (lambda (process)
            (let loop ((stacks (list process)) (active-stacks '()))
@@ -2044,7 +2063,7 @@
                                      (add-parse (car (take-right stack 2)))
                                      (actions-loop other-actions active-stacks))
                                     ((>= action 0)
-                                     (let ((new-stack (shift action attr stack)))
+                                     (let ((new-stack (shift action *input* stack)))
                                        (add-process new-stack))
                                      (actions-loop other-actions active-stacks))
                                     (else