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