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

*** empty log message ***

Browse Source 
original commit: 5180d0d5a689a1dd57248e8631fe24995b642d8a
tokens
Scott Owens 20 years ago
parent aa1e4c4250
commit d40da544f7
4 changed files with 172 additions and 142 deletions
Show Stats Download Patch File Download Diff File

82
collects/parser-tools/private-lex/token.ss
Unescape Escape View File

@ -40,46 +40,48 @@
0
t))))
(define-syntaxes (define-tokens define-empty-tokens)
(let ((define-tokens-helper
(lambda (stx empty?)
(syntax-case stx ()
((_ name (terms ...))
(andmap identifier? (syntax->list (syntax (terms ...))))
(datum->syntax-object
#'here
`(begin
(define-syntax ,(syntax name)
,(if empty?
`(make-e-terminals-def (quote-syntax ,(syntax (terms ...))))
`(make-terminals-def (quote-syntax ,(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
(format "token-~a" (syntax-object->datum n)))
n
n)
,@(if empty? '() '(x)))
,(if empty?
`',n
`(make-token ',n x))))
(syntax->list (syntax (terms ...)))))
stx))
((_ ...)
(raise-syntax-error
#f
"must have the form (define-tokens name (symbol ...)) or (define-empty-tokens name (symbol ...))"
stx))))))
(values
(lambda (stx) (define-tokens-helper stx #f))
(lambda (stx) (define-tokens-helper stx #t)))))
(define-for-syntax (make-ctor-name n)
(datum->syntax-object n
(string->symbol (format "token-~a" (syntax-e n)))
n
n))
(define-for-syntax (make-define-tokens empty?)
(lambda (stx)
(syntax-case stx ()
((_ name (token ...))
(andmap identifier? (syntax->list (syntax (token ...))))
(with-syntax (((marked-token ...)
(map (make-syntax-introducer)
(syntax->list (syntax (token ...))))))
(quasisyntax/loc stx
(begin
(define-syntax name
#,(if empty?
#'(make-e-terminals-def (quote-syntax (marked-token ...)))
#'(make-terminals-def (quote-syntax (marked-token ...)))))
#,@(map
(lambda (n)
(when (eq? (syntax-e n) 'error)
(raise-syntax-error
#f
"Cannot define a token named error."
stx))
(if empty?
#`(define (#,(make-ctor-name n))
'#,n)
#`(define (#,(make-ctor-name n) x)
(make-token '#,n x))))
(syntax->list (syntax (token ...))))
(define-syntax marked-token #f) ...))))
((_ ...)
(raise-syntax-error
#f
"must have the form (define-tokens name (identifier ...)) or (define-empty-tokens name (identifier ...))"
stx)))))
(define-syntax define-tokens (make-define-tokens #f))
(define-syntax define-empty-tokens (make-define-tokens #t))
(define-struct position (offset line col))
(define-struct position-token (token start-pos end-pos))

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

@ -12,12 +12,13 @@
(provide/contract
(parse-input ((listof syntax?) (listof syntax?) syntax? (union false? syntax?) syntax? any? . -> . (is-a?/c grammar%)))
(get-term-list (syntax? . -> . (listof syntax?))))
(parse-input ((listof identifier?) (listof identifier?) (listof identifier?)
(union false? syntax?) syntax? any? . -> . (is-a?/c grammar%)))
(get-term-list ((listof identifier?) . -> . (listof identifier?))))
(define stx-for-original-property (read-syntax #f (open-input-string "original")))
;; get-args: int * syntax-object list * syntax-object -> syntax-object list
;; get-args: ???
(define (get-args i rhs src-pos term-defs)
(let ((empty-table (make-hash-table)))
(hash-table-put! empty-table 'error #t)
@ -27,7 +28,7 @@
(for-each (lambda (s)
(hash-table-put! empty-table (syntax-object->datum s) #t))
(syntax->list (e-terminals-def-t v))))))
(cdr (syntax->list term-defs)))
term-defs)
(let get-args ((i i)
(rhs rhs))
(cond
@ -79,7 +80,7 @@
term-list)))
;; Retrieves the terminal symbols from a terminals-def (See terminal-syntax.ss)
;; get-terms-from-def: syntax-object -> symbol list
;; get-terms-from-def: identifier? -> (listof identifier?)
(define (get-terms-from-def term-syn)
(let ((t (syntax-local-value term-syn (lambda () #f))))
(cond
@ -91,48 +92,34 @@
"undefined token group"
term-syn)))))
;; get-term-list: syntax-object -> syntax-object list
(define (get-term-list so)
(syntax-case* so (tokens)
(lambda (a b)
(eq? (syntax-object->datum a) (syntax-object->datum b)))
((tokens term-def ...)
(andmap identifier? (syntax->list (syntax (term-def ...))))
(remove-duplicates
(cons (datum->syntax-object #f 'error)
(apply append
(map get-terms-from-def
(syntax->list (syntax (term-def ...))))))))
(_
(raise-syntax-error
'parser-tokens
"Token declaration must be (tokens symbol ...)"
so))))
(define (get-term-list term-group-names)
(remove-duplicates
(cons (datum->syntax-object #f 'error)
(apply append
(map get-terms-from-def term-group-names)))))
(define (parse-input start ends term-defs prec-decls prods src-pos)
(let* ((start-syms (map syntax-object->datum start))
(define (parse-input term-defs start ends prec-decls prods src-pos)
(let* ((start-syms (map syntax-e start))
(list-of-terms (map syntax-object->datum (get-term-list term-defs)))
(list-of-terms (map syntax-e (get-term-list 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)))
(unless (memq (syntax-e end) list-of-terms)
(raise-syntax-error
'parser-end-tokens
(format "End token ~a not defined as a token"
(syntax-e end))
end))
(syntax-e end))
ends))
;; Get the list of terminals out of input-terms
(list-of-non-terms
(syntax-case* prods (grammar)
(lambda (a b)
(eq? (syntax-object->datum a) (syntax-object->datum b)))
((grammar (non-term production ...) ...)
(syntax-case prods ()
(((non-term production ...) ...)
(begin
(for-each
(lambda (nts)
@ -162,10 +149,8 @@
;; Check the precedence declarations for errors and turn them into data
(precs
(syntax-case* prec-decls (precs)
(lambda (a b)
(eq? (syntax-object->datum a) (syntax-object->datum b)))
((precs (type term ...) ...)
(syntax-case prec-decls ()
(((type term ...) ...)
(let ((p-terms
(apply append (syntax-object->datum
(syntax ((term ...) ...))))))
@ -273,9 +258,7 @@
;; parse-prod+action: non-term * syntax-object -> production
(parse-prod+action
(lambda (nt prod-so)
(syntax-case* prod-so (prec)
(lambda (a b)
(eq? (syntax-object->datum a) (syntax-object->datum b)))
(syntax-case prod-so ()
((prod-rhs action)
(let ((p (parse-prod (syntax prod-rhs))))
(make-prod
@ -342,7 +325,7 @@
(let* ((starts (map (lambda (x) (make-non-term (gensym) #f)) start-syms))
(end-non-terms (map (lambda (x) (make-non-term (gensym) #f)) start-syms))
(parsed-prods (map parse-prods-for-nt (cdr (syntax->list prods))))
(parsed-prods (map parse-prods-for-nt (syntax->list prods)))
(start-prods
(map (lambda (start end-non-term)
(list (make-prod start (vector end-non-term) #f #f

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

@ -5,10 +5,12 @@
"table.ss"
(lib "class.ss")
(lib "contract.ss"))
(require-for-template mzscheme)
(provide/contract
(build-parser ((string? any? any? syntax? (listof syntax?) (listof syntax?)
(union syntax? false?) syntax?) . ->* . (any? any? any? any?))))
(build-parser ((string? any? any? (listof identifier?) (listof identifier?)
(listof identifier?) (union syntax? false?) syntax?) . ->* .
(any? any? any? any?))))
(define (strip so)
(syntax-local-introduce
@ -18,38 +20,60 @@
so
so)))
(define (fix-check-syntax start term-groups prods precs ends)
(syntax-case prods ()
((_ (bind ((bound ...) x ...) ...) ...)
(let ((binds (syntax->list (syntax (bind ...))))
(bounds (append start
(apply
append
(map syntax->list
(apply
append
(map syntax->list
(syntax->list (syntax (((bound ...) ...) ...)))))))))
(terms (get-term-list term-groups))
(term-group-stx
(map (lambda (tg)
(syntax-property
(datum->syntax-object tg #f)
'disappeared-use
tg))
(syntax->list term-groups)))
(precs (if precs
(syntax-case precs ()
((_ (__ term ...) ...)
(apply append (map syntax->list (syntax->list (syntax ((term ...) ...)))))))
null)))
`(if #f (let ,(map (lambda (bind)
`(,(strip bind) void))
(append terms binds))
(void ,@(append ends precs term-group-stx (map strip bounds)))))))))
;; fix-check-syntax : (listof identifier?) (listof identifier?) (listof identifier?)
;; (union syntax? false?) syntax?) -> syntax?
(define (fix-check-syntax input-terms start end assocs prods)
(let* ((term-binders (get-term-list input-terms))
(get-term-binder
(let ((t (make-hash-table)))
(for-each
(lambda (term)
(hash-table-put! t (syntax-e term) term))
term-binders)
(lambda (x)
(hash-table-get t (syntax-e x) (lambda () x)))))
(rhs-list
(syntax-case prods ()
(((_ rhs ...) ...)
(syntax->list (syntax (rhs ... ...)))))))
(with-syntax (((tmp ...) term-binders)
((term-group ...)
(map (lambda (tg)
(syntax-property
(datum->syntax-object tg #f)
'disappeared-use
tg))
input-terms))
((end ...)
(map get-term-binder end))
((bind ...)
(syntax-case prods ()
(((bind _ ...) ...) (syntax->list (syntax (bind ...))))))
(((bound ...) ...)
(map
(lambda (rhs)
(syntax-case rhs ()
(((bound ...) (_ pbound) __)
(map get-term-binder
(cons (syntax pbound)
(syntax->list (syntax (bound ...))))))
(((bound ...) _)
(map get-term-binder
(syntax->list (syntax (bound ...)))))))
rhs-list))
((prec ...)
(if assocs
(map get-term-binder
(syntax-case assocs ()
((_ (__ term ...) ...)
(syntax->list (syntax (term ... ...))))))
null)))
#`(when #f
(let ((bind void) ... (tmp void) ...)
(void bound ... ... term-group ... end ... prec ...))))))
(define (build-parser filename src-pos suppress input-terms start end assocs prods)
(let* ((grammar (parse-input start end input-terms assocs prods src-pos))
(let* ((grammar (parse-input input-terms start end assocs prods src-pos))
(table (build-table grammar filename suppress))
(num-non-terms (send grammar get-num-non-terms))
(token-code
@ -66,6 +90,6 @@
(values table
token-code
actions-code
(fix-check-syntax start input-terms prods assocs end))))
(fix-check-syntax input-terms start end assocs prods))))
)

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

@ -27,20 +27,22 @@
(yacc-output #f))
(for-each
(lambda (arg)
(syntax-case* arg (debug error tokens start end precs grammar suppress src-pos yacc-output)
(syntax-case* arg (debug error tokens start end precs grammar
suppress src-pos yacc-output)
(lambda (a b)
(eq? (syntax-object->datum a) (syntax-object->datum b)))
(eq? (syntax-e a) (syntax-e b)))
((debug filename)
(cond
((not (string? (syntax-object->datum (syntax filename))))
((not (string? (syntax-e (syntax filename))))
(raise-syntax-error
'parser-debug
#f
"Debugging filename must be a string"
stx
(syntax filename)))
(debug
(raise-syntax-error #f "Multiple debug declarations" stx))
(else
(set! debug (syntax-object->datum (syntax filename))))))
(set! debug (syntax-e (syntax filename))))))
((suppress)
(set! suppress #t))
((src-pos)
@ -50,65 +52,84 @@
(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)))
(begin
(when tokens
(raise-syntax-error #f "Multiple tokens declarations" stx))
(let ((defs (syntax->list (syntax (def ...)))))
(for-each
(lambda (d)
(unless (identifier? d)
(raise-syntax-error
#f
"Token-group name must be an identifier"
stx
d)))
defs)
(set! tokens defs))))
((start symbol ...)
(let ((symbols (syntax->list (syntax (symbol ...)))))
(for-each
(lambda (sym)
(unless (identifier? sym)
(raise-syntax-error 'parser-start
(raise-syntax-error #f
"Start symbol must be a symbol"
stx
sym)))
symbols)
(when start
(raise-syntax-error #f "Multiple start declarations" stx))
(when (null? symbols)
(raise-syntax-error 'parser-start
(raise-syntax-error #f
"Missing start symbol"
stx))
stx
arg))
(set! start symbols)))
((end symbols ...)
(let ((symbols (syntax->list (syntax (symbols ...)))))
(for-each
(lambda (sym)
(unless (identifier? sym)
(raise-syntax-error 'parser-end
(raise-syntax-error #f
"End token must be a symbol"
stx
sym)))
symbols)
(let ((d (duplicate-list? (map syntax-object->datum symbols))))
(let ((d (duplicate-list? (map syntax-e symbols))))
(when d
(raise-syntax-error 'parser-end
(format "Duplicate end token definition for ~a" d)
arg))
(raise-syntax-error
#f
(format "Duplicate end token definition for ~a" d)
stx
arg))
(when (null? symbols)
(raise-syntax-error 'parser-end
"end declaration must contain at least 1 token"
arg))
(raise-syntax-error
#f
"end declaration must contain at least 1 token"
stx
arg))
(when end
(raise-syntax-error #f "Multiple end declarations" stx))
(set! end symbols))))
((precs decls ...)
(if precs
(raise-syntax-error #f "Multiple precs declarations" stx)
(set! precs arg)))
(set! precs (syntax/loc arg (decls ...)))))
((grammar prods ...)
(if grammar
(raise-syntax-error #f "Multiple grammar declarations" stx)
(set! grammar arg)))
(set! grammar (syntax/loc arg (prods ...)))))
((yacc-output filename)
(cond
((not (string? (syntax-object->datum (syntax filename))))
(raise-syntax-error 'parser-yacc-output
((not (string? (syntax-e (syntax filename))))
(raise-syntax-error #f
"Yacc-output filename must be a string"
stx
(syntax filename)))
(yacc-output
(raise-syntax-error #f "Multiple yacc-output declarations" stx))
(else
(set! yacc-output (syntax-object->datum (syntax filename))))))
(_ (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! yacc-output (syntax-e (syntax filename))))))
(_ (raise-syntax-error #f "argument must match (debug filename), (error expression), (tokens def ...), (start non-term), (end tokens ...), (precs decls ...), or (grammar prods ...)" stx arg))))
(syntax->list (syntax (args ...))))
(unless tokens
(raise-syntax-error #f "missing tokens declaration" stx))

Write Preview
Loading…
Cancel
Save