[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/02: Update (system base lalr) from upstream.
|
From: |
Ludovic Courtès |
|
Subject: |
[Guile-commits] 02/02: Update (system base lalr) from upstream. |
|
Date: |
Tue, 02 Dec 2014 20:26:21 +0000 |
civodul pushed a commit to branch stable-2.0
in repository guile.
commit 8cf2a7ba7432d68b9a055d29f18117be70375af9
Author: Ludovic Courtès <address@hidden>
Date: Tue Dec 2 21:25:26 2014 +0100
Update (system base lalr) from upstream.
Suggested by Jan Nieuwenhuizen <address@hidden>.
* module/system/base/lalr.upstream.scm: Update from
<https://github.com/schemeway/lalr-scm.git>, commit 4c4f149.
---
module/system/base/lalr.upstream.scm | 99 ++++++++++++++++++++--------------
1 files changed, 59 insertions(+), 40 deletions(-)
diff --git a/module/system/base/lalr.upstream.scm
b/module/system/base/lalr.upstream.scm
index 217c439..d2c0872 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
@@ -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