;;;
;;;; 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
;; 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
(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
(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
(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
(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
(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
(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
(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")))
(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
(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
(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)))
(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)
`(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))))
(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))
(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))
;; 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))
(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))
(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 '()))
(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
HCoop / bpt / guile.git / commitdiff