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

*** empty log message ***

Browse Source 
original commit: 4d3ec15b51313f6f9296a1ed2057786481570a84
tokens
Scott Owens 23 years ago
parent a5cce475d1
commit 148fcfa324
1 changed files with 52 additions and 51 deletions
Show Stats Download Patch File Download Diff File

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

@ -20,7 +20,8 @@
(let ((match (let ((match
(push-back lb (- length longest-match-length)))) (push-back lb (- length longest-match-length))))
(if (not longest-match-action) (if (not longest-match-action)
(error 'lex "No match found in rest of input")) (error 'lexer (format "No match found in input starting with: ~a"
(list->string (lex-buffer-from lb)))))
(longest-match-action (longest-match-action
(lambda () (lambda ()
first-pos) first-pos)
@ -33,9 +34,11 @@
lb))))) lb)))))
(lambda (lb) (lambda (lb)
(unless (lex-buffer? lb) (unless (lex-buffer? lb)
(error 'lex (raise-type-error
(format 'lexer
"Lexer expects argument of type lex-buf; given ~a" lb))) "lex-buf"
0
lb))
(let ((first-pos (get-position lb))) (let ((first-pos (get-position lb)))
(let lexer-loop ( (let lexer-loop (
;; current-state ;; current-state
@ -51,7 +54,6 @@
(length 1) (length 1)
;; how many characters are in the longest match ;; how many characters are in the longest match
(longest-match-length 0) (longest-match-length 0)
;;(end-pos first-pos))
(end-pos first-pos)) (end-pos first-pos))
(let ((next-state (let ((next-state
(cond (cond
@ -84,56 +86,55 @@
pos))))))))))) pos)))))))))))
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
((_ (re act) ...) ((_ (re1 act1) (re act) ...)
(let* ((table (generate-table (syntax ((re act) ...)) (let* ((table (generate-table (syntax ((re1 act1) (re act) ...)) stx))
stx)) (code
(code `(let ((start-state ,(table-start table))
`(let ((start-state ,(table-start table)) (trans-table ,(table-trans table))
(trans-table ,(table-trans table)) (eof-table ,(table-eof table))
(eof-table ,(table-eof table)) (actions (vector ,@(vector->list (table-actions table)))))
(actions (vector ,@(vector->list (table-actions table))))) ,code)))
,code))) (datum->syntax-object #'here code #f)))
(datum->syntax-object #'here code #f))))))) (_
(raise-syntax-error #f "Form should be (lexer (re act) ...) with at least 1 (re ast) pair" stx))))))
(define-syntax define-lex-abbrev (define-syntax (define-lex-abbrev stx)
(lambda (stx) (syntax-case stx ()
(syntax-case stx () ((_ name re)
((_ name val) (syntax
(syntax (define-syntax name
(define-syntax name (make-lex-abbrev (quote-syntax re)))))
(make-lex-abbrev (quote-syntax val))))) (_
(_ (raise-syntax-error
(raise-syntax-error #f
#f "Form should be (define-lex-abbrev name re)"
"Form should be (define-lex-abbrev name val)" stx))))
stx)))))
(define-syntax define-lex-abbrevs (define-syntax (define-lex-abbrevs stx)
(lambda (stx) (syntax-case stx ()
(syntax-case stx () ((_ x ...)
((_ x ...) (let* ((abbrev (syntax->list (syntax (x ...))))
(let* ((abbrev (syntax->list (syntax (x ...)))) (r (map (lambda (a)
(r (map (lambda (a) (syntax-case a ()
(syntax-case a () ((name re)
((name val) (identifier? (syntax name))
(identifier? (syntax name)) (syntax (define-lex-abbrev name re)))
(syntax (define-lex-abbrev name val))) (_ (raise-syntax-error
(_ (raise-syntax-error 'Lexer-abbreviation
#f "Form should be (identifier value)"
"Lexer abbreviation must be (identifier value)" a))))
a)))) abbrev)))
abbrev))) (datum->syntax-object
(datum->syntax-object #'here
#'here (cons 'begin r)
(cons 'begin r) stx)))
stx))) (_
(_ (raise-syntax-error
(raise-syntax-error #f
#f "Form should be (define-lex-abbrevs (name re) ...)"
"Form should be (define-lex-abbrevs (name val) ...)" stx))))
stx)))))
;; Lex buffer is NOT thread safe ;; Lex buffer is NOT thread safe

Write Preview
Loading…
Cancel
Save