From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 24 Apr 1987 13:37:27 +0000 (+0000)
Subject: Change stack parser, unparser, and pretty-printer to handle
X-Git-Tag: 20090517-FFI~13589
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d2f33f9ce368ef8e103e7cdc729c5775089d1bf0;p=mit-scheme.git

Change stack parser, unparser, and pretty-printer to handle
reference-trap objects specially, detecting them before they get
assigned to variables, and printing them in a reasonable way.
---

diff --git a/v7/src/runtime/pp.scm b/v7/src/runtime/pp.scm
index 187586c26..2248077af 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 13.42 1987/03/17 18:52:08 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pp.scm,v 13.43 1987/04/24 13:36:36 cph Exp $
 ;;;
 ;;;	Copyright (c) 1987 Massachusetts Institute of Technology
 ;;;
@@ -331,14 +331,20 @@
       (walk-unquoted-pair pair)))
 
 (define (walk-unquoted-pair pair)
-  (if (null? (cdr pair))
-      (make-singleton-list-node (numerical-walk (car pair)))
-      (make-list-node
-       (numerical-walk (car pair))
-       (if (pair? (cdr pair))
-	   (walk-unquoted-pair (cdr pair))
-	   (make-singleton-list-node
-	    (make-prefix-node ". " (numerical-walk (cdr pair))))))))
+  (cond (((access unparse-list/unparser unparser-package) pair)
+	 (walk-general pair))
+	((null? (cdr pair))
+	 (make-singleton-list-node (numerical-walk (car pair))))
+	(else
+	 (make-list-node
+	  (numerical-walk (car pair))
+	  (if (and (pair? (cdr pair))
+		   (not
+		    ((access unparse-list/unparser unparser-package)
+		     (cdr pair))))
+	      (walk-unquoted-pair (cdr pair))
+	      (make-singleton-list-node
+	       (make-prefix-node ". " (numerical-walk (cdr pair)))))))))
 
 (define (walk-vector vector)
   (if (zero? (vector-length vector))
diff --git a/v7/src/runtime/sdata.scm b/v7/src/runtime/sdata.scm
index b0e1d36af..3e0c7015d 100644
--- a/v7/src/runtime/sdata.scm
+++ b/v7/src/runtime/sdata.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sdata.scm,v 13.42 1987/04/03 00:52:12 jinx Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sdata.scm,v 13.43 1987/04/24 13:37:01 cph Rel $
 ;;;
 ;;;	Copyright (c) 1987 Massachusetts Institute of Technology
 ;;;
@@ -80,154 +80,151 @@
       (&make-object (make-primitive-procedure '&MAKE-OBJECT))
       (hunk3-cons (make-primitive-procedure 'HUNK3-CONS)))
 
-  (define (map-unassigned object)
-    (cond ((eq? object &unbound-object)
-	   (&make-object &unassigned-type &unbound-datum))
-	  ((eq? object &unassigned-object)
-	   (&make-object &unassigned-type &unassigned-datum))
-	  (else object)))
-
-  ;; This is no longer really right, given the other traps.
-  (define (map-from-unassigned datum)
-    (if (eq? datum &unassigned-datum)				;**** cheat for speed.
-	&unassigned-object
-	&unbound-object))
-
-  (define (map-unassigned-list list)
-    (if (null? list)
-	'()
-	(cons (map-unassigned (car list))
-	      (map-unassigned-list (cdr list)))))
+(define (map-unassigned object)
+  (cond ((eq? object &unbound-object)
+	 (&make-object &unassigned-type &unbound-datum))
+	((eq? object &unassigned-object)
+	 (&make-object &unassigned-type &unassigned-datum))
+	(else object)))
+
+;;; This is no longer really right, given the other traps.
+(define (map-from-unassigned datum)
+  (if (eq? datum &unassigned-datum)	;**** cheat for speed.
+      &unassigned-object
+      &unbound-object))
+
+(define (map-unassigned-list list)
+  (if (null? list)
+      '()
+      (cons (map-unassigned (car list))
+	    (map-unassigned-list (cdr list)))))
 
 (set! make-unbound-object
-      (lambda ()
-	&unbound-object))
+  (lambda ()
+    &unbound-object))
 
 (set! unbound-object?
-      (lambda (object)
-	(eq? object &unbound-object)))
+  (lambda (object)
+    (eq? object &unbound-object)))
 
 (set! make-unassigned-object
-      (lambda ()
-	&unassigned-object))
+  (lambda ()
+    &unassigned-object))
 
 (set! unassigned-object?
-      (let ((microcode-unassigned-object
-	     (vector-ref (get-fixed-objects-vector)
-			 (fixed-objects-vector-slot 'NON-OBJECT))))
-	(lambda (object)
-	  (or (eq? object &unassigned-object)
-	      (eq? object microcode-unassigned-object)))))
-
+  (let ((microcode-unassigned-object
+	 (vector-ref (get-fixed-objects-vector)
+		     (fixed-objects-vector-slot 'NON-OBJECT))))
+    (lambda (object)
+      (or (eq? object &unassigned-object)
+	  (eq? object microcode-unassigned-object)))))
+
 (set! &typed-singleton-cons
-      (lambda (type element)
-	(system-pair-cons type
-			  (map-unassigned element)
-			  #!NULL)))
+  (lambda (type element)
+    (system-pair-cons type (map-unassigned element) '())))
 
 (set! &singleton-element
-      (lambda (singleton)
-	(if (primitive-type? &unassigned-type (system-pair-car singleton))
-	    (map-from-unassigned (primitive-datum (system-pair-car singleton)))
-	    (system-pair-car singleton))))
+  (lambda (singleton)
+    (if (primitive-type? &unassigned-type (system-pair-car singleton))
+	(map-from-unassigned (primitive-datum (system-pair-car singleton)))
+	(system-pair-car singleton))))
 
 (set! &singleton-set-element!
-      (lambda (singleton new-element)
-	(system-pair-set-car! singleton (map-unassigned new-element))))
-
+  (lambda (singleton new-element)
+    (system-pair-set-car! singleton (map-unassigned new-element))))
+
 (set! &typed-pair-cons
-      (lambda (type car cdr)
-	(system-pair-cons type
-			  (map-unassigned car)
-			  (map-unassigned cdr))))
+  (lambda (type car cdr)
+    (system-pair-cons type
+		      (map-unassigned car)
+		      (map-unassigned cdr))))
 
 (set! &pair-car
-      (lambda (pair)
-	(if (primitive-type? &unassigned-type (system-pair-car pair))
-	    (map-from-unassigned (primitive-datum (system-pair-car pair)))
-	    (system-pair-car pair))))
+  (lambda (pair)
+    (if (primitive-type? &unassigned-type (system-pair-car pair))
+	(map-from-unassigned (primitive-datum (system-pair-car pair)))
+	(system-pair-car pair))))
 
 (set! &pair-set-car!
-      (lambda (pair new-car)
-	(system-pair-set-car! pair (map-unassigned new-car))))
+  (lambda (pair new-car)
+    (system-pair-set-car! pair (map-unassigned new-car))))
 
 (set! &pair-cdr
-      (lambda (pair)
-	(if (primitive-type? &unassigned-type (system-pair-cdr pair))
-	    (map-from-unassigned (primitive-datum (system-pair-cdr pair)))
-	    (system-pair-cdr pair))))
+  (lambda (pair)
+    (if (primitive-type? &unassigned-type (system-pair-cdr pair))
+	(map-from-unassigned (primitive-datum (system-pair-cdr pair)))
+	(system-pair-cdr pair))))
 
 (set! &pair-set-cdr!
-      (lambda (pair new-cdr)
-	(system-pair-set-cdr! pair (map-unassigned new-cdr))))
-
+  (lambda (pair new-cdr)
+    (system-pair-set-cdr! pair (map-unassigned new-cdr))))
+
 (set! &typed-triple-cons
-      (lambda (type first second third)
-	(primitive-set-type type
-			    (hunk3-cons (map-unassigned first)
-					(map-unassigned second)
-					(map-unassigned third)))))
+  (lambda (type first second third)
+    (primitive-set-type type
+			(hunk3-cons (map-unassigned first)
+				    (map-unassigned second)
+				    (map-unassigned third)))))
 
 (set! &triple-first
-      (lambda (triple)
-	(if (primitive-type? &unassigned-type (system-hunk3-cxr0 triple))
-	    (map-from-unassigned (primitive-datum (system-hunk3-cxr0 triple)))
-	    (system-hunk3-cxr0 triple))))
+  (lambda (triple)
+    (if (primitive-type? &unassigned-type (system-hunk3-cxr0 triple))
+	(map-from-unassigned (primitive-datum (system-hunk3-cxr0 triple)))
+	(system-hunk3-cxr0 triple))))
 
 (set! &triple-set-first!
-      (lambda (triple new-first)
-	(system-hunk3-set-cxr0! triple (map-unassigned new-first))))
+  (lambda (triple new-first)
+    (system-hunk3-set-cxr0! triple (map-unassigned new-first))))
 
 (set! &triple-second
-      (lambda (triple)
-	(if (primitive-type? &unassigned-type (system-hunk3-cxr1 triple))
-	    (map-from-unassigned (primitive-datum (system-hunk3-cxr1 triple)))
-	    (system-hunk3-cxr1 triple))))
+  (lambda (triple)
+    (if (primitive-type? &unassigned-type (system-hunk3-cxr1 triple))
+	(map-from-unassigned (primitive-datum (system-hunk3-cxr1 triple)))
+	(system-hunk3-cxr1 triple))))
 
 (set! &triple-set-second!
-      (lambda (triple new-second)
-	(system-hunk3-set-cxr0! triple (map-unassigned new-second))))
+  (lambda (triple new-second)
+    (system-hunk3-set-cxr0! triple (map-unassigned new-second))))
 
 (set! &triple-third
-      (lambda (triple)
-	(if (primitive-type? &unassigned-type (system-hunk3-cxr2 triple))
-	    (map-from-unassigned (primitive-datum (system-hunk3-cxr2 triple)))
-	    (system-hunk3-cxr2 triple))))
+  (lambda (triple)
+    (if (primitive-type? &unassigned-type (system-hunk3-cxr2 triple))
+	(map-from-unassigned (primitive-datum (system-hunk3-cxr2 triple)))
+	(system-hunk3-cxr2 triple))))
 
 (set! &triple-set-third!
-      (lambda (triple new-third)
-	(system-hunk3-set-cxr0! triple (map-unassigned new-third))))
+  (lambda (triple new-third)
+    (system-hunk3-set-cxr0! triple (map-unassigned new-third))))
 
 (set! &typed-vector-cons
-      (lambda (type elements)
-	(system-list-to-vector type (map-unassigned-list elements))))
+  (lambda (type elements)
+    (system-list-to-vector type (map-unassigned-list elements))))
 
 (set! &list-to-vector
-      list->vector)
+  list->vector)
 
 (set! &vector-size
-      system-vector-size)
+  system-vector-size)
 
 (set! &vector-ref
-      (lambda (vector index)
-	(if (primitive-type? &unassigned-type (system-vector-ref vector index))
-	    (map-from-unassigned
-	     (primitive-datum (system-vector-ref vector index)))
-	    (system-vector-ref vector index))))
+  (lambda (vector index)
+    (if (primitive-type? &unassigned-type (system-vector-ref vector index))
+	(map-from-unassigned
+	 (primitive-datum (system-vector-ref vector index)))
+	(system-vector-ref vector index))))
 
 (set! &vector-to-list
-      (lambda (vector)
-	(&subvector-to-list vector 0 (system-vector-size vector))))
+  (lambda (vector)
+    (&subvector-to-list vector 0 (system-vector-size vector))))
 
 (set! &subvector-to-list
-      (lambda (vector start stop)
-	(let loop ((sublist (system-subvector-to-list vector start stop)))
-	  (if (null? sublist)
-	      '()
-	      (cons (if (primitive-type? &unassigned-type (car sublist))
-			(map-from-unassigned (primitive-datum (car sublist)))
-			(car sublist))
-		    (loop (cdr sublist)))))))
-
-)
+  (lambda (vector start stop)
+    (let loop ((sublist (system-subvector-to-list vector start stop)))
+      (if (null? sublist)
+	  '()
+	  (cons (if (primitive-type? &unassigned-type (car sublist))
+		    (map-from-unassigned (primitive-datum (car sublist)))
+		    (car sublist))
+		(loop (cdr sublist)))))))
+
 )
