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

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

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

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

@ -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))))
)
Write Preview
Loading…
Cancel
Save