|
|
|
@ -71,85 +71,78 @@
|
|
|
|
[lexeme-srcloc (make-rename-transformer #'lexeme-srcloc-p)])
|
|
|
|
[lexeme-srcloc (make-rename-transformer #'lexeme-srcloc-p)])
|
|
|
|
action-stx)))))
|
|
|
|
action-stx)))))
|
|
|
|
|
|
|
|
|
|
|
|
(begin-for-syntax
|
|
|
|
|
|
|
|
; This macro only exists to keep the indentation below the same,
|
|
|
|
|
|
|
|
; in order to make the diff easier to read. So it probably makes
|
|
|
|
|
|
|
|
; sense to inline it after reading.
|
|
|
|
|
|
|
|
(define-syntax-rule (begin-with-disappeared-uses body0 body ...)
|
|
|
|
|
|
|
|
(with-disappeared-uses
|
|
|
|
|
|
|
|
(let () body0 body ...))))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define-for-syntax (make-lexer-macro caller src-loc-style)
|
|
|
|
(define-for-syntax (make-lexer-macro caller src-loc-style)
|
|
|
|
(λ (stx)
|
|
|
|
(λ (stx)
|
|
|
|
(syntax-case stx ()
|
|
|
|
(syntax-case stx ()
|
|
|
|
[(_ . RE+ACTS)
|
|
|
|
[(_ . RE+ACTS)
|
|
|
|
(begin-with-disappeared-uses
|
|
|
|
(with-disappeared-uses
|
|
|
|
(define spec/re-acts (syntax->list #'RE+ACTS))
|
|
|
|
(let ()
|
|
|
|
(for/and ([x (in-list spec/re-acts)])
|
|
|
|
(define spec/re-acts (syntax->list #'RE+ACTS))
|
|
|
|
(syntax-case x ()
|
|
|
|
(for/and ([x (in-list spec/re-acts)])
|
|
|
|
[(RE ACT) #t]
|
|
|
|
(syntax-case x ()
|
|
|
|
[else (raise-syntax-error caller "not a regular expression / action pair" stx x)]))
|
|
|
|
[(RE ACT) #t]
|
|
|
|
(define eof-act (get-special-action spec/re-acts #'eof (case src-loc-style
|
|
|
|
[else (raise-syntax-error caller "not a regular expression / action pair" stx x)]))
|
|
|
|
[(lexer-src-pos) #'(return-without-pos eof)]
|
|
|
|
(define eof-act (get-special-action spec/re-acts #'eof (case src-loc-style
|
|
|
|
[(lexer-srcloc) #'(return-without-srcloc eof)]
|
|
|
|
[(lexer-src-pos) #'(return-without-pos eof)]
|
|
|
|
[else #'eof])))
|
|
|
|
[(lexer-srcloc) #'(return-without-srcloc eof)]
|
|
|
|
(define spec-act (get-special-action spec/re-acts #'special #'(void)))
|
|
|
|
[else #'eof])))
|
|
|
|
(define spec-comment-act (get-special-action spec/re-acts #'special-comment #'#f))
|
|
|
|
(define spec-act (get-special-action spec/re-acts #'special #'(void)))
|
|
|
|
(define ids (list #'special #'special-comment #'eof))
|
|
|
|
(define spec-comment-act (get-special-action spec/re-acts #'special-comment #'#f))
|
|
|
|
(define re-acts (filter (λ (spec/re-act)
|
|
|
|
(define ids (list #'special #'special-comment #'eof))
|
|
|
|
(syntax-case spec/re-act ()
|
|
|
|
(define re-acts (filter (λ (spec/re-act)
|
|
|
|
[((special) act)
|
|
|
|
(syntax-case spec/re-act ()
|
|
|
|
(not (ormap
|
|
|
|
[((special) act)
|
|
|
|
(λ (x)
|
|
|
|
(not (ormap
|
|
|
|
(and (identifier? #'special)
|
|
|
|
(λ (x)
|
|
|
|
(module-or-top-identifier=? #'special x)))
|
|
|
|
(and (identifier? #'special)
|
|
|
|
ids))]
|
|
|
|
(module-or-top-identifier=? #'special x)))
|
|
|
|
[_ #t])) spec/re-acts))
|
|
|
|
ids))]
|
|
|
|
(define names (map (λ (x) (datum->syntax #f (gensym))) re-acts))
|
|
|
|
[_ #t])) spec/re-acts))
|
|
|
|
(define acts (map (λ (x) (stx-car (stx-cdr x))) re-acts))
|
|
|
|
(define names (map (λ (x) (datum->syntax #f (gensym))) re-acts))
|
|
|
|
(define re-actnames (map (λ (re-act name) (list (stx-car re-act) name)) re-acts names))
|
|
|
|
(define acts (map (λ (x) (stx-car (stx-cdr x))) re-acts))
|
|
|
|
(when (null? spec/re-acts)
|
|
|
|
(define re-actnames (map (λ (re-act name) (list (stx-car re-act) name)) re-acts names))
|
|
|
|
(raise-syntax-error caller "expected at least one action" stx))
|
|
|
|
(when (null? spec/re-acts)
|
|
|
|
(define-values (trans start action-names no-look) (build-lexer re-actnames))
|
|
|
|
(raise-syntax-error caller "expected at least one action" stx))
|
|
|
|
(when (vector-ref action-names start) ;; Start state is final
|
|
|
|
(define-values (trans start action-names no-look) (build-lexer re-actnames))
|
|
|
|
(unless (and
|
|
|
|
(when (vector-ref action-names start) ;; Start state is final
|
|
|
|
;; All the successor states are final
|
|
|
|
(unless (and
|
|
|
|
(vector? (vector-ref trans start))
|
|
|
|
;; All the successor states are final
|
|
|
|
(andmap (λ (x) (vector-ref action-names (vector-ref x 2)))
|
|
|
|
(vector? (vector-ref trans start))
|
|
|
|
(vector->list (vector-ref trans start)))
|
|
|
|
(andmap (λ (x) (vector-ref action-names (vector-ref x 2)))
|
|
|
|
;; Each character has a successor state
|
|
|
|
(vector->list (vector-ref trans start)))
|
|
|
|
(let loop ([check 0]
|
|
|
|
;; Each character has a successor state
|
|
|
|
[nexts (vector->list (vector-ref trans start))])
|
|
|
|
(let loop ([check 0]
|
|
|
|
(cond
|
|
|
|
[nexts (vector->list (vector-ref trans start))])
|
|
|
|
[(null? nexts) #f]
|
|
|
|
(cond
|
|
|
|
[else
|
|
|
|
[(null? nexts) #f]
|
|
|
|
(let ([next (car nexts)])
|
|
|
|
[else
|
|
|
|
(and (= (vector-ref next 0) check)
|
|
|
|
(let ([next (car nexts)])
|
|
|
|
(let ([next-check (vector-ref next 1)])
|
|
|
|
(and (= (vector-ref next 0) check)
|
|
|
|
(or (>= next-check max-char-num)
|
|
|
|
(let ([next-check (vector-ref next 1)])
|
|
|
|
(loop (add1 next-check) (cdr nexts))))))])))
|
|
|
|
(or (>= next-check max-char-num)
|
|
|
|
(eprintf "warning: lexer at ~a can accept the empty string\n" stx)))
|
|
|
|
(loop (add1 next-check) (cdr nexts))))))])))
|
|
|
|
(with-syntax ([START-STATE-STX start]
|
|
|
|
(eprintf "warning: lexer at ~a can accept the empty string\n" stx)))
|
|
|
|
[TRANS-TABLE-STX trans]
|
|
|
|
(with-syntax ([START-STATE-STX start]
|
|
|
|
[NO-LOOKAHEAD-STX no-look]
|
|
|
|
[TRANS-TABLE-STX trans]
|
|
|
|
[(NAME ...) names]
|
|
|
|
[NO-LOOKAHEAD-STX no-look]
|
|
|
|
[(ACT ...) (map (λ (a) (wrap-action a src-loc-style)) acts)]
|
|
|
|
[(NAME ...) names]
|
|
|
|
[(ACT-NAME ...) (vector->list action-names)]
|
|
|
|
[(ACT ...) (map (λ (a) (wrap-action a src-loc-style)) acts)]
|
|
|
|
[SPEC-ACT-STX (wrap-action spec-act src-loc-style)]
|
|
|
|
[(ACT-NAME ...) (vector->list action-names)]
|
|
|
|
[HAS-COMMENT-ACT?-STX (if (syntax-e spec-comment-act) #t #f)]
|
|
|
|
[SPEC-ACT-STX (wrap-action spec-act src-loc-style)]
|
|
|
|
[SPEC-COMMENT-ACT-STX (wrap-action spec-comment-act src-loc-style)]
|
|
|
|
[HAS-COMMENT-ACT?-STX (if (syntax-e spec-comment-act) #t #f)]
|
|
|
|
[EOF-ACT-STX (wrap-action eof-act src-loc-style)])
|
|
|
|
[SPEC-COMMENT-ACT-STX (wrap-action spec-comment-act src-loc-style)]
|
|
|
|
(syntax/loc stx (let ([NAME ACT] ...)
|
|
|
|
[EOF-ACT-STX (wrap-action eof-act src-loc-style)])
|
|
|
|
(let ([proc (lexer-body START-STATE-STX
|
|
|
|
(syntax/loc stx (let ([NAME ACT] ...)
|
|
|
|
TRANS-TABLE-STX
|
|
|
|
(let ([proc (lexer-body START-STATE-STX
|
|
|
|
(vector ACT-NAME ...)
|
|
|
|
TRANS-TABLE-STX
|
|
|
|
NO-LOOKAHEAD-STX
|
|
|
|
(vector ACT-NAME ...)
|
|
|
|
SPEC-ACT-STX
|
|
|
|
NO-LOOKAHEAD-STX
|
|
|
|
HAS-COMMENT-ACT?-STX
|
|
|
|
SPEC-ACT-STX
|
|
|
|
SPEC-COMMENT-ACT-STX
|
|
|
|
HAS-COMMENT-ACT?-STX
|
|
|
|
EOF-ACT-STX)])
|
|
|
|
SPEC-COMMENT-ACT-STX
|
|
|
|
;; reverse eta to get named procedures:
|
|
|
|
EOF-ACT-STX)])
|
|
|
|
(λ (port) (proc port)))))))])))
|
|
|
|
;; reverse eta to get named procedures:
|
|
|
|
|
|
|
|
(λ (port) (proc port))))))))])))
|
|
|
|
|
|
|
|
|
|
|
|
(define-syntax lexer (make-lexer-macro 'lexer #f))
|
|
|
|
(define-syntax lexer (make-lexer-macro 'lexer #f))
|
|
|
|
(define-syntax lexer-src-pos (make-lexer-macro 'lexer-src-pos 'lexer-src-pos))
|
|
|
|
(define-syntax lexer-src-pos (make-lexer-macro 'lexer-src-pos 'lexer-src-pos))
|
|
|
|
|
Jesse A. Tov
5 years ago
committed by