\ No newline at end of file
diff --git a/v7/src/runtime/unpars.scm b/v7/src/runtime/unpars.scm
index 1a76f98eb..30d4f03e0 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 13.42 1987/02/20 13:49:28 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unpars.scm,v 13.43 1987/04/24 13:37:27 cph Exp $
 ;;;
 ;;;	Copyright (c) 1987 Massachusetts Institute of Technology
 ;;;
@@ -114,16 +114,6 @@
        (*unparse-string "RETURN-ADDRESS ")
        (*unparse-object (return-address-name return-address))))))
 
-(define (unparse-unassigned x)
-  (unparse-with-brackets
-   (lambda ()
-     (*unparse-string "UNASSIGNED"))))
-
-(define (unparse-unbound x)
-  (unparse-with-brackets
-   (lambda ()
-     (*unparse-string "UNBOUND"))))
-
 (define (unparse-symbol symbol)
   (*unparse-string (symbol->string symbol)))
 
@@ -197,16 +187,49 @@
 
 (define-type 'LIST
   (lambda (object)
-    ((cond ((future? (car object)) unparse-list)
-	   ((unassigned-object? object) unparse-unassigned)
-	   ((unbound-object? object) unparse-unbound)
-	   (else
-	    (let ((entry (assq (car object) *unparser-special-pairs*)))
-	      (if entry
-		  (cdr entry)
-		  unparse-list))))
-     object)))
+    ((or (unparse-list/unparser object) unparse-list) object)))
 
