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

*** empty log message ***

Browse Source 
original commit: 6f4bc60db3c345db50ebd3d711b4571abc01e905
tokens
Scott Owens 23 years ago
parent fb9cf08639
commit ba3e2af0f8
7 changed files with 141 additions and 57 deletions
Show Stats Download Patch File Download Diff File

6
collects/parser-tools/private-yacc/grammar.ss
Unescape Escape View File

@ -30,6 +30,7 @@
(rename gram-terms grammar-terms) (rename gram-terms grammar-terms)
(rename gram-num-prods grammar-num-prods) (rename gram-num-prods grammar-num-prods)
(rename gram-prods grammar-prods) (rename gram-prods grammar-prods)
(rename gram-end-terms grammar-end-terms)
;; Things that work on productions ;; Things that work on productions
prod-index prod-prec prod-rhs prod-lhs prod-action) prod-index prod-prec prod-rhs prod-lhs prod-action)
@ -155,7 +156,8 @@
;; (bool vector) ;; (bool vector)
;; (non-term list) ;; (non-term list)
;; (term list) ;; (term list)
;; int) ;; int
;; (term list))
;; ;;
;; The nt-prods field is indexed by the number assigned to the non-term and ;; The nt-prods field is indexed by the number assigned to the non-term and
;; contains the list of productions for that non-term ;; contains the list of productions for that non-term
@ -163,7 +165,7 @@
;; The nulls field is indexed by the index for a non-term and is trus iff ;; The nulls field is indexed by the index for a non-term and is trus iff
;; the non-term is nullable ;; the non-term is nullable
(define-struct gram (define-struct gram
(nt-prods prods nulls non-terms terms num-prods)) (nt-prods prods nulls non-terms terms num-prods end-terms))
;; get-nt-prods: grammar * non-term -> production list ;; get-nt-prods: grammar * non-term -> production list

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

