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-num-prods grammar-num-prods)
(rename gram-prods grammar-prods)
(rename gram-end-terms grammar-end-terms)
;; Things that work on productions
prod-index prod-prec prod-rhs prod-lhs prod-action)
@ -155,7 +156,8 @@
;; (bool vector)
;; (non-term list)
;; (term list)
;; int)
;; int
;; (term list))
;;
;; The nt-prods field is indexed by the number assigned to the non-term and
;; 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 non-term is nullable
(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

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

@ -111,31 +111,44 @@
"undefined token group"
term-syn)))))
;; parse-input: syntax-object^4 * string -> grammar
(define (parse-input start term-defs prec-decls prods runtime)
;; parse-input: syntax-object * syntax-object list * syntax-object^4 -> grammar
(define (parse-input start ends term-defs prec-decls prods runtime)
(let* ((counter 0)
(start-sym (syntax-object->datum start))
;; Get the list of terminals out of input-terms
(list-of-terms
(syntax-case term-defs ()
((term-def ...)
(andmap identifier? (syntax->list term-defs))
(syntax-case term-defs (tokens)
((tokens term-def ...)
(andmap identifier? (syntax->list (syntax (term-def ...))))
(remove-duplicates
(apply append
(map get-terms-from-def
(syntax->list term-defs)))))
(cons 'error
(apply append
(map get-terms-from-def
(syntax->list (syntax (term-def ...))))))))
(_
(raise-syntax-error
'parser-tokens
"Token list must be (symbol ...)"
"Token declaration must be (tokens symbol ...)"
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
(syntax-case prods ()
(((non-term production ...) ...)
(syntax-case prods (grammar)
((grammar (non-term production ...) ...)
(begin
(for-each
(lambda (nts)
@ -167,14 +180,14 @@
(syntax-object->datum (syntax (non-term ...)))))
(_
(raise-syntax-error
'parser-productions
"Productions must be of the form ((non-terminal productions ...) ...)"
'parser-grammar
"Grammar must be of the form (grammar (non-terminal productions ...) ...)"
prods))))
;; Check the precedence declarations for errors and turn them into data
(precs
(syntax-case prec-decls ()
(((type term ...) ...)
(syntax-case prec-decls (precs)
((precs (type term ...) ...)
(let ((p-terms
(apply append (syntax-object->datum
(syntax ((term ...) ...))))))
@ -210,11 +223,11 @@
"Associativity must be left, right or nonassoc"
type)))
(syntax->list (syntax (type ...))))
(syntax-object->datum prec-decls)))))
(cdr (syntax-object->datum prec-decls))))))
(_
(raise-syntax-error
'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))))
(terms (build-terms list-of-terms precs))
@ -346,14 +359,14 @@
(prods
(cons
(list (make-prod start
(vector (hash-table-get non-term-table
start-sym))
(vector (hash-table-get non-term-table start-sym)
(hash-table-get term-table (car end-terms)))
0
#f
(datum->syntax-object
runtime
`(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)
(add1 (length non-terms)))))
@ -376,4 +389,5 @@
nulls
(cons start non-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?
shift-state reduce-prod-num reduce-lhs-num reduce-rhs-length
make-shift make-reduce)
make-shift make-reduce make-accept)
;; action = (shift 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)
(define (build-parser start input-terms assocs prods filename runtime src)
(let* ((grammar (parse-input start input-terms assocs prods runtime))
(define (build-parser filename error-expr input-terms start end assocs prods runtime src)
(let* ((grammar (parse-input start end input-terms assocs prods runtime))
(table (build-table grammar filename))
(table-code
(cons 'vector
@ -42,7 +42,8 @@
`(vector ,@(map prod-action (grammar-prods grammar))))
(parser-code
`(letrec ((term-sym->index ,token-code)
`(letrec ((err ,error-expr)
(term-sym->index ,token-code)
(table ,table-code)
(actions ,actions-code)
(reduce-stack
@ -61,7 +62,8 @@
(a (hash-table-get term-sym->index
(if (token? ip)
(token-name ip)
ip)))
ip)
err))
(action (array2d-ref table s a)))
(cond
((shift? action)
@ -88,7 +90,7 @@
ip))))
((accept? action)
(printf "accept~n"))
(else (error 'parser)))))))))
(else (err)))))))))
(datum->syntax-object
runtime
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))))))))
(get-lookahead (vector-ref get-state state)
(item-prod item))))
items))
items))
(loop (add1 state)))))
(resolve-prec-conflicts table get-term get-prod num-states num-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 (define-tokens-helper stx hack empty?)
(define (define-tokens-helper stx runtime empty?)
(syntax-case stx ()
((_ name (terms ...))
(andmap identifier? (syntax->list (syntax (terms ...))))
(datum->syntax-object
hack
runtime
`(begin
(define-syntax ,(syntax name)
(make-terminals-def ',(syntax (terms ...))))
,@(map
(lambda (n)
(if (eq? (syntax-object->datum n) 'error)
(raise-syntax-error
#f
"Cannot define a token named error."
stx))
`(define (,(datum->syntax-object
n
(string->symbol

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

@ -1,40 +1,102 @@
#cs
(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"
"private-yacc/parser-actions.ss"
"private-yacc/array2d.ss")
(provide define-tokens define-empty-tokens parser parser-debug)
(provide define-tokens define-empty-tokens parser)
(define-syntax parser
(lambda (stx)
(syntax-case stx ()
((_ start input-terms assocs prods)
(build-parser (syntax start) (syntax input-terms)
(syntax assocs) (syntax prods)
"" #'here stx))
((_ args ...)
(let ((arg-list (syntax->list (syntax (args ...))))
(debug #f)
(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
#f
"parser must have the form (parser start-symbol tokens precedence/associativity productions)"
"parser must have the form (parser args ...)"
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