*** empty log message ***

original commit: dc2758d4ddd339d1c509d67da9362ae660764e04
tokens
Scott Owens 23 years ago
parent f520a564ed
commit 7d31c73875

@ -15,7 +15,7 @@
runtime runtime
`(begin `(begin
(define-syntax ,(syntax name) (define-syntax ,(syntax name)
(make-terminals-def ',(syntax (terms ...)))) (make-terminals-def (quote-syntax ,(syntax (terms ...)))))
,@(map ,@(map
(lambda (n) (lambda (n)
(if (eq? (syntax-object->datum n) 'error) (if (eq? (syntax-object->datum n) 'error)

@ -6,7 +6,7 @@
(require "yacc-helper.ss" "../private-lex/token-syntax.ss" "grammar.ss" (lib "list.ss")) (require "yacc-helper.ss" "../private-lex/token-syntax.ss" "grammar.ss" (lib "list.ss"))
(provide parse-input) (provide parse-input get-term-list)
;; get-args: num * syntax-object -> syntax-object list ;; get-args: num * syntax-object -> syntax-object list
(define (get-args x act src-pos) (define (get-args x act src-pos)
@ -110,36 +110,38 @@
(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
((terminals-def? t) (terminals-def-t t)) ((terminals-def? t) (syntax->list (terminals-def-t t)))
(else (else
(raise-syntax-error (raise-syntax-error
'parser-tokens 'parser-tokens
"undefined token group" "undefined token group"
term-syn))))) 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))))
;; parse-input: syntax-object * syntax-object list * syntax-object^4 * boolean-> grammar ;; 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) (define (parse-input start ends term-defs prec-decls prods runtime src-pos)
(let* ((counter 0) (let* ((counter 0)
(start-sym (syntax-object->datum start)) (start-sym (syntax-object->datum start))
(list-of-terms (map syntax-object->datum (get-term-list term-defs)))
(list-of-terms
(syntax-case* term-defs (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 'error
(apply append
(map get-terms-from-def
(syntax->list (syntax (term-def ...))))))))
(_
(raise-syntax-error
'parser-tokens
"Token declaration must be (tokens symbol ...)"
term-defs))))
(end-terms (end-terms
(map (map

@ -8,6 +8,20 @@
(provide build-parser) (provide build-parser)
(define (fix-check-syntax start terms prods)
(syntax-case prods ()
((_ (bind ((bound ...) x ...) ...) ...)
(let ((binds (syntax->list (syntax (bind ...))))
(bounds (cons start
(apply append (map syntax->list
(apply append (map syntax->list
(syntax->list (syntax (((bound ...) ...) ...)))))))))
(terms (get-term-list terms)))
`(if #f (let ,(map (lambda (bind)
`(,bind void))
(append terms binds))
(void ,@bounds)))))))
(define (build-parser filename src-pos suppress error-expr input-terms start end assocs prods runtime src) (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)) (let* ((grammar (parse-input start end input-terms assocs prods runtime src-pos))
(table (build-table grammar filename suppress)) (table (build-table grammar filename suppress))
@ -195,5 +209,5 @@
#f #f #f #f #f))))))))))) #f #f #f #f #f)))))))))))
(datum->syntax-object (datum->syntax-object
runtime runtime
parser-code `(begin #|,(fix-check-syntax start input-terms prods)|# ,parser-code)
src)))) src))))

@ -27,8 +27,10 @@
(hash-table-put! t (car l) (car l)) (hash-table-put! t (car l) (car l))
(dl? (cdr l))))))) (dl? (cdr l)))))))
(dl? l))) (dl? l)))
;; remove-duplicates: symbol list -> symbol list (require (lib "pretty.ss"))
;; remove-duplicates: syntax-object list -> syntax-object list
;; removes the duplicates from the lists ;; removes the duplicates from the lists
(define (remove-duplicates sl) (define (remove-duplicates sl)
(let ((t (make-hash-table))) (let ((t (make-hash-table)))
@ -36,10 +38,10 @@
(lambda (sl) (lambda (sl)
(cond (cond
((null? sl) sl) ((null? sl) sl)
((hash-table-get t (car sl) (lambda () #f)) ((hash-table-get t (syntax-object->datum (car sl)) (lambda () #f))
(x (cdr sl))) (x (cdr sl)))
(else (else
(hash-table-put! t (car sl) #t) (hash-table-put! t (syntax-object->datum (car sl)) #t)
(cons (car sl) (x (cdr sl)))))))) (cons (car sl) (x (cdr sl))))))))
(x sl)))) (x sl))))

Loading…
Cancel
Save