mbutterick
/
br-parser-tools
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

*** empty log message ***

Browse Source 
original commit: abf74d9040aa14a62d261a93e4cde5bca6f96f7e
tokens
Scott Owens 23 years ago
parent db43a04859
commit 53ac439c6a
3 changed files with 140 additions and 125 deletions
Show Stats Download Patch File Download Diff File

18
collects/parser-tools/private-yacc/input-file-parser.ss
Unescape Escape View File

@ -9,12 +9,18 @@
(provide parse-input) (provide parse-input)
;; get-args: num * syntax-object -> syntax-object list ;; get-args: num * syntax-object -> syntax-object list
(define (get-args x act) (define (get-args x act src-pos)
(let loop ((i 1)) (let loop ((i 1))
(cond (cond
((> i x) null) ((> i x) null)
(else (cons (datum->syntax-object act (string->symbol (format "$~a" i))) (else
(loop (add1 i))))))) (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 ;; nullable: production list * int -> non-term set
;; determines which non-terminals can derive epsilon ;; determines which non-terminals can derive epsilon
@ -111,8 +117,8 @@
"undefined token group" "undefined token group"
term-syn))))) term-syn)))))
;; parse-input: syntax-object * syntax-object list * syntax-object^4 -> grammar ;; parse-input: syntax-object * syntax-object list * syntax-object^4 * boolean-> grammar
(define (parse-input start ends term-defs prec-decls prods runtime) (define (parse-input start ends term-defs prec-decls prods runtime src-pos)
(let* ((counter 0) (let* ((counter 0)
(start-sym (syntax-object->datum start)) (start-sym (syntax-object->datum start))
@ -285,7 +291,7 @@
(lambda (prod act) (lambda (prod act)
(datum->syntax-object (datum->syntax-object
runtime runtime
`(lambda ,(get-args (vector-length prod) act) `(lambda ,(get-args (vector-length prod) act src-pos)
,act) ,act)
act))) act)))

22
collects/parser-tools/private-yacc/parser-builder.ss
Unescape Escape View File

@ -8,8 +8,8 @@
(provide build-parser) (provide build-parser)
(define (build-parser filename suppress error-expr input-terms start end assocs prods runtime src) (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)) (let* ((grammar (parse-input start end input-terms assocs prods runtime src-pos))
(table (build-table grammar filename suppress)) (table (build-table grammar filename suppress))
(table-code (table-code
`((lambda (table-list) `((lambda (table-list)
@ -67,7 +67,9 @@
(reduce-stack (reduce-stack
(lambda (s n v) (lambda (s n v)
(if (> n 0) (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)))) (values s v))))
(fix-error (fix-error
(lambda (stack ip get-token) (lambda (stack ip get-token)
@ -119,18 +121,22 @@
(lambda (get-token) (lambda (get-token)
(let parsing-loop ((stack (list 0)) (let parsing-loop ((stack (list 0))
(ip (get-token))) (ip (get-token)))
;;(display stack) ;;(display stack)
;;(newline) ;;(newline)
;;(display (if (token? ip) (token-name ip) ip)) ;;(display (if (token? ip) (token-name ip) ip))
;;(newline) ;;(newline)
(let ((action (find-action stack ip))) (let* ((tok ,(if src-pos `(car ip) `ip))
(action (find-action stack tok)))
(cond (cond
((shift? action) ((shift? action)
;; (printf "shift:~a~n" (shift-state action)) ;; (printf "shift:~a~n" (shift-state action))
(let ((val (if (token? ip) (let ((val (if (token? tok)
(token-value ip) (token-value tok)
#f))) #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)))) (get-token))))
((reduce? action) ((reduce? action)
;; (printf "reduce:~a~n" (reduce-prod-num action)) ;; (printf "reduce:~a~n" (reduce-prod-num action))
@ -152,7 +158,7 @@
(cadr stack)) (cadr stack))
(else (else
(err ip) (err ip)
(let ((new-stack (fix-error stack ip get-token))) (let ((new-stack (fix-error stack tok get-token)))
(if new-stack (if new-stack
(parsing-loop new-stack (get-token)) (parsing-loop new-stack (get-token))
(void))))))))))) (void)))))))))))

11
collects/parser-tools/yacc.ss
Unescape Escape View File

@ -9,11 +9,11 @@
(provide parser) (provide parser)
(define-syntax parser (define-syntax (parser stx)
(lambda (stx)
(syntax-case stx () (syntax-case stx ()
((_ args ...) ((_ args ...)
(let ((arg-list (syntax->list (syntax (args ...)))) (let ((arg-list (syntax->list (syntax (args ...))))
(src-pos #f)
(debug #f) (debug #f)
(error #f) (error #f)
(tokens #f) (tokens #f)
@ -24,7 +24,7 @@
(grammar #f)) (grammar #f))
(for-each (for-each
(lambda (arg) (lambda (arg)
(syntax-case* arg (debug error tokens start end precs grammar suppress) (syntax-case* arg (debug error tokens start end precs grammar suppress src-pos)
(lambda (a b) (lambda (a b)
(eq? (syntax-object->datum a) (syntax-object->datum b))) (eq? (syntax-object->datum a) (syntax-object->datum b)))
((debug filename) ((debug filename)
@ -40,6 +40,8 @@
(set! debug (syntax-object->datum (syntax filename)))))) (set! debug (syntax-object->datum (syntax filename))))))
((suppress) ((suppress)
(set! suppress #t)) (set! suppress #t))
((src-pos)
(set! src-pos #t))
((error expression) ((error expression)
(if error (if error
(raise-syntax-error #f "Multiple error declarations" stx) (raise-syntax-error #f "Multiple error declarations" stx)
@ -105,6 +107,7 @@
(if (not start) (if (not start)
(raise-syntax-error #f "missing start declaration" stx)) (raise-syntax-error #f "missing start declaration" stx))
(build-parser (if debug debug "") (build-parser (if debug debug "")
src-pos
suppress suppress
error error
tokens tokens
@ -118,7 +121,7 @@
(raise-syntax-error (raise-syntax-error
#f #f
"parser must have the form (parser args ...)" "parser must have the form (parser args ...)"
stx))))) stx))))
) )
Write Preview
Loading…
Cancel
Save