Add support for use of backslash as symbol quote character. Fix

printing of non-canonical symbols; respect canonicalization flag.

diff --git a/v7/src/runtime/parse.scm b/v7/src/runtime/parse.scm
index 99686735339fc9afdd7507b042de96b2cf72cb53..c2162173496b0325ca735c86ba91c96981e6123f 100644 (file)
--- a/v7/src/runtime/parse.scm
+++ b/v7/src/runtime/parse.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: parse.scm,v 14.41 2003/07/30 04:14:23 cph Exp $
+$Id: parse.scm,v 14.42 2003/07/30 17:25:44 cph Exp $
 
 Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology
 Copyright 1992,1993,1994,1997,1998,1999 Massachusetts Institute of Technology
@@ -35,19 +35,21 @@ USA.
   (set! char-set/whitespace
        (char-set #\tab #\linefeed #\page #\return #\space))
   (set! char-set/non-whitespace (char-set-invert char-set/whitespace))
+  (set! char-set/symbol-quotes (string->char-set "|\\"))
+  (set! char-set/atom-delimiters
+       (char-set-union char-set/undefined-atom-delimiters
+                       char-set/whitespace
+                       char-set/symbol-quotes
+                       (string->char-set "\"();'`")))
   (set! char-set/comment-delimiters (char-set #\newline))
   (set! char-set/special-comment-leaders (string->char-set "#|"))
   (set! char-set/string-delimiters (string->char-set "\"\\"))
-  (set! char-set/atom-delimiters
-       (char-set-union char-set/whitespace
-                       char-set/undefined-atom-delimiters
-                       (string->char-set "\"();'`|")))
   (set! char-set/char-delimiters
        (char-set-union (string->char-set "-\\") char-set/atom-delimiters))
+  (set! char-set/number-leaders (string->char-set "0123456789+-.#"))
   (set! char-set/symbol-leaders
        (char-set-difference (char-set-invert char-set/atom-delimiters)
-                            (string->char-set "0123456789+-.#")))
-  (set! char-set/quoted-symbol-delimiters (string->char-set "|\\"))
+                            char-set/number-leaders))
   (set! char-set/non-digit
        (char-set-difference (char-set-invert (char-set))
                             char-set:numeric))
@@ -75,13 +77,14 @@ USA.
 (define char-set/undefined-atom-delimiters)
 (define char-set/whitespace)
 (define char-set/non-whitespace)
+(define char-set/symbol-quotes)
+(define char-set/atom-delimiters)
 (define char-set/comment-delimiters)
 (define char-set/special-comment-leaders)
 (define char-set/string-delimiters)
-(define char-set/atom-delimiters)
 (define char-set/char-delimiters)
+(define char-set/number-leaders)
 (define char-set/symbol-leaders)
-(define char-set/quoted-symbol-delimiters)
 (define char-set/non-digit)
 
 (define lambda-optional-tag)
@@ -332,50 +335,75 @@ USA.
 \f
 ;;;; Symbols/Numbers
 
-(define (read-atom)
-  (let ((s (read-string char-set/atom-delimiters)))
+(define-accretor 0 (parse-object/atom)
+  (let ((s (read-unquoted-atom-segment)))
     (if (eof-object? s)
        (parse-error/end-of-file))
-    (if *parser-canonicalize-symbols?*
-       (string-downcase! s))
-    (if (eqv? (peek-char/eof-ok) #\|)
-       (values
-        (call-with-output-string
-          (lambda (port)
-            (write-string s port)
-            (let loop ()
-              (discard-char)
-              (let find-bar ()
-                (let ((s (read-string char-set/quoted-symbol-delimiters)))
-                  (if (eof-object? s)
-                      (parse-error "Unterminated |"))
-                  (write-string s port)
-                  (if (char=? (read-char) #\|)
-                      (let ((s (read-string char-set/atom-delimiters)))
-                        (if (not (eof-object? s))
-                            (begin
-                              (if *parser-canonicalize-symbols?*
-                                  (string-downcase! s))
-                              (write-string s port)
-                              (if (eqv? (peek-char/eof-ok) #\|)
-                                  (loop)))))
-                      (begin
-                        (write-char (read-char) port)
-                        (find-bar))))))))
-        #t)
-       (values s #f))))
+    (if (peek-atom-quote?)
+       (string->symbol (read-quoted-atom s))
+       (or (parse-number s)
+           (string->symbol s)))))
 
-(define-accretor 0 (parse-object/atom)
-  (receive (string force-sym?) (read-atom)
-    (or (and (not force-sym?)
-            (parse-number string))
-       (string->symbol string))))
+(define (read-unquoted-atom-segment)
+  (let ((s (read-string char-set/atom-delimiters)))
+    (if (and (not (eof-object? s))
+            *parser-canonicalize-symbols?*)
+       (string-downcase! s))
+    s))
+
+(define (read-quoted-atom s)
+  (call-with-output-string
+    (lambda (port)
+      (write-string s port)
+      (letrec
+         ((read-quoted
+           (lambda ()
+             (if (char=? (read-char) #\|)
+                 (find-bar)
+                 (begin
+                   (write-char (read-char) port)
+                   (read-unquoted)))))
+          (find-bar
+           (lambda ()
+             (write-string (read-quoted-atom-segment) port)
+             (if (char=? (read-char) #\|)
+                 (read-unquoted)
+                 (begin
+                   (write-char (read-char) port)
+                   (find-bar)))))
+          (read-unquoted
+           (lambda ()
+             (let ((s (read-unquoted-atom-segment)))
+               (if (not (eof-object? s))
+                   (begin
+                     (write-string s port)
+                     (if (peek-atom-quote?)
+                         (read-quoted))))))))
+       (read-quoted)))))
+
+(define (peek-atom-quote?)
+  (let ((c (peek-char/eof-ok)))
+    (and (char? c)
+        (or (char=? c #\|)
+            (char=? c #\\)))))
+
+(define (read-quoted-atom-segment)
+  (let ((s (read-string char-set/symbol-quotes)))
+    (if (eof-object? s)
+       (parse-error/end-of-file))
+    s))
+\f
+(define (read-atom)
+  (let ((s (read-unquoted-atom-segment)))
+    (if (eof-object? s)
+       (parse-error/end-of-file))
+    (if (peek-atom-quote?)
+       (read-quoted-atom s)
+       s)))
 
 (define-accretor 0 (parse-object/symbol)
-  (receive (string force-sym?) (read-atom)
-    force-sym?
-    (string->symbol string)))
-\f
+  (string->symbol (read-atom)))
+
 (define (parse-number string)
   (let ((radix (if (memv *parser-radix* '(2 8 10 16)) *parser-radix* 10)))
     (if (fix:= radix 10)
@@ -391,9 +419,7 @@ USA.
 (define-accretor 1 (parse-object/numeric-prefix)
   (let ((number
         (let ((char (read-char)))
-          (receive (s force-sym?) (read-atom)
-            force-sym?
-            (string-append (string #\# char) s)))))
+          (string-append (string #\# char) (read-atom)))))
     (let ((n (parse-number number)))
       (if (not n)
          (parse-error "Bad number syntax" number))
@@ -401,8 +427,7 @@ USA.
 
 (define-accretor 1 (parse-object/bit-string)
   (discard-char)
-  (receive (s force-sym?) (read-atom)
-    force-sym?
+  (let ((s (read-atom)))
     (let ((end (string-length s)))
       (unsigned-integer->bit-string
        end

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index f1491e5e432de4d4e36f55e4c12a4a472bdcb7f6..5f8ab2020e9ae5b2f269e53411b2f69fec85f5ff 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.453 2003/07/30 04:37:29 cph Exp $
+$Id: runtime.pkg,v 14.454 2003/07/30 17:25:47 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -2360,7 +2360,8 @@ USA.
          lambda-rest-tag)
   (export (runtime unparser)
          char-set/atom-delimiters
-         char-set/quoted-symbol-delimiters
+         char-set/number-leaders
+         char-set/symbol-quotes
          lambda-auxiliary-tag
          lambda-optional-tag
          lambda-rest-tag)

diff --git a/v7/src/runtime/unpars.scm b/v7/src/runtime/unpars.scm
index c4982fb17e782afb987b68628fef466a0cd58602..9c6baac3a21656f84e09e3c9e9c66988971ba441 100644 (file)
--- a/v7/src/runtime/unpars.scm
+++ b/v7/src/runtime/unpars.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: unpars.scm,v 14.54 2003/07/30 05:14:38 cph Exp $
+$Id: unpars.scm,v 14.55 2003/07/30 17:25:51 cph Exp $
 
 Copyright 1986,1987,1990,1991,1992,1995 Massachusetts Institute of Technology
 Copyright 1996,2001,2002,2003 Massachusetts Institute of Technology
@@ -48,9 +48,8 @@ USA.
   (set! *unparse-abbreviate-quotations?* #f)
   (set! system-global-unparser-table (make-system-global-unparser-table))
   (set! *default-list-depth* 0)
-  (set! symbol-delimiters
-       (char-set-difference char-set/atom-delimiters
-                            char-set:upper-case))
+  (set! quoted-symbol-chars
+       (char-set-union char-set/atom-delimiters char-set:upper-case))
   (set-current-unparser-table! system-global-unparser-table))
 
 (define *unparser-radix*)
@@ -67,7 +66,7 @@ USA.
 (define *unparse-abbreviate-quotations?*)
 (define system-global-unparser-table)
 (define *default-list-depth*)
-(define symbol-delimiters)
+(define quoted-symbol-chars)
 (define *current-unparser-table*)
 
 (define (current-unparser-table)
@@ -339,8 +338,13 @@ USA.
 
 (define (unparse-symbol symbol)
   (let ((s (symbol-name symbol)))
-    (if (or (string-find-next-char-in-set s symbol-delimiters)
-           (string->number s))
+    (if (or (string-find-next-char-in-set s
+                                         (if *parser-canonicalize-symbols?*
+                                             quoted-symbol-chars
+                                             char-set/atom-delimiters))
+           (fix:= (string-length s) 0)
+           (and (char-set-member? char-set/number-leaders (string-ref s 0))
+                (string->number s)))
        (begin
          (*unparse-char #\|)
          (let ((end (string-length s)))
@@ -349,7 +353,7 @@ USA.
                  (let ((i
                         (substring-find-next-char-in-set
                          s start end
-                         char-set/quoted-symbol-delimiters)))
+                         char-set/symbol-quotes)))
                    (if i
                        (begin
                          (*unparse-substring s start i)