*** empty log message ***

original commit: 2be8fedb446fc5d6283d92da0e15ff49312d2759
tokens
Scott Owens 20 years ago
parent c1cc72360c
commit 6e3f0cd227

@ -8,16 +8,17 @@
"grammar.ss" "grammar.ss"
(lib "class.ss") (lib "class.ss")
(lib "contract.ss")) (lib "contract.ss"))
(require-for-template mzscheme)
(provide/contract (provide/contract
(parse-input ((listof syntax?) (listof syntax?) syntax? (union false? syntax?) syntax? syntax? any? . -> . (is-a?/c grammar%))) (parse-input ((listof syntax?) (listof syntax?) syntax? (union false? syntax?) syntax? any? . -> . (is-a?/c grammar%)))
(get-term-list (syntax? . -> . (listof syntax?)))) (get-term-list (syntax? . -> . (listof syntax?))))
(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: int * syntax-object list * syntax-object -> syntax-object list
(define (get-args i rhs act 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)
(for-each (lambda (td) (for-each (lambda (td)
@ -32,18 +33,18 @@
(cond (cond
((null? rhs) null) ((null? rhs) null)
(else (else
(let ((b (syntax-local-introduce (car rhs))) (let ((b (car rhs))
(name (if (hash-table-get empty-table (syntax-object->datum (car rhs)) (lambda () #f)) (name (if (hash-table-get empty-table (syntax-object->datum (car rhs)) (lambda () #f))
(gensym) (gensym)
(string->symbol (format "$~a" i))))) (string->symbol (format "$~a" i)))))
(cond (cond
(src-pos (src-pos
`(,(datum->syntax-object act name b stx-for-original-property) `(,(datum->syntax-object b name b stx-for-original-property)
,(datum->syntax-object act (string->symbol (format "$~a-start-pos" i)) b stx-for-original-property) ,(datum->syntax-object b (string->symbol (format "$~a-start-pos" i)) b stx-for-original-property)
,(datum->syntax-object act (string->symbol (format "$~a-end-pos" i)) b stx-for-original-property) ,(datum->syntax-object b (string->symbol (format "$~a-end-pos" i)) b stx-for-original-property)
,@(get-args (add1 i) (cdr rhs)))) ,@(get-args (add1 i) (cdr rhs))))
(else (else
`(,(datum->syntax-object act name b stx-for-original-property) `(,(datum->syntax-object b name b stx-for-original-property)
,@(get-args (add1 i) (cdr rhs))))))))))) ,@(get-args (add1 i) (cdr rhs)))))))))))
;; Given the list of terminal symbols and the precedence/associativity definitions, ;; Given the list of terminal symbols and the precedence/associativity definitions,
@ -108,7 +109,7 @@
"Token declaration must be (tokens symbol ...)" "Token declaration must be (tokens symbol ...)"
so)))) so))))
(define (parse-input start ends term-defs prec-decls prods runtime src-pos) (define (parse-input start ends term-defs prec-decls prods src-pos)
(let* ((start-syms (map syntax-object->datum start)) (let* ((start-syms (map syntax-object->datum start))
(list-of-terms (map syntax-object->datum (get-term-list term-defs))) (list-of-terms (map syntax-object->datum (get-term-list term-defs)))
@ -265,11 +266,9 @@
;; parse-action: syntax-object * syntax-object -> syntax-object ;; parse-action: syntax-object * syntax-object -> syntax-object
(parse-action (parse-action
(lambda (rhs act) (lambda (rhs act)
(datum->syntax-object (quasisyntax/loc act
runtime (lambda #,(get-args 1 (syntax->list rhs) src-pos term-defs)
`(lambda ,(get-args 1 (syntax->list rhs) act src-pos term-defs) #,act))))
,act)
act)))
;; parse-prod+action: non-term * syntax-object -> production ;; parse-prod+action: non-term * syntax-object -> production
(parse-prod+action (parse-prod+action
@ -347,7 +346,7 @@
(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
(datum->syntax-object runtime `(lambda (x) x))))) (syntax (lambda (x) x)))))
starts end-non-terms)) starts end-non-terms))
(prods (prods
`(,@start-prods `(,@start-prods
@ -361,9 +360,7 @@
(hash-table-get term-table end)) (hash-table-get term-table end))
#f #f
#f #f
(datum->syntax-object (syntax (lambda (x) x))))
runtime
`(lambda (x) x))))
end-terms)) end-terms))
end-non-terms start-syms) end-non-terms start-syms)
,@parsed-prods))) ,@parsed-prods)))

@ -8,7 +8,7 @@
(provide/contract (provide/contract
(build-parser ((string? any? any? syntax? (listof syntax?) (listof syntax?) (build-parser ((string? any? any? syntax? (listof syntax?) (listof syntax?)
(union syntax? false?) syntax? syntax?) . ->* . (any? any? any? any?)))) (union syntax? false?) syntax?) . ->* . (any? any? any? any?))))
(define (strip so) (define (strip so)
(syntax-local-introduce (syntax-local-introduce
@ -48,8 +48,8 @@
(append terms binds)) (append terms binds))
(void ,@(append ends precs term-group-stx (map strip bounds))))))))) (void ,@(append ends precs term-group-stx (map strip bounds)))))))))
(define (build-parser filename src-pos suppress input-terms start end assocs prods runtime) (define (build-parser filename src-pos suppress input-terms start end assocs prods)
(let* ((grammar (parse-input start end input-terms assocs prods runtime src-pos)) (let* ((grammar (parse-input start end input-terms 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

@ -128,8 +128,7 @@
start start
end end
precs precs
grammar grammar)))
stx)))
(when (and yacc-output (not (string=? yacc-output ""))) (when (and yacc-output (not (string=? yacc-output "")))
(with-handlers [(exn:fail:filesystem? (with-handlers [(exn:fail:filesystem?
(lambda (e) (lambda (e)

Loading…
Cancel
Save