From 53ac439c6a56019a3ea2d84b677c7cf64247ecff Mon Sep 17 00:00:00 2001 From: Scott Owens Date: Thu, 10 Jan 2002 23:24:58 +0000 Subject: [PATCH] *** empty log message *** original commit: abf74d9040aa14a62d261a93e4cde5bca6f96f7e --- .../private-yacc/input-file-parser.ss | 18 +- .../private-yacc/parser-builder.ss | 22 +- collects/parser-tools/yacc.ss | 225 +++++++++--------- 3 files changed, 140 insertions(+), 125 deletions(-) diff --git a/collects/parser-tools/private-yacc/input-file-parser.ss b/collects/parser-tools/private-yacc/input-file-parser.ss index 20d40f1..bd7ae2b 100644 --- a/collects/parser-tools/private-yacc/input-file-parser.ss +++ b/collects/parser-tools/private-yacc/input-file-parser.ss @@ -9,12 +9,18 @@ (provide parse-input) ;; get-args: num * syntax-object -> syntax-object list - (define (get-args x act) + (define (get-args x act src-pos) (let loop ((i 1)) (cond ((> i x) null) - (else (cons (datum->syntax-object act (string->symbol (format "$~a" i))) - (loop (add1 i))))))) + (else + (if src-pos + `(,(datum->syntax-object act (string->symbol (format "$~a" i))) + ,(datum->syntax-object act (string->symbol (format "$~a-start-pos" i))) + ,(datum->syntax-object act (string->symbol (format "$~a-end-pos" i))) + ,@(loop (add1 i))) + `(,(datum->syntax-object act (string->symbol (format "$~a" i))) + ,@(loop (add1 i)))))))) ;; nullable: production list * int -> non-term set ;; determines which non-terminals can derive epsilon @@ -111,8 +117,8 @@ "undefined token group" term-syn))))) - ;; parse-input: syntax-object * syntax-object list * syntax-object^4 -> grammar - (define (parse-input start ends term-defs prec-decls prods runtime) + ;; parse-input: syntax-object * syntax-object list * syntax-object^4 * boolean-> grammar + (define (parse-input start ends term-defs prec-decls prods runtime src-pos) (let* ((counter 0) (start-sym (syntax-object->datum start)) @@ -285,7 +291,7 @@ (lambda (prod act) (datum->syntax-object runtime - `(lambda ,(get-args (vector-length prod) act) + `(lambda ,(get-args (vector-length prod) act src-pos) ,act) act))) diff --git a/collects/parser-tools/private-yacc/parser-builder.ss b/collects/parser-tools/private-yacc/parser-builder.ss index 3454100..ce8740a 100644 --- a/collects/parser-tools/private-yacc/parser-builder.ss +++ b/collects/parser-tools/private-yacc/parser-builder.ss @@ -8,8 +8,8 @@ (provide build-parser) - (define (build-parser filename suppress error-expr input-terms start end assocs prods runtime src) - (let* ((grammar (parse-input start end input-terms assocs prods runtime)) + (define (build-parser filename src-pos suppress error-expr input-terms start end assocs prods runtime src) + (let* ((grammar (parse-input start end input-terms assocs prods runtime src-pos)) (table (build-table grammar filename suppress)) (table-code `((lambda (table-list) @@ -67,7 +67,9 @@ (reduce-stack (lambda (s n v) (if (> n 0) - (reduce-stack (cddr s) (sub1 n) (cons (cadr s) v)) + ,(if src-pos + `(reduce-stack (cddr s) (sub1 n) `(,(cadr s) ,(caddr s) ,(cadddr s) ,@v)) + `(reduce-stack (cddr s) (sub1 n) (cons (cadr s) v))) (values s v)))) (fix-error (lambda (stack ip get-token) @@ -119,18 +121,22 @@ (lambda (get-token) (let parsing-loop ((stack (list 0)) (ip (get-token))) + ;;(display stack) ;;(newline) ;;(display (if (token? ip) (token-name ip) ip)) ;;(newline) - (let ((action (find-action stack ip))) + (let* ((tok ,(if src-pos `(car ip) `ip)) + (action (find-action stack tok))) (cond ((shift? action) ;; (printf "shift:~a~n" (shift-state action)) - (let ((val (if (token? ip) - (token-value ip) + (let ((val (if (token? tok) + (token-value tok) #f))) - (parsing-loop (cons (shift-state action) (cons val stack)) + (parsing-loop ,(if src-pos + ``(,(shift-state action) ,val ,(cadr ip) ,(caddr ip) ,@stack) + ``(,(shift-state action) ,val ,@stack)) (get-token)))) ((reduce? action) ;; (printf "reduce:~a~n" (reduce-prod-num action)) @@ -152,7 +158,7 @@ (cadr stack)) (else (err ip) - (let ((new-stack (fix-error stack ip get-token))) + (let ((new-stack (fix-error stack tok get-token))) (if new-stack (parsing-loop new-stack (get-token)) (void))))))))))) diff --git a/collects/parser-tools/yacc.ss b/collects/parser-tools/yacc.ss index c7990cc..9e437d1 100644 --- a/collects/parser-tools/yacc.ss +++ b/collects/parser-tools/yacc.ss @@ -1,6 +1,6 @@ #cs (module yacc mzscheme - + (require-for-syntax "private-yacc/parser-builder.ss" "private-yacc/yacc-helper.ss") (require "private-yacc/parser-actions.ss" @@ -8,117 +8,120 @@ "private-lex/token.ss") (provide parser) - - (define-syntax parser - (lambda (stx) - (syntax-case stx () - ((_ args ...) - (let ((arg-list (syntax->list (syntax (args ...)))) - (debug #f) - (error #f) - (tokens #f) - (start #f) - (end #f) - (precs #f) - (suppress #f) - (grammar #f)) - (for-each - (lambda (arg) - (syntax-case* arg (debug error tokens start end precs grammar suppress) - (lambda (a b) - (eq? (syntax-object->datum a) (syntax-object->datum b))) - ((debug filename) - (cond - ((not (string? (syntax-object->datum (syntax filename)))) - (raise-syntax-error - 'parser-debug - "Debugging filename must be a string" - (syntax filename))) - (debug - (raise-syntax-error #f "Multiple debug declarations" stx)) - (else - (set! debug (syntax-object->datum (syntax filename)))))) - ((suppress) - (set! suppress #t)) - ((error expression) - (if error - (raise-syntax-error #f "Multiple error declarations" stx) - (set! error (syntax expression)))) - ((tokens def ...) - (if tokens - (raise-syntax-error #f "Multiple tokens declarations" stx) - (set! tokens arg))) - ((start symbol) - (cond - ((not (identifier? (syntax symbol))) - (raise-syntax-error - 'parser-start - "Start non-terminal must be a symbol" - (syntax symbol))) - (start - (raise-syntax-error #f "Multiple start declarations" stx)) - (else - (set! start (syntax symbol))))) - ((end symbols ...) - (begin - (for-each - (lambda (sym) - (if (not (identifier? sym)) - (raise-syntax-error - 'parser-end - "End token must be a symbol" - sym))) - (syntax->list (syntax (symbols ...)))) - (let ((d (duplicate-list? (syntax-object->datum - (syntax (symbols ...)))))) - (if d - (raise-syntax-error - 'parser-end - (format "Duplicate end token definition for ~a" d) - arg))) - (if (= 0 (length (syntax->list (syntax (symbols ...))))) + + (define-syntax (parser stx) + (syntax-case stx () + ((_ args ...) + (let ((arg-list (syntax->list (syntax (args ...)))) + (src-pos #f) + (debug #f) + (error #f) + (tokens #f) + (start #f) + (end #f) + (precs #f) + (suppress #f) + (grammar #f)) + (for-each + (lambda (arg) + (syntax-case* arg (debug error tokens start end precs grammar suppress src-pos) + (lambda (a b) + (eq? (syntax-object->datum a) (syntax-object->datum b))) + ((debug filename) + (cond + ((not (string? (syntax-object->datum (syntax filename)))) + (raise-syntax-error + 'parser-debug + "Debugging filename must be a string" + (syntax filename))) + (debug + (raise-syntax-error #f "Multiple debug declarations" stx)) + (else + (set! debug (syntax-object->datum (syntax filename)))))) + ((suppress) + (set! suppress #t)) + ((src-pos) + (set! src-pos #t)) + ((error expression) + (if error + (raise-syntax-error #f "Multiple error declarations" stx) + (set! error (syntax expression)))) + ((tokens def ...) + (if tokens + (raise-syntax-error #f "Multiple tokens declarations" stx) + (set! tokens arg))) + ((start symbol) + (cond + ((not (identifier? (syntax symbol))) + (raise-syntax-error + 'parser-start + "Start non-terminal must be a symbol" + (syntax symbol))) + (start + (raise-syntax-error #f "Multiple start declarations" stx)) + (else + (set! start (syntax symbol))))) + ((end symbols ...) + (begin + (for-each + (lambda (sym) + (if (not (identifier? sym)) + (raise-syntax-error + 'parser-end + "End token must be a symbol" + sym))) + (syntax->list (syntax (symbols ...)))) + (let ((d (duplicate-list? (syntax-object->datum + (syntax (symbols ...)))))) + (if d (raise-syntax-error 'parser-end - "end declaration must contain at least 1 token" - arg)) - (if end - (raise-syntax-error #f "Multiple end declarations" stx)) - (set! end (syntax->list (syntax (symbols ...)))))) - ((precs decls ...) - (if precs - (raise-syntax-error #f "Multiple precs declarations" stx) - (set! precs arg))) - ((grammar prods ...) - (if grammar - (raise-syntax-error #f "Multiple grammar declarations" stx) - (set! grammar arg))) - (_ (raise-syntax-error 'parser-args "argument must match (debug filename), (error expression), (tokens def ...), (start non-term), (end tokens ...), (precs decls ...), or (grammar prods ...)" arg)))) - (syntax->list (syntax (args ...)))) - (if (not tokens) - (raise-syntax-error #f "missing tokens declaration" stx)) - (if (not error) - (raise-syntax-error #f "missing error declaration" stx)) - (if (not grammar) - (raise-syntax-error #f "missing grammar declaration" stx)) - (if (not end) - (raise-syntax-error #f "missing end declaration" stx)) - (if (not start) - (raise-syntax-error #f "missing start declaration" stx)) - (build-parser (if debug debug "") - suppress - error - tokens - start - end - precs - grammar - #'here - stx))) - (_ - (raise-syntax-error - #f - "parser must have the form (parser args ...)" - stx))))) - + (format "Duplicate end token definition for ~a" d) + arg))) + (if (= 0 (length (syntax->list (syntax (symbols ...))))) + (raise-syntax-error + 'parser-end + "end declaration must contain at least 1 token" + arg)) + (if end + (raise-syntax-error #f "Multiple end declarations" stx)) + (set! end (syntax->list (syntax (symbols ...)))))) + ((precs decls ...) + (if precs + (raise-syntax-error #f "Multiple precs declarations" stx) + (set! precs arg))) + ((grammar prods ...) + (if grammar + (raise-syntax-error #f "Multiple grammar declarations" stx) + (set! grammar arg))) + (_ (raise-syntax-error 'parser-args "argument must match (debug filename), (error expression), (tokens def ...), (start non-term), (end tokens ...), (precs decls ...), or (grammar prods ...)" arg)))) + (syntax->list (syntax (args ...)))) + (if (not tokens) + (raise-syntax-error #f "missing tokens declaration" stx)) + (if (not error) + (raise-syntax-error #f "missing error declaration" stx)) + (if (not grammar) + (raise-syntax-error #f "missing grammar declaration" stx)) + (if (not end) + (raise-syntax-error #f "missing end declaration" stx)) + (if (not start) + (raise-syntax-error #f "missing start declaration" stx)) + (build-parser (if debug debug "") + src-pos + suppress + error + tokens + start + end + precs + grammar + #'here + stx))) + (_ + (raise-syntax-error + #f + "parser must have the form (parser args ...)" + stx)))) + ) \ No newline at end of file