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

*** empty log message ***

Browse Source 
original commit: 7b5e1aefc0ff9514cadecef785524512d996b5d7
tokens
Scott Owens 23 years ago
parent 621e178854
commit 94d036a2f7
2 changed files with 117 additions and 90 deletions
Show Stats Download Patch File Download Diff File

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

@ -1,32 +1,46 @@
;; This implements the equivalent of mzscheme's read-syntax for R5RS scheme.
;; It has not been thoroughly tested. Also it will read an entire file into a
;; list of syntax objects
;; Everything in this module will be read with case sensitivity.
#cs #cs
(module read mzscheme (module read mzscheme
(require (lib "lex.ss" "parser-tools") (require (lib "lex.ss" "parser-tools")
(lib "util.ss" "parser-tools")) (lib "yacc.ss" "parser-tools")
(lib "readerr.ss" "syntax"))
(define-tokens data (DATUM))
(define-empty-tokens delim (OP CP HASHOP QUOTE QUASI-QUOTE UNQUOTE UNQUOTE-SPLICING DOT EOF))
(define scheme-lexer (define scheme-lexer
(lexer (lexer-src-pos
[(: (whitespace) (comment)) (scheme-lexer lex-buf)]
["#t" #t] ;; Skip comments, without accumulating extra position information
["#f" #f] [(: (whitespace) (comment)) (return-without-pos (scheme-lexer lex-buf))]
[(@ "#\\" (any)) (caddr (string->list (get-lexeme)))]
["#\\space" #\space] ["#t" (token-DATUM #t)]
["#\\newline" #\newline] ["#f" (token-DATUM #f)]
[(: (@ (initial) (* (subsequent))) + - "...") (string->symbol (get-lexeme))] [(@ "#\\" (any)) (token-DATUM (caddr (string->list (get-lexeme))))]
[#\" (list->string (get-string-token lex-buf))] ["#\\space" (token-DATUM #\space)]
[#\( (make-OPEN-LIST)] ["#\\newline" (token-DATUM #\newline)]
[#\) (make-CLOSE)] [(: (@ (initial) (* (subsequent))) + - "...") (token-DATUM (string->symbol (get-lexeme)))]
["#(" (make-OPEN-VECTOR)] [#\" (token-DATUM (list->string (get-string-token lex-buf)))]
[(num2) (string->number (get-lexeme) 2)] [#\( 'OP]
[(num8) (string->number (get-lexeme) 8)] [#\) 'CP]
[(num10) (string->number (get-lexeme) 10)] [#\[ 'OP]
[(num16) (string->number (get-lexeme) 16)] [#\] 'CP]
["'" (make-QUOTE)] ["#(" 'HASHOP]
["`" (make-QUASI-QUOTE)] [(num2) (token-DATUM (string->number (get-lexeme) 2))]
["," (make-UNQUOTE)] [(num8) (token-DATUM (string->number (get-lexeme) 8))]
[",@" (make-UNQUOTE-SPLICING)] [(num10) (token-DATUM (string->number (get-lexeme) 10))]
["." (make-DOT)] [(num16) (token-DATUM (string->number (get-lexeme) 16))]
[(eof) eof])) ["'" 'QUOTE]
["`" 'QUASI-QUOTE]
["," 'UNQUOTE]
[",@" 'UNQUOTE-SPLICING]
["." 'DOT]
[(eof) 'EOF]))
(define get-string-token (define get-string-token
(lexer (lexer
@ -38,6 +52,10 @@
(define-lex-abbrevs (define-lex-abbrevs
[any (- #\000 #\377)]
[letter (: (- a z) (- A Z))]
[digit (- #\0 #\9)]
[whitespace (: #\newline #\return #\tab #\space #\vtab)]
[initial (: (letter) ! $ % & * / : < = > ? ^ _ ~)] [initial (: (letter) ! $ % & * / : < = > ? ^ _ ~)]
[subsequent (: (initial) (digit) + - #\. @)] [subsequent (: (initial) (digit) + - #\. @)]
[comment (@ #\; (* (^ #\newline)) #\newline)] [comment (@ #\; (* (^ #\newline)) #\newline)]
@ -146,74 +164,83 @@
[suffix (: (@) (@ (exponent-marker) (sign) (+ (digit10))))] [suffix (: (@) (@ (exponent-marker) (sign) (+ (digit10))))]
[exponent-marker (: e s f d l)] [exponent-marker (: e s f d l)]
[sign (: (@) + -)] [sign (: (@) + -)]
[exactness (: (@) "#i" "#e")] [exactness (: (@) "#i" "#e")])
)
(define stx-for-original-property (read-syntax #f (open-input-string "original")))
(define r (build-reader scheme-lexer))
(provide r) ;; A macro to build the syntax object
(define-syntax (build-so stx)
(define (compare s1 s2) (syntax-case stx ()
(for-each (lambda (x y) ((_ value start end)
(if (not (equal? x y)) (with-syntax ((start-pos (datum->syntax-object
(printf "~a~n~n~a" x y))) (syntax end)
s1 s2)) (string->symbol
(format "$~a-start-pos"
(define (read-all read) (syntax-object->datum (syntax start))))))
(lambda (ip) (end-pos (datum->syntax-object
(let ((r (read ip))) (syntax end)
(cond (string->symbol
((eof-object? r) (format "$~a-end-pos"
null) (syntax-object->datum (syntax end))))))
(else (source (datum->syntax-object
(cons r ((read-all read) ip))))))) (syntax end)
'source-name)))
(define (lex-all lexer) (syntax
(lambda (in) (datum->syntax-object
(let ((lb (make-lex-buf in))) #f
(let loop ((t (lexer lb))) value
(if (not (eof-object? t)) (list source
(loop (lexer lb))))))) (position-line start-pos)
(position-col start-pos)
(position-offset start-pos)
(require (lib "list.ss")) (- (position-offset end-pos)
(define files (filter (lambda (x) (position-offset start-pos)))
(string=? ".scm" stx-for-original-property))))))
(substring x
(- (string-length x) 4) (define (scheme-parser source-name)
(string-length x)))) (parser
(directory-list))) (src-pos)
(define (test)
(printf "just lexing~n") (start s)
(time (end EOF)
(map (lambda (x) (error (lambda (a name val start end)
(display x) (raise-read-error
(newline) "read-error"
(call-with-input-file x (lex-all scheme-lexer))) source-name
files)) (position-line start)
#| (position-col start)
(printf "reading~n") (position-offset start)
(time (- (position-offset end)
(map (lambda (x) (position-offset start)))))
(display x) (tokens data delim)
(newline)
(call-with-input-file x (read-all r)))
files)) (grammar
(printf "builtin read~n")
(time (s [(sexp-list) (reverse $1)])
(map (lambda (x)
(display x) (sexp [(DATUM) (build-so $1 1 1)]
(newline) [(OP sexp-list CP) (build-so (reverse $2) 1 3)]
(call-with-input-file x (read-all read))) [(HASHOP sexp-list CP) (build-so (list->vector (reverse $2)) 1 3)]
files)) [(QUOTE sexp) (build-so (list 'quote $2) 1 2)]
(printf "testing~n") [(QUASI-QUOTE sexp) (build-so (list 'quasi-quote $2) 1 2)]
(for-each (lambda (x) [(UNQUOTE sexp) (build-so (list 'unquote $2) 1 2)]
(display x) [(UNQUOTE-SPLICING sexp) (build-so (list 'unquote-splicing $2) 1 2)]
(newline) [(OP sexp-list DOT sexp CP) (build-so (append (reverse $2) $4) 1 5)])
(compare (call-with-input-file x (read-all read ))
(call-with-input-file x (read-all r)))) (sexp-list [() null]
files)|#) [(sexp-list sexp) (cons $2 $1)]))))
(provide test) (define (rs sn ip off)
(let ((lb (make-lex-buf ip off)))
((scheme-parser sn) (lambda () (scheme-lexer lb)))))
(define readsyntax
(case-lambda ((sn) (rs sn (current-input-port) (list 0 0 0)))
((sn ip) (rs sn ip (list 0 0 0)))
((sn ip off) (rs sn ip off))))
(provide (rename readsyntax read-syntax))
) )

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

@ -85,7 +85,7 @@
(not (andmap (lambda (x) (>= x 0)) offsets))) (not (andmap (lambda (x) (>= x 0)) offsets)))
(raise-type-error 'make-lex-buf "list of 3 non-negative exact integers" 1 ip offsets)) (raise-type-error 'make-lex-buf "list of 3 non-negative exact integers" 1 ip offsets))
(else (else
(make-lex-buffer ip null null (caddr offsets) (car offsets) (cadr offsets) null null)))))) (make-lex-buffer ip null null (add1 (caddr offsets)) (add1 (car offsets)) (add1 (cadr offsets)) null null))))))
(define (get-next lb) (define (get-next lb)
(cond (cond

Write Preview
Loading…
Cancel
Save