From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 9 Feb 1989 03:45:36 +0000 (+0000)
Subject: Unparser now treats QUASIQUOTE, UNQUOTE, and UNQUOTE-SPLICING
X-Git-Tag: 20090517-FFI~12280
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7a3c4644243445527ebcc18387c3109264898ee8;p=mit-scheme.git

Unparser now treats QUASIQUOTE, UNQUOTE, and UNQUOTE-SPLICING
specially.
---

diff --git a/v7/src/runtime/pp.scm b/v7/src/runtime/pp.scm
index 3d7be2b3d..758e06ea1 100644
--- 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 cd75ac37c..95f552051 100644
--- 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))))
 
 ;;;; Procedures and Environments