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

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

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

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

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

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

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

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

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

Write Preview
Loading…
Cancel
Save