Unparser now treats QUASIQUOTE, UNQUOTE, and UNQUOTE-SPLICING

specially.

diff --git a/v7/src/runtime/pp.scm b/v7/src/runtime/pp.scm
index 3d7be2b3ddecdf3d6296f0104fff2c6a67b4f198..758e06ea1c2cabe84fc0f0b459671356ecbc66d7 100644 (file)
--- a/v7/src/runtime/pp.scm
+++ b/v7/src/runtime/pp.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pp.scm,v 14.4 1988/08/15 21:57:18 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pp.scm,v 14.5 1989/02/09 03:45:36 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -348,9 +348,11 @@ MIT in each case. |#
             (object-type? (ucode-type interned-symbol) x))
         identity-procedure)
        ((primitive-procedure? x) walk-primitive)
-       ((and (pair? x)
-             (not (unparse-list/unparser x)))
-        walk-pair)
+       ((pair? x)
+        (if (and (unparse-list/unparser x)
+                 (not (unparse-list/prefix-pair? x)))
+            walk-general
+            walk-pair))
        ((and (vector? x)
              (not (zero? (vector-length x)))
              (not (unparse-vector/unparser x)))
@@ -368,13 +370,16 @@ MIT in each case. |#
 (define (walk-pair pair)
   (if (null? (cdr pair))
       (make-singleton-list-node (numerical-walk (car pair)))
-      (make-list-node
-       (numerical-walk (car pair))
-       (if (and (pair? (cdr pair))
-               (not (unparse-list/unparser (cdr pair))))
-          (walk-pair (cdr pair))
-          (make-singleton-list-node
-           (make-prefix-node ". " (numerical-walk (cdr pair))))))))
+      (let ((prefix (unparse-list/prefix-pair? pair)))
+       (if prefix
+           (make-prefix-node prefix (numerical-walk (cadr pair)))
+           (make-list-node
+            (numerical-walk (car pair))
+            (if (and (pair? (cdr pair))
+                     (not (unparse-list/unparser (cdr pair))))
+                (walk-pair (cdr pair))
+                (make-singleton-list-node
+                 (make-prefix-node ". " (numerical-walk (cdr pair))))))))))
 
 (define (walk-vector vector)
   (make-prefix-node "#" (walk-pair (vector->list vector))))

diff --git a/v7/src/runtime/unpars.scm b/v7/src/runtime/unpars.scm
index cd75ac37cdc6e0e4b40c8cfae3f79ae7fcf0829e..95f552051c9d4aae19f62d5047ecdfd057facd82 100644 (file)
--- a/v7/src/runtime/unpars.scm
+++ b/v7/src/runtime/unpars.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unpars.scm,v 14.11 1989/01/06 21:00:42 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unpars.scm,v 14.12 1989/02/09 03:45:14 cph Rel $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -420,18 +420,25 @@ MIT in each case. |#
 
 (define (unparse-list/unparser object)
   (and (not (future? (car object)))
-       (if (eq? (car object) 'QUOTE)
-          (and (pair? (cdr object))
-               (null? (cddr object))
-               unparse-quote-form)
-          (let ((method (unparser/tagged-pair-method (car object))))
-            (and method
-                 (lambda (object)
-                   (invoke-user-method method object)))))))
-
-(define (unparse-quote-form pair)
-  (*unparse-char #\')
-  (*unparse-object (cadr pair)))
+       (let ((prefix (unparse-list/prefix-pair? object)))
+        (if prefix
+            (lambda (pair)
+              (*unparse-string prefix)
+              (*unparse-object (cadr pair)))
+            (let ((method (unparser/tagged-pair-method (car object))))
+              (and method
+                   (lambda (object)
+                     (invoke-user-method method object))))))))
+
+(define (unparse-list/prefix-pair? object)
+  (and (pair? (cdr object))
+       (null? (cddr object))
+       (case (car object)
+        ((QUOTE) "'")
+        ((QUASIQUOTE) "`")
+        ((UNQUOTE) ",")
+        ((UNQUOTE-SPLICING) ",@")
+        (else false))))
 \f
 ;;;; Procedures and Environments