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

99
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,9 +34,20 @@
(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))
(syntax/loc action
(lambda (start-pos-p end-pos-p lexeme-p return-without-pos-p input-port-p)
(syntax-parameterize
((start-pos (lambda (x) #'start-pos-p))
(end-pos (lambda (x) #'end-pos-p))
(lexeme (lambda (x) #'lexeme-p))
(return-without-pos (lambda (x) #'return-without-pos-p))
(input-port (lambda (x) #'input-port-p)))
action-stx)))))
(define-for-syntax (make-lexer-trans wrap?)
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
((_) ((_)
@ -53,33 +66,43 @@
(let* ((spec/re-act-lst (let* ((spec/re-act-lst
(syntax->list (syntax (re-act ...)))) (syntax->list (syntax (re-act ...))))
(eof-act (eof-act
(get-special-action spec/re-act-lst 'eof #''eof)) (get-special-action spec/re-act-lst #'eof #''eof))
(spec-act (spec-act
(get-special-action spec/re-act-lst 'special #'(void))) (get-special-action spec/re-act-lst #'special #'(void)))
(spec-error-act (spec-error-act
(get-special-action spec/re-act-lst 'special-error #'(raise exception))) (get-special-action spec/re-act-lst #'special-error #'(raise lexeme)))
(spec-comment-act (spec-comment-act
(get-special-action spec/re-act-lst 'special-comment #'#f)) (get-special-action spec/re-act-lst #'special-comment #'#f))
(ids (list #'special #'special-comment #'special-error #'eof))
(re-act-lst (re-act-lst
(filter-out-specials spec/re-act-lst (filter
'(special special-comment special-error eof)))) (lambda (spec/re-act)
(syntax-case spec/re-act ()
(((special) act)
(not (ormap
(lambda (x)
(module-identifier=? (syntax special) x))
ids)))
(_ #t)))
spec/re-act-lst)))
(let-values (((trans start actions no-look) (let-values (((trans start actions no-look)
(build-lexer re-act-lst))) (build-lexer re-act-lst)))
(with-syntax ((start-state-stx start) (with-syntax ((start-state-stx start)
(trans-table-stx trans) (trans-table-stx trans)
(no-lookahead-stx no-look) (no-lookahead-stx no-look)
(actions-stx `(vector ,@(map (lambda (a) (actions-stx
(if a (wrap-action a 'lexeme #'here a) #f)) `(vector ,@(map (lambda (a)
(if a (wrap-action a) #f))
(vector->list actions)))) (vector->list actions))))
(spec-act-stx (spec-act-stx
(wrap-action spec-act 'special #'here spec-act)) (wrap-action spec-act))
(spec-error-act-stx (spec-error-act-stx
(wrap-action spec-error-act 'exception #'here spec-error-act)) (wrap-action spec-error-act))
(has-comment-act?-stx (if (syntax-e spec-comment-act) #t #f)) (has-comment-act?-stx
(if (syntax-e spec-comment-act) #t #f))
(spec-comment-act-stx (spec-comment-act-stx
(wrap-action spec-comment-act (gensym) #'here spec-comment-act)) (wrap-action spec-comment-act))
(eof-act-stx (eof-act-stx (wrap-action eof-act))
(wrap-action eof-act 'lexeme #'here eof-act))
(wrap? wrap?)) (wrap? wrap?))
(syntax (syntax
(lexer-body start-state-stx (lexer-body start-state-stx
@ -91,10 +114,10 @@
has-comment-act?-stx has-comment-act?-stx
spec-comment-act-stx spec-comment-act-stx
eof-act-stx eof-act-stx
wrap?)))))))))))) wrap?))))))))))
(values
(build-lexer #f) (define-syntax lexer (make-lexer-trans #f))
(build-lexer #t)))) (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,8 +135,9 @@
(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
(lambda (a)
(syntax-case a () (syntax-case a ()
((name re) ((name re)
(identifier? (syntax name)) (identifier? (syntax name))
@ -123,11 +147,8 @@
"form should be (define-lex-abbrevs (name re) ...)" "form should be (define-lex-abbrevs (name re) ...)"
stx stx
a)))) a))))
abbrev))) (syntax->list (syntax (x ...))))))
(datum->syntax-object (syntax/loc stx (begin abbrev ...))))
#'here
(cons 'begin r)
stx)))
(_ (_
(raise-syntax-error (raise-syntax-error
#f #f
@ -330,5 +351,21 @@
(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