Bison-like source locations in LALR-parser

Bison-like source locations in LALR-parser

[Jan Nieuwenhuizen]

Hi,

I am using these patches to provide Bison-like source locations that we
need for error messages and the like.  The output of the parser is a
plain scheme tree, now transparently annotated with source locations
that match the parsed input file.

What do you think?

Greetings, Jan
-- 
Jan Nieuwenhuizen <janneke@gnu.org> | GNU LilyPond http://lilypond.org
Freelance IT http://JoyofSource.com | Avatar®  http://AvatarAcademy.nl  

[PATCH 1/2] LALR-parser: provide bison-like location constructs @1 ... @n.

[Jan Nieuwenhuizen]

	* module/system/base/lalr.upstream.scm (lalr-parser): Provide
	bison-like positional location constructs: @1 ... @n.
	(*lalr-scm-version*): Bump to 2.5.0.
---
 module/system/base/lalr.upstream.scm | 40 ++++++++++++++++--------------------
 1 file changed, 18 insertions(+), 22 deletions(-)

diff --git a/module/system/base/lalr.upstream.scm b/module/system/base/lalr.upstream.scm
index 217c439..b250c23 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 
@@ -1591,17 +1592,19 @@
 		     `(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)
@@ -1879,17 +1882,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 +1915,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))
              
@@ -2025,8 +2022,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 +2040,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
-- 
Jan Nieuwenhuizen <janneke@gnu.org> | GNU LilyPond http://lilypond.org
Freelance IT http://JoyofSource.com | Avatar®  http://AvatarAcademy.nl  

[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 <janneke@gnu.org> | GNU LilyPond http://lilypond.org
Freelance IT http://JoyofSource.com | Avatar®  http://AvatarAcademy.nl  

Re: Bison-like source locations in LALR-parser

[Ludovic Courtès]

Hi, Jan,

Jan Nieuwenhuizen <janneke@gnu.org> skribis:

> I am using these patches to provide Bison-like source locations that we
> need for error messages and the like.  The output of the parser is a
> plain scheme tree, now transparently annotated with source locations
> that match the parsed input file.

I don’t think this is needed.  Lexers are expected to use
‘make-lexical-token’ and ‘make-source-location’ from (system base lalr)
to preserve source location information.

Besides, note that lalr.upstream.scm is a copy of the upstream lalr-scm,
hosted at <http://code.google.com/p/lalr-scm/>.

HTH,
Ludo’.

Re: Bison-like source locations in LALR-parser

[Jan Nieuwenhuizen]

Ludovic Courtès writes:

Hi Ludo,

> I don’t think this is needed.  Lexers are expected to use
> ‘make-lexical-token’ and ‘make-source-location’ from (system base lalr)
> to preserve source location information.

I hope you're right...and that's what I tried, but I didn't get it
working.  Possibly I need to cook-up a small example.

What I found was that, yes the LEXER has all it needs, but once you
get to construction rules in the parser; say

   (interface-spec
    (interface Identifier lbrace type-list event-list optional-behaviour rbrace) : `(,$1 ,$2 ,$4 ,$5 ,$6))

all it sees is the values, i.e. strings of the tokens that the lexer
sees.  The lexer cannot hand tokens to the parser, AFAICS.

What my patches do, is that for elements in the list that I construct
above that support source-properties, including the list itself, the
source location is set transparently.

Sometimes that is not enough, and you can use

   @1 ... @n

to set the source location explicitly.

> Besides, note that lalr.upstream.scm is a copy of the upstream lalr-scm,
> hosted at <http://code.google.com/p/lalr-scm/>.

Yes...that's looks quit dead.  Isn't it?  I can try though...

Greetings, Jan

-- 
Jan Nieuwenhuizen <janneke@gnu.org> | GNU LilyPond http://lilypond.org
Freelance IT http://JoyofSource.com | Avatar®  http://AvatarAcademy.nl  

Re: Bison-like source locations in LALR-parser

[Ludovic Courtès]

Hi,

Jan Nieuwenhuizen <janneke@gnu.org> skribis:

