[PATCH 2/2] LALR-parser: transparent source locations using source-proprerties.

[Jan Nieuwenhuizen]

        * module/system/base/lalr.upstream.scm (lalr-parser): Add
        token argument to push.
        (lr-driver): (___push): Transparently set source location from
        token using source-properties.
---
 module/system/base/lalr.upstream.scm | 13 ++++++++++---
 1 file changed, 10 insertions(+), 3 deletions(-)

diff --git a/module/system/base/lalr.upstream.scm 
b/module/system/base/lalr.upstream.scm
index b250c23..871c931 100755
--- a/module/system/base/lalr.upstream.scm
+++ b/module/system/base/lalr.upstream.scm
@@ -1609,7 +1609,10 @@
                                   '()))
                        ,(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 
(1+ ___sp))
+                                                       `(list-ref ___sp (1+ 
___sp))))))))))
 
           gram/actions))))
 
@@ -1825,7 +1828,11 @@
     (if (>= ___sp (vector-length ___stack))
         (___growstack)))
   
-  (define (___push delta new-category lvalue)
+  (define (___push delta new-category 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)))
     (set! ___sp (- ___sp (* delta 2)))
     (let* ((state     (vector-ref ___stack ___sp))
            (new-state (cdr (assoc new-category (vector-ref ___gtable state)))))
@@ -2000,7 +2007,7 @@
     (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)))))
-- 
Jan Nieuwenhuizen <address@hidden> | GNU LilyPond http://lilypond.org
Freelance IT http://JoyofSource.com | Avatar®  http://AvatarAcademy.nl