wisp-cvs

[<di...@us...>]

Update of /cvsroot/wisp/wisp/src/builtin
In directory usw-pr-cvs1:/tmp/cvs-serv30995/src/builtin

Modified Files:
	builtin.wisp parser.wisp tostring.wisp 
Log Message:
Borrowed the box external representation from PLT MzScheme.

Index: builtin.wisp
===================================================================
RCS file: /cvsroot/wisp/wisp/src/builtin/builtin.wisp,v
retrieving revision 1.209
retrieving revision 1.210
diff -u -d -r1.209 -r1.210
--- builtin.wisp	4 Sep 2002 14:29:47 -0000	1.209
+++ builtin.wisp	4 Sep 2002 14:33:34 -0000	1.210
@@ -164,10 +164,18 @@
 
 ;;;; Quasiquotation
 
+; Wisp guarantees that quasiquoting always copies the quasiquoted conses,
+; vectors, and boxes even when they do not contain any |unquote| forms.
+; The guarantee is void if |cons| (or another structure-constructor) is
+; bound to a wrong object, of course.
 (defmacro (quasiquote i)
   (cond
     ((cons? i) (quasiquote-cons i))
     ((vector? i) `(list->vector (,'quasiquote ,(vector->list i))))
+    ((box? i) (try (my v (box-ref i)
+                     (list 'make-box (list 'quasiquote v)))
+                (except (undefined)
+                  `(make-box))))
     (else (list 'quote i))))
 
 (define (process-unquote-splicing splicee rest)

Index: parser.wisp
===================================================================
RCS file: /cvsroot/wisp/wisp/src/builtin/parser.wisp,v
retrieving revision 1.115
retrieving revision 1.116
diff -u -d -r1.115 -r1.116
--- parser.wisp	4 Sep 2002 14:32:24 -0000	1.115
+++ parser.wisp	4 Sep 2002 14:33:35 -0000	1.116
@@ -162,6 +162,7 @@
                          (case (read-char port)
                            ((#\<) (raise 'unreadable (string-copy "#<")))
                            ((#\open) #\V)
+                           ((#\&) #\B)
                            ((#\\) (my body (read-character-body port)
                                     (or (and (parse-character-body body)
                                              => (cut cons 'PARSED <>))
@@ -170,24 +171,24 @@
                              (read-line port)
                              (token-read-loop))
                            ((#\|)
-                            (letrec (((state-normal level)
-                                       (case (read-char port)
-                                         ((#\|) (state-potdec level))
-                                         ((#\#) (state-potinc level))
-                                         (else (state-normal level))))
-                                     ((state-potinc level)
-                                       (case (read-char port)
-                                         ((#\|) (state-normal (+ level 1)))
-                                         ((#\#) (state-potinc level))
-                                         (else (state-normal level))))
-                                     ((state-potdec level)
-                                       (case (read-char port)
-                                         ((#\|) (state-potdec level))
-                                         ((#\#) (if (not (zero? level))
-                                                  (state-normal (- level 1))))
-                                         (else (state-normal level)))))
-                              (state-normal 0))
-                            (token-read-loop))
+                             (letrec (((state-normal level)
+                                        (case (read-char port)
+                                          ((#\|) (state-potdec level))
+                                          ((#\#) (state-potinc level))
+                                          (else (state-normal level))))
+                                      ((state-potinc level)
+                                        (case (read-char port)
+                                          ((#\|) (state-normal (+ level 1)))
+                                          ((#\#) (state-potinc level))
+                                          (else (state-normal level))))
+                                      ((state-potdec level)
+                                        (case (read-char port)
+                                          ((#\|) (state-potdec level))
+                                          ((#\#) (if (not (zero? level))
+                                                   (state-normal (- level 1))))
+                                          (else (state-normal level)))))
+                               (state-normal 0))
+                             (token-read-loop))
                            (else
                              (raise 'invalid-reader-syntax
                                     (string-copy
@@ -262,6 +263,15 @@
              (read-list port))
            ((eqv? t #\V)
              (list->vector (read-block port #\close)))
+           ((eqv? t #\B)
+             (if (eqv? (peek-token port) #\.)
+               (begin
+                 (read-token port)
+                 (make-box))
+               (my o (read-complex-structure port)
+                 (if (eof-object? o)
+                   (raise 'premature-eof port))
+                 (make-box o))))
            ((and (char? t) (char<=? #\0 t #\4))
              (string->number (read-token port) (case t
                                                  ((#\0) 10)

Index: tostring.wisp
===================================================================
RCS file: /cvsroot/wisp/wisp/src/builtin/tostring.wisp,v
retrieving revision 1.74
retrieving revision 1.75
diff -u -d -r1.74 -r1.75
--- tostring.wisp	4 Sep 2002 14:29:47 -0000	1.74
+++ tostring.wisp	4 Sep 2002 14:33:35 -0000	1.75
@@ -55,6 +55,12 @@
                            (set! n[i] (loop s[i]))
                            (incr! i)))
                        n)))
+                 ((box? s)
+                   (my n (make-box)
+                     (acons! seen s n)
+                     (try (set! n[] (loop s[]))
+                       (except (undefined)))
+                     n))
                  (else
                    (cons! unrecognized s)
                    (acons! seen s s)
@@ -243,13 +249,22 @@
                   (emit ", slot count ")
                   (emit (integer->string (record-type-slot-count s)))
                   (emit #\>))
-                ((box? s) ; boxes are intentionally left non-readable
-                  (try (my datum (box-ref s)
-                         (emit "#<box: ")
-                         (loop datum)
-                         (emit #\>))
-                    (except (undefined)
-                      (emit "#<empty box>"))))
-                (else (emit "#<???>"))))))))))
+                ((box? s)
+                  (if (not (check-duplicity s))
+                    (begin
+                      (emit "#&")
+                      (try (my datum (box-ref s)
+                             ; emit space unless the object would start
+                             ; by a left parenthesis
+                             (if (not (or (and (cons? datum)
+                                               (not (assq datum dupl)))
+                                          (null? datum)))
+                               (emit #\space))
+                             (loop datum))
+                        (except (undefined)
+                          (emit #\.))))))
+                (else (emit "#<??? ")
+                      (emit (stringify-address s))
+                      (emit #\>))))))))))
 
 ; vim: lispwords+=,local