+(define (unparse-list list)
+  (let ((kernel
+	 (lambda ()
+	   (*unparse-char #\()
+	   (*unparse-object-or-future (car list))
+	   (unparse-tail (cdr list) 2)
+	   (*unparse-char #\)))))
+    (if *unparser-list-depth-limit*
+	(fluid-let ((*unparser-list-depth* (1+ *unparser-list-depth*)))
+	  (if (> *unparser-list-depth* *unparser-list-depth-limit*)
+	      (*unparse-string "...")
+	      (kernel)))
+	(kernel))))
+
+(define (unparse-tail l n)
+  (cond ((pair? l)
+	 (let ((unparser (unparse-list/unparser l)))
+	   (if unparser
+	       (begin (*unparse-string " . ")
+		      (unparser l))
+	       (begin (*unparse-char #\Space)
+		      (*unparse-object-or-future (car l))
+		      (if (and *unparser-list-breadth-limit*
+			       (>= n *unparser-list-breadth-limit*)
+			       (not (null? (cdr l))))
+			  (*unparse-string " ...")
+			  (unparse-tail (cdr l) (1+ n)))))))
+	((not (null? l))
+	 (*unparse-string " . ")
+	 (*unparse-object-or-future l))))
+
+(define (unparse-list/unparser object)
+  (cond ((future? (car object)) false)
+	((unassigned-object? object) unparse-unassigned)
+	((unbound-object? object) unparse-unbound)
+	((reference-trap? object) unparse-reference-trap)
+	(else
+	 (let ((entry (assq (car object) *unparser-special-pairs*)))
+	   (and entry
+		(cdr entry))))))
+
 (define *unparser-special-pairs* '())
 
 (define (add-unparser-special-pair! key unparser)
@@ -223,32 +246,21 @@
 	       (*unparse-object-or-future (cadr pair)))
 	(unparse-list pair))))
 
-(define (unparse-list list)
-  (if *unparser-list-depth-limit*
-      (fluid-let ((*unparser-list-depth* (1+ *unparser-list-depth*)))
-	(if (> *unparser-list-depth* *unparser-list-depth-limit*)
-	    (*unparse-string "...")
-	    (begin (*unparse-char #\()
-		   (*unparse-object-or-future (car list))
-		   (unparse-tail (cdr list) 2)
-		   (*unparse-char #\)))))
-      (begin (*unparse-char #\()
-	     (*unparse-object-or-future (car list))
-	     (unparse-tail (cdr list) 2)
-	     (*unparse-char #\)))))
+(define (unparse-unassigned x)
+  (unparse-with-brackets
+   (lambda ()
+     (*unparse-string "UNASSIGNED"))))
 
-(define (unparse-tail l n)
-  (cond ((pair? l)
-	 (*unparse-char #\Space)
-	 (*unparse-object-or-future (car l))
-	 (if (and *unparser-list-breadth-limit*
-		  (>= n *unparser-list-breadth-limit*)
-		  (not (null? (cdr l))))
-	     (*unparse-string " ...")
-	     (unparse-tail (cdr l) (1+ n))))
-	((not (null? l))
-	 (*unparse-string " . ")
-	 (*unparse-object-or-future l))))
+(define (unparse-unbound x)
+  (unparse-with-brackets
+   (lambda ()
+     (*unparse-string "UNBOUND"))))
+
+(define (unparse-reference-trap x)
+  (unparse-with-brackets
+   (lambda ()
+     (*unparse-string "REFERENCE-TRAP ")
+     (*unparse-object (reference-trap-kind x)))))
 
 ;;;; Procedures and Environments
 
@@ -299,6 +311,4 @@
 (define-type 'COMPLEX unparse-number)
 
 ;;; end UNPARSER-PACKAGE.
-))
-
 ))
\ No newline at end of file