*** empty log message ***

original commit: 7b5e1aefc0ff9514cadecef785524512d996b5d7

collects/parser-tools/examples/read.ss

@@ -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
 (module read mzscheme
 
   (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
-    (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
     (lexer
@@ -38,6 +52,10 @@
   
   
   (define-lex-abbrevs
+   [any (- #\000 #\377)]
+   [letter (: (- a z) (- A Z))]
+   [digit (- #\0 #\9)]
+   [whitespace (: #\newline #\return #\tab #\space #\vtab)]
    [initial (: (letter) ! $ % & * / : < = > ? ^ _ ~)]
    [subsequent (: (initial) (digit) + - #\. @)]
    [comment (@ #\; (* (^ #\newline)) #\newline)]
@@ -146,74 +164,83 @@
    [suffix (: (@) (@ (exponent-marker) (sign) (+ (digit10))))]
    [exponent-marker (: e s f d l)]
    [sign (: (@) + -)]
-   [exactness (: (@) "#i" "#e")]
+   [exactness (: (@) "#i" "#e")])
-   )
-   
 
-  (define r (build-reader scheme-lexer))
-  (provide r)
-
-  (define (compare s1 s2)
-    (for-each (lambda (x y)
-		(if (not (equal? x y))
-		    (printf "~a~n~n~a" x y)))
-	      s1 s2))
   
-  (define (read-all read)
+  (define stx-for-original-property (read-syntax #f (open-input-string "original")))
-    (lambda (ip)
+  
-      (let ((r (read ip)))
+  ;; A macro to build the syntax object
-	(cond
+  (define-syntax (build-so stx)
-	 ((eof-object? r)
+    (syntax-case stx ()
-	  null)
+      ((_ value start end)
-	 (else
+       (with-syntax ((start-pos (datum->syntax-object 
-	  (cons r ((read-all read) ip)))))))
+                                 (syntax end)
-
+                                 (string->symbol 
-  (define (lex-all lexer)
+                                  (format "$~a-start-pos"
-    (lambda (in)
+                                          (syntax-object->datum (syntax start))))))
-      (let ((lb (make-lex-buf in)))
+                     (end-pos (datum->syntax-object 
-	(let loop ((t (lexer lb)))
+                               (syntax end)
-	  (if (not (eof-object? t))
+                               (string->symbol 
-	      (loop (lexer lb)))))))
+                                (format "$~a-end-pos"
-
+                                        (syntax-object->datum (syntax end))))))
+                     (source (datum->syntax-object
+                              (syntax end)
+                              'source-name)))
+         (syntax
+          (datum->syntax-object 
+           #f
+           value
+           (list source 
+                 (position-line start-pos)
+                 (position-col start-pos)
+                 (position-offset start-pos)
+                 (- (position-offset end-pos)
+                    (position-offset start-pos)))
+           stx-for-original-property))))))
+  
+  (define (scheme-parser source-name)
+    (parser
+     (src-pos)
 
-  (require (lib "list.ss"))
+     (start s)
-  (define files (filter (lambda (x) 
+     (end EOF)
-			(string=? ".scm"
+     (error (lambda (a name val start end)
-				  (substring x 
+              (raise-read-error 
-					     (- (string-length x) 4)
+               "read-error"
-					     (string-length x))))
+               source-name
-		      (directory-list)))
+               (position-line start)
-  (define (test)
+               (position-col start)
-    (printf "just lexing~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 (lex-all scheme-lexer)))
+     
-	  files))
+     (grammar
-    #|
+      
-    (printf "reading~n")
+      (s [(sexp-list) (reverse $1)])
-    (time
+      
-     (map (lambda (x) 
+      (sexp [(DATUM) (build-so $1 1 1)]
-	    (display x)
+            [(OP sexp-list CP) (build-so (reverse $2) 1 3)]
-	    (newline)
+            [(HASHOP sexp-list CP) (build-so (list->vector (reverse $2)) 1 3)]
-	    (call-with-input-file x (read-all r)))
+            [(QUOTE sexp) (build-so (list 'quote $2) 1 2)]
-	  files))
+            [(QUASI-QUOTE sexp) (build-so (list 'quasi-quote $2) 1 2)]
-    (printf "builtin read~n")
+            [(UNQUOTE sexp) (build-so (list 'unquote $2) 1 2)]
-    (time
+            [(UNQUOTE-SPLICING sexp) (build-so (list 'unquote-splicing $2) 1 2)]
-     (map (lambda (x) 
+            [(OP sexp-list DOT sexp CP) (build-so (append (reverse $2) $4) 1 5)])
-	    (display x)
+      
-	    (newline)
+      (sexp-list [() null]
-	    (call-with-input-file x (read-all read)))
+                 [(sexp-list sexp) (cons $2 $1)]))))
-	  files))
+  
-    (printf "testing~n")
+  (define (rs sn ip off)
-    (for-each (lambda (x)
+    (let ((lb (make-lex-buf ip off)))
-		(display x)
+      ((scheme-parser sn) (lambda () (scheme-lexer lb)))))
-		(newline)
-		(compare (call-with-input-file x (read-all read ))
-			 (call-with-input-file x (read-all r))))
-	      files)|#)
   
-  (provide test)
+  (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))
+                        
   )

collects/parser-tools/lex.ss

@@ -85,7 +85,7 @@
 	    (not (andmap (lambda (x) (>= x 0)) offsets)))
 	(raise-type-error 'make-lex-buf "list of 3 non-negative exact integers" 1 ip offsets))
        (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)
     (cond