From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 30 Jul 2003 17:25:51 +0000 (+0000)
Subject: Add support for use of backslash as symbol quote character. Fix
X-Git-Tag: 20090517-FFI~1841
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=07ce32e85f4477460ba9a5a8e27abd9f3a27ba8d;p=mit-scheme.git
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 996867353..c21621734 100644
--- 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.
;;;; 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))
+
+(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)))
-
+ (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 f1491e5e4..5f8ab2020 100644
--- 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 c4982fb17..9c6baac3a 100644
--- 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)