mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-30 17:00:23 +02:00
Code Activity

Update (system base lalr) from upstream.

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

* module/system/base/lalr.upstream.scm: Update from
  <https://github.com/schemeway/lalr-scm.git>, commit 4c4f149.
This commit is contained in:
Ludovic Courtès 2014-12-02 21:25:26 +01:00
parent 7e466e0265
commit 8cf2a7ba74
1 changed files with 59 additions and 40 deletions
Download patch file Download diff file Expand all files Collapse all files

99
module/system/base/lalr.upstream.scm
View file

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