original commit: 8f7a5eef7d519eddac9931d8a0252f2f591c4552
tokens
Matthew Flatt 20 years ago
parent 4866d90396
commit d7df17ee88

@ -33,8 +33,6 @@
;; A regular expression operator
char-set)
(define file-path (make-parameter #f))
;; wrap-action: syntax-object src-pos? -> syntax-object
(define-for-syntax (wrap-action action src-pos?)
(with-syntax ((action-stx
@ -90,16 +88,24 @@
(module-or-top-identifier=? (syntax special) x))
ids)))
(_ #t)))
spec/re-act-lst)))
(let-values (((trans start actions no-look disappeared-uses)
(build-lexer re-act-lst)))
spec/re-act-lst))
(name-lst (map (lambda (x) (datum->syntax-object #f (gensym))) re-act-lst))
(act-lst (map (lambda (x) (stx-car (stx-cdr x))) re-act-lst))
(re-actname-lst (map (lambda (re-act name)
(list (stx-car re-act)
name))
re-act-lst
name-lst)))
(let-values (((trans start action-names no-look disappeared-uses)
(build-lexer re-actname-lst)))
(with-syntax ((start-state-stx start)
(trans-table-stx trans)
(no-lookahead-stx no-look)
(actions-stx
`(vector ,@(map (lambda (a)
(if a (wrap-action a src-pos?) #f))
(vector->list actions))))
((name ...) name-lst)
((act ...) (map (lambda (a)
(wrap-action a src-pos?))
act-lst))
((act-name ...) (vector->list action-names))
(spec-act-stx
(wrap-action spec-act src-pos?))
(spec-error-act-stx
@ -111,15 +117,16 @@
(eof-act-stx (wrap-action eof-act src-pos?)))
(syntax-property
(syntax/loc stx
(let ([name act] ...)
(lexer-body start-state-stx
trans-table-stx
actions-stx
(vector act-name ...)
no-lookahead-stx
spec-act-stx
spec-error-act-stx
has-comment-act?-stx
spec-comment-act-stx
eof-act-stx))
eof-act-stx)))
'disappeared-use
disappeared-uses)))))))))
@ -300,6 +307,7 @@
;(printf "(read-string ~e port) = ~e~n" longest-match-length match)
(do-match lb first-pos longest-match-action match)))
(define file-path (make-parameter #f))
(define (do-match ip first-pos action value)
#;(printf "(action ~a ~a ~a ~a)~n"

@ -1,6 +1,7 @@
(module front mzscheme
(require (prefix is: (lib "integer-set.ss"))
(lib "list.ss")
(lib "stx.ss" "syntax")
"util.ss"
"stx.ss"
"re.ss"
@ -132,8 +133,8 @@
(define (build-lexer sos)
(let* ((disappeared-uses (box null))
(s-re-acts (map (lambda (so)
(cons (parse (car (syntax->list so)) disappeared-uses)
(cadr (syntax->list so))))
(cons (parse (stx-car so) disappeared-uses)
(stx-car (stx-cdr so))))
sos))
(cache (make-cache))

Loading…
Cancel
Save