> Ludovic Courtès writes:
>
>> I don’t think this is needed.  Lexers are expected to use
>> ‘make-lexical-token’ and ‘make-source-location’ from (system base lalr)
>> to preserve source location information.
>
> I hope you're right...and that's what I tried, but I didn't get it
> working.  Possibly I need to cook-up a small example.
>
> What I found was that, yes the LEXER has all it needs, but once you
> get to construction rules in the parser; say
>
>    (interface-spec
>     (interface Identifier lbrace type-list event-list optional-behaviour rbrace) : `(,$1 ,$2 ,$4 ,$5 ,$6))
>
> all it sees is the values, i.e. strings of the tokens that the lexer
> sees.  The lexer cannot hand tokens to the parser, AFAICS.

Here’s an example:

http://git.savannah.gnu.org/cgit/guile-rpc.git/tree/modules/rpc/compiler/lexer.l
http://git.savannah.gnu.org/cgit/guile-rpc.git/tree/modules/Makefile.am#n58
http://git.savannah.gnu.org/cgit/guile-rpc.git/tree/modules/rpc/compiler/parser.scm#n101

Note that actually, the ‘location’ produced by Makefile.am does:

  (make-lexical-token type (make-source-location ...)
                      (append value (list (vector line column))))

So the line/column info is also stored alongside the token’s value, and
then access from parser.scm with those cadr calls.

>> Besides, note that lalr.upstream.scm is a copy of the upstream lalr-scm,
>> hosted at <http://code.google.com/p/lalr-scm/>.
>
> Yes...that's looks quit dead.  Isn't it?  I can try though...

Well, that’s because it’s “finished.”  :-)

But yeah, it’s worth trying.  Dominique has been responsive and helpful
in the past.

Thanks,
Ludo’.

Re: Bison-like source locations in LALR-parser -- upstream update

[Jan Nieuwenhuizen]

[-- Attachment #1: Type: text/plain, Size: 1195 bytes --]

Ludovic Courtès writes:

Hi,

>>> I don’t think this is needed.  Lexers are expected to use
>>> ‘make-lexical-token’ and ‘make-source-location’ from (system base lalr)
>>> to preserve source location information.

>> I hope you're right...and that's what I tried, but I didn't get it
>> working.  Possibly I need to cook-up a small example.

> Here’s an example:
>
> http://git.savannah.gnu.org/cgit/guile-rpc.git/tree/modules/rpc/compiler/lexer.l

Thanks for the example!  To me that is still a nice hack and that is why
I think that more straightforward bison-like parser support would be
nice.

>> Yes...that's looks quit dead.  Isn't it?  I can try though...
>
> Well, that’s because it’s “finished.”  :-)

Heheh, yeah right ;-)

> But yeah, it’s worth trying.  Dominique has been responsive and helpful
> in the past.

Dominique was indeed very responsive and helpful.  He expressed that he
found my patches very interesting, found two problems, suggested how
to fix those and merged them.

Find attached the three patches pulled verbatim from upstream that Guile
is behind on now, the first one is by Dominique.

Greetings, Jan


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-LALR-parser-No-more-unexpected-shift-reduce-conflict.patch --]
[-- Type: text/x-diff, Size: 2831 bytes --]

From a6aac9d20d9d64f475780b59011c1e7e0cb1670a Mon Sep 17 00:00:00 2001
From: Jan Nieuwenhuizen <janneke@gnu.org>
Date: Sun, 5 Oct 2014 12:07:03 +0200
Subject: [PATCH 1/3] LALR-parser: No more unexpected shift-reduce conflicts
 with LR driver.

---
 module/system/base/lalr.upstream.scm | 18 +++++++++++++-----
 1 file changed, 13 insertions(+), 5 deletions(-)

diff --git a/module/system/base/lalr.upstream.scm b/module/system/base/lalr.upstream.scm
index 217c439..ecc0fb3 100755
--- a/module/system/base/lalr.upstream.scm
+++ b/module/system/base/lalr.upstream.scm
@@ -235,6 +235,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 +1102,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 +1118,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 +1137,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)
-- 
/home/janneke/.signature


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: 0002-LALR-parser-provide-bison-like-location-constructs-1.patch --]
[-- Type: text/x-diff, Size: 4519 bytes --]

From ddbbc3874bfdcefa23622edc16175c9881342194 Mon Sep 17 00:00:00 2001
From: Jan Nieuwenhuizen <janneke@gnu.org>
Date: Sun, 5 Oct 2014 12:08:24 +0200
Subject: [PATCH 2/3] LALR-parser: provide bison-like location constructs @1
 ... @n.

    * module/system/base/lalr.upstream.scm (lalr-parser): Provide
    bison-like positional location constructs: @1 ... @n.
    (*lalr-scm-version*): Bump to 2.5.0.
---
 module/system/base/lalr.upstream.scm | 40 ++++++++++++++++--------------------
 1 file changed, 18 insertions(+), 22 deletions(-)

diff --git a/module/system/base/lalr.upstream.scm b/module/system/base/lalr.upstream.scm
index ecc0fb3..8e915f9 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 
@@ -1599,17 +1600,19 @@
 		     `(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)
@@ -1887,17 +1890,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))
@@ -1926,7 +1923,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))
              
@@ -2033,8 +2030,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 '()))
@@ -2052,7 +2048,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
-- 
/home/janneke/.signature


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #4: 0003-LALR-parser-transparent-source-locations-using-sourc.patch --]
[-- Type: text/x-diff, Size: 5264 bytes --]

From cce9b448ad15a7c70d710ec7a5779ed27c8a3e4c Mon Sep 17 00:00:00 2001
From: Jan Nieuwenhuizen <janneke@gnu.org>
Date: Sun, 5 Oct 2014 12:13:00 +0200
Subject: [PATCH 3/3] LALR-parser: transparent source locations using
 source-proprerties.

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

diff --git a/module/system/base/lalr.upstream.scm b/module/system/base/lalr.upstream.scm
index 8e915f9..d2c0872 100755
--- a/module/system/base/lalr.upstream.scm
+++ b/module/system/base/lalr.upstream.scm
@@ -34,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
@@ -45,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
@@ -57,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
@@ -68,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
@@ -79,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
@@ -88,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
@@ -99,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")))
@@ -1617,7 +1629,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 (- ___sp ,(length rhs)))
+                                            `(list-ref ___sp ,(length rhs))))))))))
 
 	   gram/actions))))
 
@@ -1833,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))
@@ -2008,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))
-- 
/home/janneke/.signature


[-- Attachment #5: Type: text/plain, Size: 156 bytes --]



-- 
Jan Nieuwenhuizen <janneke@gnu.org> | GNU LilyPond http://lilypond.org
Freelance IT http://JoyofSource.com | Avatar®  http://AvatarAcademy.nl  

Re: Bison-like source locations in LALR-parser -- upstream update

[Ludovic Courtès]

Hi Jan,

I’ve (finally!) pushed the LALR update from upstream to the ‘stable-2.0’
branch.

Thanks again, and sorry for the delay.

Ludo’.