@ -111,31 +111,44 @@
"undefined token group" "undefined token group"
term-syn))))) term-syn)))))
;; parse-input: syntax-object^4 * string -> grammar ;; parse-input: syntax-object * syntax-object list * syntax-object^4 -> grammar
(define (parse-input start term-defs prec-decls prods runtime) (define (parse-input start ends term-defs prec-decls prods runtime)
(let* ((counter 0) (let* ((counter 0)
(start-sym (syntax-object->datum start)) (start-sym (syntax-object->datum start))
;; Get the list of terminals out of input-terms
(list-of-terms (list-of-terms
(syntax-case term-defs () (syntax-case term-defs (tokens)
((term-def ...) ((tokens term-def ...)
(andmap identifier? (syntax->list term-defs)) (andmap identifier? (syntax->list (syntax (term-def ...))))
(remove-duplicates (remove-duplicates
(apply append (cons 'error
(map get-terms-from-def (apply append
(syntax->list term-defs))))) (map get-terms-from-def
(syntax->list (syntax (term-def ...))))))))
(_ (_
(raise-syntax-error (raise-syntax-error
'parser-tokens 'parser-tokens
"Token list must be (symbol ...)" "Token declaration must be (tokens symbol ...)"
term-defs)))) term-defs))))
(end-terms
(map
(lambda (end)
(if (not (memq (syntax-object->datum end) list-of-terms))
(raise-syntax-error
'parser-end-tokens
(format "End token ~a not defined as a token"
(syntax-object->datum end))
end)
(syntax-object->datum end)))
ends))
;; Get the list of terminals out of input-terms
(list-of-non-terms (list-of-non-terms
(syntax-case prods () (syntax-case prods (grammar)
(((non-term production ...) ...) ((grammar (non-term production ...) ...)
(begin (begin
(for-each (for-each
(lambda (nts) (lambda (nts)
@ -167,14 +180,14 @@
(syntax-object->datum (syntax (non-term ...))))) (syntax-object->datum (syntax (non-term ...)))))
(_ (_
(raise-syntax-error (raise-syntax-error
'parser-productions 'parser-grammar
"Productions must be of the form ((non-terminal productions ...) ...)" "Grammar must be of the form (grammar (non-terminal productions ...) ...)"
prods)))) prods))))
;; Check the precedence declarations for errors and turn them into data ;; Check the precedence declarations for errors and turn them into data
(precs (precs
(syntax-case prec-decls () (syntax-case prec-decls (precs)
(((type term ...) ...) ((precs (type term ...) ...)
(let ((p-terms (let ((p-terms
(apply append (syntax-object->datum (apply append (syntax-object->datum
(syntax ((term ...) ...)))))) (syntax ((term ...) ...))))))
@ -210,11 +223,11 @@
"Associativity must be left, right or nonassoc" "Associativity must be left, right or nonassoc"
type))) type)))
(syntax->list (syntax (type ...)))) (syntax->list (syntax (type ...))))
(syntax-object->datum prec-decls))))) (cdr (syntax-object->datum prec-decls))))))
(_ (_
(raise-syntax-error (raise-syntax-error
'parser-precedences 'parser-precedences
"Precedence declaration must be of the form ((assoc term ...) ...) where assoc is left, right or nonassoc" "Precedence declaration must be of the form (precs (assoc term ...) ...) where assoc is left, right or nonassoc"
prec-decls)))) prec-decls))))
(terms (build-terms list-of-terms precs)) (terms (build-terms list-of-terms precs))
@ -346,14 +359,14 @@
(prods (prods
(cons (cons
(list (make-prod start (list (make-prod start
(vector (hash-table-get non-term-table (vector (hash-table-get non-term-table start-sym)
start-sym)) (hash-table-get term-table (car end-terms)))
0 0
#f #f
(datum->syntax-object (datum->syntax-object
runtime runtime
`(lambda (x) x)))) `(lambda (x) x))))
(map parse-prods-for-nt (syntax->list prods)))) (map parse-prods-for-nt (cdr (syntax->list prods)))))
(nulls (nullable (apply append prods) (nulls (nullable (apply append prods)
(add1 (length non-terms))))) (add1 (length non-terms)))))
@ -376,4 +389,5 @@
nulls nulls
(cons start non-terms) (cons start non-terms)
terms terms
counter)))))) counter
end-terms))))))

2
collects/parser-tools/private-yacc/parser-actions.ss
Unescape Escape View File

@ -5,7 +5,7 @@
(provide shift? reduce? accept? (provide shift? reduce? accept?
shift-state reduce-prod-num reduce-lhs-num reduce-rhs-length shift-state reduce-prod-num reduce-lhs-num reduce-rhs-length
make-shift make-reduce) make-shift make-reduce make-accept)
;; action = (shift int) ;; action = (shift int)
;; | (reduce int int int) ;; | (reduce int int int)

12
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 start input-terms assocs prods filename runtime src) (define (build-parser filename error-expr input-terms start end assocs prods runtime src)
(let* ((grammar (parse-input start input-terms assocs prods runtime)) (let* ((grammar (parse-input start end input-terms assocs prods runtime))
(table (build-table grammar filename)) (table (build-table grammar filename))
(table-code (table-code
(cons 'vector (cons 'vector
@ -42,7 +42,8 @@
`(vector ,@(map prod-action (grammar-prods grammar)))) `(vector ,@(map prod-action (grammar-prods grammar))))
(parser-code (parser-code
`(letrec ((term-sym->index ,token-code) `(letrec ((err ,error-expr)
(term-sym->index ,token-code)
(table ,table-code) (table ,table-code)
(actions ,actions-code) (actions ,actions-code)
(reduce-stack (reduce-stack
@ -61,7 +62,8 @@
(a (hash-table-get term-sym->index (a (hash-table-get term-sym->index
(if (token? ip) (if (token? ip)
(token-name ip) (token-name ip)
ip))) ip)
err))
(action (array2d-ref table s a))) (action (array2d-ref table s a)))
(cond (cond
((shift? action) ((shift? action)
@ -88,7 +90,7 @@
ip)))) ip))))
((accept? action) ((accept? action)
(printf "accept~n")) (printf "accept~n"))
(else (error 'parser))))))))) (else (err)))))))))
(datum->syntax-object (datum->syntax-object
runtime runtime
parser-code parser-code

3
collects/parser-tools/private-yacc/table.ss
Unescape Escape View File

@ -264,8 +264,7 @@
(vector-length (prod-rhs (item-prod item)))))))) (vector-length (prod-rhs (item-prod item))))))))
(get-lookahead (vector-ref get-state state) (get-lookahead (vector-ref get-state state)
(item-prod item)))) (item-prod item))))
items)) items))
(loop (add1 state))))) (loop (add1 state)))))
(resolve-prec-conflicts table get-term get-prod num-states num-terms (resolve-prec-conflicts table get-term get-prod num-states num-terms
num-non-terms) num-non-terms)

