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

*** empty log message ***

Browse Source 
original commit: 22c2bf198f947fd0bc45ec25114b9e757a6942e7
tokens
Scott Owens 23 years ago
parent 00517ff265
commit 7c6dde5a62
3 changed files with 37 additions and 89 deletions
Show Stats Download Patch File Download Diff File

20
collects/parser-tools/examples/calc.ss
Unescape Escape View File

@ -31,7 +31,7 @@
[(eof) 'EOF] [(eof) 'EOF]
;; recursively call the lexer on the remaining input after a tab or space. Returning the ;; recursively call the lexer on the remaining input after a tab or space. Returning the
;; result of that operation. This effectively skips all whitespace. ;; result of that operation. This effectively skips all whitespace.
[(: #\tab #\space) (calcl lex-buf)] [(: #\tab #\space) (calcl input-port)]
;; The parser will treat the return of 'newline the same as (token-newline) ;; The parser will treat the return of 'newline the same as (token-newline)
[#\newline 'newline] [#\newline 'newline]
[(: = + - * / ^) (string->symbol (get-lexeme))] [(: = + - * / ^) (string->symbol (get-lexeme))]
@ -84,13 +84,11 @@
;; run the calculator on the given input-port ;; run the calculator on the given input-port
(define (calc ip) (define (calc ip)
;; Make the lex-buffer (letrec ((one-line
(let ((lb (make-lex-buf ip))) (lambda ()
(letrec ((one-line (let ((result (calcp (lambda () (calcl ip)))))
(lambda () (if result
(let ((result (calcp (lambda () (calcl lb))))) (begin
(if result (printf "~a~n" result)
(begin (one-line)))))))
(printf "~a~n" result) (one-line))))
(one-line)))))))
(one-line))))

13
collects/parser-tools/examples/read.ss
Unescape Escape View File

@ -17,7 +17,7 @@
(lexer-src-pos (lexer-src-pos
;; Skip comments, without accumulating extra position information ;; Skip comments, without accumulating extra position information
[(: (whitespace) (comment)) (return-without-pos (scheme-lexer lex-buf))] [(: (whitespace) (comment)) (return-without-pos (scheme-lexer input-port))]
["#t" (token-DATUM #t)] ["#t" (token-DATUM #t)]
["#f" (token-DATUM #f)] ["#f" (token-DATUM #f)]
@ -25,7 +25,7 @@
["#\\space" (token-DATUM #\space)] ["#\\space" (token-DATUM #\space)]
["#\\newline" (token-DATUM #\newline)] ["#\\newline" (token-DATUM #\newline)]
[(: (@ (initial) (* (subsequent))) + - "...") (token-DATUM (string->symbol (get-lexeme)))] [(: (@ (initial) (* (subsequent))) + - "...") (token-DATUM (string->symbol (get-lexeme)))]
[#\" (token-DATUM (list->string (get-string-token lex-buf)))] [#\" (token-DATUM (list->string (get-string-token input-port)))]
[#\( 'OP] [#\( 'OP]
[#\) 'CP] [#\) 'CP]
[#\[ 'OP] [#\[ 'OP]
@ -45,9 +45,9 @@
(define get-string-token (define get-string-token
(lexer (lexer
[(^ #\" #\\) (cons (car (string->list (get-lexeme))) [(^ #\" #\\) (cons (car (string->list (get-lexeme)))
(get-string-token lex-buf))] (get-string-token input-port))]
[(@ #\\ #\\) (cons #\\ (get-string-token lex-buf))] [(@ #\\ #\\) (cons #\\ (get-string-token input-port))]
[(@ #\\ #\") (cons #\" (get-string-token lex-buf))] [(@ #\\ #\") (cons #\" (get-string-token input-port))]
[#\" null])) [#\" null]))
@ -233,8 +233,7 @@
[(sexp-list sexp) (cons $2 $1)])))) [(sexp-list sexp) (cons $2 $1)]))))
(define (rs sn ip off) (define (rs sn ip off)
(let ((lb (make-lex-buf ip off))) ((scheme-parser sn) (lambda () (scheme-lexer ip)))))
((scheme-parser sn) (lambda () (scheme-lexer lb)))))
(define readsyntax (define readsyntax
(case-lambda ((sn) (rs sn (current-input-port) (list 0 0 0))) (case-lambda ((sn) (rs sn (current-input-port) (list 0 0 0)))

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

@ -11,11 +11,10 @@
(lib "cffi.ss" "compiler")) (lib "cffi.ss" "compiler"))
(provide lexer lexer-src-pos define-lex-abbrev define-lex-abbrevs (provide lexer lexer-src-pos define-lex-abbrev define-lex-abbrevs
make-lex-buf
get-position position-offset position-line position-col position? get-position position-offset position-line position-col position?
define-tokens define-empty-tokens) define-tokens define-empty-tokens)
(define-syntaxes (lexer lexer-src-pos) (define-syntaxes (lexer-experiment lexer-src-pos-experiment)
(let ((build-lexer (let ((build-lexer
(lambda (wrap?) (lambda (wrap?)
(lambda (stx) (lambda (stx)
@ -42,7 +41,7 @@
(build-lexer #f) (build-lexer #f)
(build-lexer #t)))) (build-lexer #t))))
(define-syntaxes (lexer-old lexer-src-pos-old) (define-syntaxes (lexer lexer-src-pos)
(let ((build-lexer (let ((build-lexer
(lambda (wrap?) (lambda (wrap?)
(lambda (stx) (lambda (stx)
@ -114,32 +113,32 @@
stx)))) stx))))
(define (compiled-lexer-body lexer actions wrap?) (define (compiled-lexer-body lexer actions wrap?)
(lambda (lb) (lambda (ip)
(unless (lex-buffer? lb) (unless (input-port? ip)
(raise-type-error (raise-type-error
'lexer 'lexer
"lex-buf" "input-port"
0 0
lb)) ip))
(let ((first-pos (get-position lb))) (let ((first-pos (get-position ip)))
(let-values (((longest-match-length longest-match-action) (let-values (((longest-match-length longest-match-action)
(lexer lb next-char))) (lexer ip peek-string)))
(do-match lb first-pos longest-match-length (vector-ref actions longest-match-action) wrap?))))) (do-match ip first-pos longest-match-length (vector-ref actions longest-match-action) wrap?)))))
(define (lexer-body start-state trans-table eof-table actions no-lookahead wrap?) (define (lexer-body start-state trans-table eof-table actions no-lookahead wrap?)
(lambda (lb) (lambda (ip)
(unless (lex-buffer? lb) (unless (input-port? ip)
(raise-type-error (raise-type-error
'lexer 'lexer
"lex-buf" "input-port"
0 0
lb)) ip))
(let ((first-pos (get-position lb))) (let ((first-pos (get-position ip)))
(let lexer-loop ( (let lexer-loop (
;; current-state ;; current-state
(state start-state) (state start-state)
;; the character to transition on ;; the character to transition on
(char (next-char lb)) (char (peek-string 1 0 ip))
;; action for the longest match seen thus far ;; action for the longest match seen thus far
;; including a match at the current state ;; including a match at the current state
(longest-match-action (longest-match-action
@ -159,10 +158,10 @@
(+ (char->integer (string-ref char 0)) (* 256 state))))))) (+ (char->integer (string-ref char 0)) (* 256 state)))))))
(cond (cond
((not next-state) ((not next-state)
(do-match lb first-pos longest-match-length longest-match-action wrap?)) (do-match ip first-pos longest-match-length longest-match-action wrap?))
((vector-ref no-lookahead next-state) ((vector-ref no-lookahead next-state)
(let ((act (vector-ref actions next-state))) (let ((act (vector-ref actions next-state)))
(do-match lb (do-match ip
first-pos first-pos
(if act length longest-match-length) (if act length longest-match-length)
(if act act longest-match-action) (if act act longest-match-action)
@ -170,7 +169,7 @@
(else (else
(let ((act (vector-ref actions next-state))) (let ((act (vector-ref actions next-state)))
(lexer-loop next-state (lexer-loop next-state
(next-char lb) (peek-string 1 length ip)
(if act (if act
act act
longest-match-action) longest-match-action)
@ -180,7 +179,7 @@
longest-match-length)))))))))) longest-match-length))))))))))
(define (do-match lb first-pos longest-match-length longest-match-action wrap?) (define (do-match lb first-pos longest-match-length longest-match-action wrap?)
(let* ((match (get-match lb longest-match-length)) (let* ((match (read-string longest-match-length lb))
(end-pos (get-position lb))) (end-pos (get-position lb)))
(if (not longest-match-action) (if (not longest-match-action)
(raise-read-error (raise-read-error
@ -210,57 +209,9 @@
lb))))) lb)))))
;; Lex buffer is NOT thread safe
;; c = char | eof
;; lex-buf =
;; (make-lex-buffer input-port int int int int)
(define-struct lex-buffer (ip peek-amt line-start col-start offset-start))
;; make-lex-buf: input-port -> lex-buf
(define make-lex-buf
(case-lambda
((ip)
(cond
((not (input-port? ip))
(raise-type-error 'make-lex-buf "input-port" 0 ip))
(else
(port-count-lines! ip)
(make-lex-buffer ip 0 0 0 0))))
((ip offsets)
(cond
((not (input-port? ip))
(raise-type-error 'make-lex-buf "input-port" 0 ip offsets))
((or (not (= 3 (length offsets)))
(not (andmap integer? offsets))
(not (andmap exact? offsets))
(not (andmap (lambda (x) (>= x 0)) offsets)))
(raise-type-error 'make-lex-buf "list of 3 non-negative exact integers" 1 ip offsets))
(else
(port-count-lines! ip)
(make-lex-buffer ip 0 (car offsets) (cadr offsets) (caddr offsets)))))))
;; next-char: lex-buffer -> (string or eof)
(define (next-char lb)
(let* ((peek-amt (lex-buffer-peek-amt lb))
(str (peek-string 1 peek-amt (lex-buffer-ip lb))))
(set-lex-buffer-peek-amt! lb (add1 peek-amt))
str))
;; get-match: lex-buf * int -> string
;; reads the next i characters.
(define (get-match lb i)
(set-lex-buffer-peek-amt! lb 0)
(read-string i (lex-buffer-ip lb)))
(define-struct position (offset line col)) (define-struct position (offset line col))
(define (get-position lb) (define (get-position ip)
(let-values (((line col off) (port-next-location (lex-buffer-ip lb)))) (let-values (((line col off) (port-next-location ip)))
(if (and line col) (make-position off line col)))
(make-position (+ (lex-buffer-offset-start lb) off)
(+ (lex-buffer-line-start lb) line)
(if (= line 1)
(+ (lex-buffer-col-start lb) col)
col))
(make-position (+ (lex-buffer-offset-start lb) off) #f #f))))
) )

Write Preview
Loading…
Cancel
Save