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)))))))))))

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

@ -1,6 +1,6 @@
#cs #cs
(module yacc mzscheme (module yacc mzscheme
(require-for-syntax "private-yacc/parser-builder.ss" (require-for-syntax "private-yacc/parser-builder.ss"
"private-yacc/yacc-helper.ss") "private-yacc/yacc-helper.ss")
(require "private-yacc/parser-actions.ss" (require "private-yacc/parser-actions.ss"
@ -8,117 +8,120 @@
"private-lex/token.ss") "private-lex/token.ss")
(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)
(start #f) (start #f)
(end #f) (end #f)
(precs #f) (precs #f)
(suppress #f) (suppress #f)
(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)
(cond (cond
((not (string? (syntax-object->datum (syntax filename)))) ((not (string? (syntax-object->datum (syntax filename))))
(raise-syntax-error (raise-syntax-error
'parser-debug 'parser-debug
"Debugging filename must be a string" "Debugging filename must be a string"
(syntax filename))) (syntax filename)))
(debug (debug
(raise-syntax-error #f "Multiple debug declarations" stx)) (raise-syntax-error #f "Multiple debug declarations" stx))
(else (else
(set! debug (syntax-object->datum (syntax filename)))))) (set! debug (syntax-object->datum (syntax filename))))))
((suppress) ((suppress)
(set! suppress #t)) (set! suppress #t))
((error expression) ((src-pos)
(if error (set! src-pos #t))
(raise-syntax-error #f "Multiple error declarations" stx) ((error expression)
(set! error (syntax expression)))) (if error
((tokens def ...) (raise-syntax-error #f "Multiple error declarations" stx)
(if tokens (set! error (syntax expression))))
(raise-syntax-error #f "Multiple tokens declarations" stx) ((tokens def ...)
(set! tokens arg))) (if tokens
((start symbol) (raise-syntax-error #f "Multiple tokens declarations" stx)
(cond (set! tokens arg)))
((not (identifier? (syntax symbol))) ((start symbol)
(raise-syntax-error (cond
'parser-start ((not (identifier? (syntax symbol)))
"Start non-terminal must be a symbol" (raise-syntax-error
(syntax symbol))) 'parser-start
(start "Start non-terminal must be a symbol"
(raise-syntax-error #f "Multiple start declarations" stx)) (syntax symbol)))
(else (start
(set! start (syntax symbol))))) (raise-syntax-error #f "Multiple start declarations" stx))
((end symbols ...) (else
(begin (set! start (syntax symbol)))))
(for-each ((end symbols ...)
(lambda (sym) (begin
(if (not (identifier? sym)) (for-each
(raise-syntax-error (lambda (sym)
'parser-end (if (not (identifier? sym))
"End token must be a symbol" (raise-syntax-error
sym))) 'parser-end
(syntax->list (syntax (symbols ...)))) "End token must be a symbol"
(let ((d (duplicate-list? (syntax-object->datum sym)))
(syntax (symbols ...)))))) (syntax->list (syntax (symbols ...))))
(if d (let ((d (duplicate-list? (syntax-object->datum
(raise-syntax-error (syntax (symbols ...))))))
'parser-end (if d
(format "Duplicate end token definition for ~a" d)
arg)))
(if (= 0 (length (syntax->list (syntax (symbols ...)))))
(raise-syntax-error (raise-syntax-error
'parser-end 'parser-end
"end declaration must contain at least 1 token" (format "Duplicate end token definition for ~a" d)
arg)) arg)))
(if end (if (= 0 (length (syntax->list (syntax (symbols ...)))))
(raise-syntax-error #f "Multiple end declarations" stx)) (raise-syntax-error
(set! end (syntax->list (syntax (symbols ...)))))) 'parser-end
((precs decls ...) "end declaration must contain at least 1 token"
(if precs arg))
(raise-syntax-error #f "Multiple precs declarations" stx) (if end
(set! precs arg))) (raise-syntax-error #f "Multiple end declarations" stx))
((grammar prods ...) (set! end (syntax->list (syntax (symbols ...))))))
(if grammar ((precs decls ...)
(raise-syntax-error #f "Multiple grammar declarations" stx) (if precs
(set! grammar arg))) (raise-syntax-error #f "Multiple precs declarations" stx)
(_ (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)))) (set! precs arg)))
(syntax->list (syntax (args ...)))) ((grammar prods ...)
(if (not tokens) (if grammar
(raise-syntax-error #f "missing tokens declaration" stx)) (raise-syntax-error #f "Multiple grammar declarations" stx)
(if (not error) (set! grammar arg)))
(raise-syntax-error #f "missing error declaration" stx)) (_ (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))))
(if (not grammar) (syntax->list (syntax (args ...))))
(raise-syntax-error #f "missing grammar declaration" stx)) (if (not tokens)
(if (not end) (raise-syntax-error #f "missing tokens declaration" stx))
(raise-syntax-error #f "missing end declaration" stx)) (if (not error)
(if (not start) (raise-syntax-error #f "missing error declaration" stx))
(raise-syntax-error #f "missing start declaration" stx)) (if (not grammar)
(build-parser (if debug debug "") (raise-syntax-error #f "missing grammar declaration" stx))
suppress (if (not end)
error (raise-syntax-error #f "missing end declaration" stx))
tokens (if (not start)
start (raise-syntax-error #f "missing start declaration" stx))
end (build-parser (if debug debug "")
precs src-pos
grammar suppress
#'here error
stx))) tokens
(_ start
(raise-syntax-error end
#f precs
"parser must have the form (parser args ...)" grammar
stx))))) #'here
stx)))
(_
(raise-syntax-error
#f
"parser must have the form (parser args ...)"
stx))))
) )
Write Preview
Loading…
Cancel
Save