9
collects/parser-tools/private-yacc/terminal-syntax.ss
Unescape Escape View File

@ -7,17 +7,22 @@
(define-struct terminals-def (t)) (define-struct terminals-def (t))
(define (define-tokens-helper stx hack empty?) (define (define-tokens-helper stx runtime empty?)
(syntax-case stx () (syntax-case stx ()
((_ name (terms ...)) ((_ name (terms ...))
(andmap identifier? (syntax->list (syntax (terms ...)))) (andmap identifier? (syntax->list (syntax (terms ...))))
(datum->syntax-object (datum->syntax-object
hack runtime
`(begin `(begin
(define-syntax ,(syntax name) (define-syntax ,(syntax name)
(make-terminals-def ',(syntax (terms ...)))) (make-terminals-def ',(syntax (terms ...))))
,@(map ,@(map
(lambda (n) (lambda (n)
(if (eq? (syntax-object->datum n) 'error)
(raise-syntax-error
#f
"Cannot define a token named error."
stx))
`(define (,(datum->syntax-object `(define (,(datum->syntax-object
n n
(string->symbol (string->symbol

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

@ -1,40 +1,102 @@
#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")
(require "private-yacc/terminal.ss" (require "private-yacc/terminal.ss"
"private-yacc/parser-actions.ss" "private-yacc/parser-actions.ss"
"private-yacc/array2d.ss") "private-yacc/array2d.ss")
(provide define-tokens define-empty-tokens parser parser-debug) (provide define-tokens define-empty-tokens parser)
(define-syntax parser (define-syntax parser
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
((_ start input-terms assocs prods) ((_ args ...)
(build-parser (syntax start) (syntax input-terms) (let ((arg-list (syntax->list (syntax (args ...))))
(syntax assocs) (syntax prods) (debug #f)
"" #'here stx)) (error #f)
(tokens #f)
(start #f)
(end #f)
(precs #f)
(grammar #f))
(for-each
(lambda (arg)
(syntax-case arg (debug error tokens start end precs grammar)
((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))))))
((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 ...))))
(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 grammar)
(raise-syntax-error #f "missing error declaration" stx))
(if (not end)
(raise-syntax-error #f "missing end declaration" stx))
(build-parser (if debug debug "")
error
tokens
start
end
precs
grammar
#'here
stx)))
(_ (_
(raise-syntax-error (raise-syntax-error
#f #f
"parser must have the form (parser start-symbol tokens precedence/associativity productions)" "parser must have the form (parser args ...)"
stx))))) stx)))))
(define-syntax parser-debug
(lambda (stx)
(syntax-case stx ()
((_ filename start input-terms assocs prods)
(string? (syntax-object->datum (syntax filename)))
(build-parser (syntax start) (syntax input-terms)
(syntax assocs) (syntax prods)
(syntax-object->datum (syntax filename))
#'here stx))
(_
(raise-syntax-error
#f
"parser must have the form (parser-debug filename start-symbol tokens precedence/associativity productions) where filename is a string"
stx)))))
) )
Write Preview
Loading…
Cancel
Save