mbutterick
/
br-parser-tools
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

*** empty log message ***

Browse Source 
original commit: 66a01cd74f14b8321bc70127a253ab417b19569e
tokens
Scott Owens 21 years ago
parent 7b76f564c9
commit c1cc72360c
2 changed files with 127 additions and 113 deletions
Show Stats Download Patch File Download Diff File

205
collects/parser-tools/lex.ss
Unescape Escape View File

@ -3,14 +3,16 @@
;; Provides the syntax used to create lexers and the functions needed to ;; Provides the syntax used to create lexers and the functions needed to
;; create and use the buffer that the lexer reads from. See doc.txt. ;; create and use the buffer that the lexer reads from. See doc.txt.
(require-for-syntax (lib "define.ss" "syntax") (require-for-syntax (lib "list.ss")
(lib "define.ss" "syntax")
(lib "boundmap.ss" "syntax")
"private-lex/util.ss" "private-lex/util.ss"
"private-lex/actions.ss" "private-lex/actions.ss"
"private-lex/front.ss" "private-lex/front.ss"
"private-lex/unicode-chars.ss") "private-lex/unicode-chars.ss")
(require (lib "stxparam.ss")
(require (lib "readerr.ss" "syntax") (lib "readerr.ss" "syntax")
"private-lex/token.ss") "private-lex/token.ss")
(provide lexer lexer-src-pos define-lex-abbrev define-lex-abbrevs define-lex-trans (provide lexer lexer-src-pos define-lex-abbrev define-lex-abbrevs define-lex-trans
@ -32,69 +34,90 @@
(define file-path (make-parameter #f)) (define file-path (make-parameter #f))
(define-syntaxes (lexer lexer-src-pos) ;; wrap-action: syntax-object -> syntax-object
(let ((build-lexer (define-for-syntax (wrap-action action)
(lambda (wrap?) (with-syntax ((action-stx action))
(lambda (stx) (syntax/loc action
(syntax-case stx () (lambda (start-pos-p end-pos-p lexeme-p return-without-pos-p input-port-p)
((_) (syntax-parameterize
(raise-syntax-error #f "accepts the empty string" stx)) ((start-pos (lambda (x) #'start-pos-p))
((_ re-act ...) (end-pos (lambda (x) #'end-pos-p))
(begin (lexeme (lambda (x) #'lexeme-p))
(for-each (return-without-pos (lambda (x) #'return-without-pos-p))
(lambda (x) (input-port (lambda (x) #'input-port-p)))
(syntax-case x () action-stx)))))
((re act) (void))
(_ (raise-syntax-error #f (define-for-syntax (make-lexer-trans wrap?)
"not a regular expression / action pair" (lambda (stx)
stx (syntax-case stx ()
x)))) ((_)
(syntax->list (syntax (re-act ...)))) (raise-syntax-error #f "accepts the empty string" stx))
(let* ((spec/re-act-lst ((_ re-act ...)
(syntax->list (syntax (re-act ...)))) (begin
(eof-act (for-each
(get-special-action spec/re-act-lst 'eof #''eof)) (lambda (x)
(spec-act (syntax-case x ()
(get-special-action spec/re-act-lst 'special #'(void))) ((re act) (void))
(spec-error-act (_ (raise-syntax-error #f
(get-special-action spec/re-act-lst 'special-error #'(raise exception))) "not a regular expression / action pair"
(spec-comment-act stx
(get-special-action spec/re-act-lst 'special-comment #'#f)) x))))
(re-act-lst (syntax->list (syntax (re-act ...))))
(filter-out-specials spec/re-act-lst (let* ((spec/re-act-lst
'(special special-comment special-error eof)))) (syntax->list (syntax (re-act ...))))
(let-values (((trans start actions no-look) (eof-act
(build-lexer re-act-lst))) (get-special-action spec/re-act-lst #'eof #''eof))
(with-syntax ((start-state-stx start) (spec-act
(trans-table-stx trans) (get-special-action spec/re-act-lst #'special #'(void)))
(no-lookahead-stx no-look) (spec-error-act
(actions-stx `(vector ,@(map (lambda (a) (get-special-action spec/re-act-lst #'special-error #'(raise lexeme)))
(if a (wrap-action a 'lexeme #'here a) #f)) (spec-comment-act
(vector->list actions)))) (get-special-action spec/re-act-lst #'special-comment #'#f))
(spec-act-stx (ids (list #'special #'special-comment #'special-error #'eof))
(wrap-action spec-act 'special #'here spec-act)) (re-act-lst
(spec-error-act-stx (filter
(wrap-action spec-error-act 'exception #'here spec-error-act)) (lambda (spec/re-act)
(has-comment-act?-stx (if (syntax-e spec-comment-act) #t #f)) (syntax-case spec/re-act ()
(spec-comment-act-stx (((special) act)
(wrap-action spec-comment-act (gensym) #'here spec-comment-act)) (not (ormap
(eof-act-stx (lambda (x)
(wrap-action eof-act 'lexeme #'here eof-act)) (module-identifier=? (syntax special) x))
(wrap? wrap?)) ids)))
(syntax (_ #t)))
(lexer-body start-state-stx spec/re-act-lst)))
trans-table-stx (let-values (((trans start actions no-look)
actions-stx (build-lexer re-act-lst)))
no-lookahead-stx (with-syntax ((start-state-stx start)
spec-act-stx (trans-table-stx trans)
spec-error-act-stx (no-lookahead-stx no-look)
has-comment-act?-stx (actions-stx
spec-comment-act-stx `(vector ,@(map (lambda (a)
eof-act-stx (if a (wrap-action a) #f))
wrap?)))))))))))) (vector->list actions))))
(values (spec-act-stx
(build-lexer #f) (wrap-action spec-act))
(build-lexer #t)))) (spec-error-act-stx
(wrap-action spec-error-act))
(has-comment-act?-stx
(if (syntax-e spec-comment-act) #t #f))
(spec-comment-act-stx
(wrap-action spec-comment-act))
(eof-act-stx (wrap-action eof-act))
(wrap? wrap?))
(syntax
(lexer-body start-state-stx
trans-table-stx
actions-stx
no-lookahead-stx
spec-act-stx
spec-error-act-stx
has-comment-act?-stx
spec-comment-act-stx
eof-act-stx
wrap?))))))))))
(define-syntax lexer (make-lexer-trans #f))
(define-syntax lexer-src-pos (make-lexer-trans #t))
(define-syntax (define-lex-abbrev stx) (define-syntax (define-lex-abbrev stx)
(syntax-case stx () (syntax-case stx ()
@ -112,22 +135,20 @@
(define-syntax (define-lex-abbrevs stx) (define-syntax (define-lex-abbrevs stx)
(syntax-case stx () (syntax-case stx ()
((_ x ...) ((_ x ...)
(let* ((abbrev (syntax->list (syntax (x ...)))) (with-syntax (((abbrev ...)
(r (map (lambda (a) (map
(syntax-case a () (lambda (a)
((name re) (syntax-case a ()
(identifier? (syntax name)) ((name re)
(syntax (define-lex-abbrev name re))) (identifier? (syntax name))
(_ (raise-syntax-error (syntax (define-lex-abbrev name re)))
#f (_ (raise-syntax-error
"form should be (define-lex-abbrevs (name re) ...)" #f
stx "form should be (define-lex-abbrevs (name re) ...)"
a)))) stx
abbrev))) a))))
(datum->syntax-object (syntax->list (syntax (x ...))))))
#'here (syntax/loc stx (begin abbrev ...))))
(cons 'begin r)
stx)))
(_ (_
(raise-syntax-error (raise-syntax-error
#f #f
@ -324,11 +345,27 @@
(create-unicode-abbrevs #'here) (create-unicode-abbrevs #'here)
(define-lex-trans (char-set stx) (define-lex-trans (char-set stx)
(syntax-case stx () (syntax-case stx ()
((_ str) ((_ str)
(string? (syntax-e (syntax str))) (string? (syntax-e (syntax str)))
(with-syntax (((char ...) (string->list (syntax-e (syntax str))))) (with-syntax (((char ...) (string->list (syntax-e (syntax str)))))
(syntax (union char ...)))))) (syntax (union char ...))))))
(define-syntax provide-lex-keyword
(syntax-rules ()
[(_ id ...)
(begin
(define-syntax-parameter id
(make-set!-transformer
(lambda (stx)
(raise-syntax-error
#f
(format "use of a lexer keyword (~a) is not in an appropriate lexer action"
'id)
stx))))
...
(provide id ...))]))
(provide-lex-keyword start-pos end-pos lexeme input-port return-without-pos)
) )

31
collects/parser-tools/private-lex/actions.ss
Unescape Escape View File

@ -1,20 +1,8 @@
(module actions mzscheme (module actions mzscheme
(provide (all-defined)) (provide (all-defined))
(require (lib "stx.ss" "syntax"))
;; wrap-action: (syntax-object or #f) symbol syntax-object syntax-object -> syntax-object ;; get-special-action: (syntax-object list) syntax-object syntax-object -> syntax-object
(define (wrap-action action result-name ctxt loc)
(if action
(let ((parms (datum->syntax-object
action
`(start-pos end-pos ,result-name return-without-pos input-port))))
(datum->syntax-object ctxt
`(lambda ,parms ,action)
loc))
(datum->syntax-object ctxt 'void loc)))
;; get-special-action: (syntax-object list) symbol 'a -> syntax-object or 'a
;; Returns the first action from a rule of the form ((which-special) action) ;; Returns the first action from a rule of the form ((which-special) action)
(define (get-special-action rules which-special none) (define (get-special-action rules which-special none)
(cond (cond
@ -22,21 +10,10 @@
(else (else
(syntax-case (car rules) () (syntax-case (car rules) ()
(((special) act) (((special) act)
(eq? (syntax-e (syntax special)) which-special) (module-identifier=? (syntax special) which-special)
(syntax act)) (syntax act))
(_ (get-special-action (cdr rules) which-special none)))))) (_ (get-special-action (cdr rules) which-special none))))))
;; filter-out-specials: (syntax-object list) (symbol list) -> (syntax-object list)
;; Returns a list missing all the rules of the form ((special) action)
;; where special is a symbol in which specials.
(define (filter-out-specials rules which-specials)
(cond
((null? rules) null)
(else
(syntax-case (car rules) ()
(((special) act)
(memq (syntax-e (syntax special)) which-specials)
(filter-out-specials (cdr rules) which-specials))
(_ (cons (car rules) (filter-out-specials (cdr rules) which-specials)))))))
) )
Write Preview
Loading…
Cancel
Save