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

[Jan Nieuwenhuizen]

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

>From a6aac9d20d9d64f475780b59011c1e7e0cb1670a Mon Sep 17 00:00:00 2001
From: Jan Nieuwenhuizen <address@hidden>
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

>From ddbbc3874bfdcefa23622edc16175c9881342194 Mon Sep 17 00:00:00 2001
From: Jan Nieuwenhuizen <address@hidden>
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 <address@hidden>
 ;; 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

>From cce9b448ad15a7c70d710ec7a5779ed27c8a3e4c Mon Sep 17 00:00:00 2001
From: Jan Nieuwenhuizen <address@hidden>
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


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