*** empty log message ***

original commit: a05bd24b8e5926e51e8a10a8b3d582376678a309
tokens
Scott Owens 23 years ago
parent c370b8f4cf
commit c15b3d72cc

@ -15,20 +15,33 @@
(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) (define (get-args i rhs act src-pos term-defs)
(let ((empty-table (make-hash-table)))
(for-each (lambda (td)
(let ((v (syntax-local-value td)))
(if (e-terminals-def? v)
(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)))
(let get-args ((i i)
(rhs rhs))
(cond (cond
((null? rhs) null) ((null? rhs) null)
(else (else
(let ((b (syntax-local-introduce (car rhs)))) (let ((b (syntax-local-introduce (car rhs)))
(name (if (hash-table-get empty-table (syntax-object->datum (car rhs)) (lambda () #f))
(gensym)
(string->symbol (format "$~a" i)))))
(cond (cond
(src-pos (src-pos
`(,(datum->syntax-object act (string->symbol (format "$~a" i)) b stx-for-original-property) `(,(datum->syntax-object act 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 act (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 act (string->symbol (format "$~a-end-pos" i)) b stx-for-original-property)
,@(get-args (add1 i) (cdr rhs) act src-pos))) ,@(get-args (add1 i) (cdr rhs))))
(else (else
`(,(datum->syntax-object act (string->symbol (format "$~a" i)) b stx-for-original-property) `(,(datum->syntax-object act name b stx-for-original-property)
,@(get-args (add1 i) (cdr rhs) act src-pos)))))))) ,@(get-args (add1 i) (cdr rhs)))))))))))
;; nullable: production list * int -> non-term set ;; nullable: production list * int -> non-term set
;; determines which non-terminals can derive epsilon ;; determines which non-terminals can derive epsilon
@ -311,7 +324,7 @@
(lambda (rhs act) (lambda (rhs act)
(datum->syntax-object (datum->syntax-object
runtime runtime
`(lambda ,(get-args 1 (syntax->list rhs) act src-pos) `(lambda ,(get-args 1 (syntax->list rhs) act src-pos term-defs)
,act) ,act)
act))) act)))

@ -61,7 +61,7 @@
((rhs) (list `(,$1 #f))) ((rhs) (list `(,$1 #f)))
((rhs prec) (list `(,$1 ,$2 #f))) ((rhs prec) (list `(,$1 ,$2 #f)))
((rhs PIPE prods) (cons `(,$1 #f) $3)) ((rhs PIPE prods) (cons `(,$1 #f) $3))
((rhs prec PIPE prods) (cons `(,$1 ,$2 #f) $3))) ((rhs prec PIPE prods) (cons `(,$1 ,$2 #f) $4)))
(prec (prec
((%prec SYM) ((%prec SYM)
(begin (begin

Loading…
Cancel
Save