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 187586c26cb7811819266c5ce628a7baae53eb63..2248077af25c7e2d7ef9d4b4b3a213f2452c3c54 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 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 b0e1d36afa84e32c21cc21ca2d1bc0c9eccb49dd..3e0c7015dc1a44adc1ea4f9e6e3d83803d83d5a4 100644 (file)
--- 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)))))
+\f
 (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))))
-\f
+  (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))))
+\f
 (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))))
 \f
 (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 1a76f98eb4ebc0c5043ef3320017d575e4ac23f2..30d4f03e074d85f7516923161f1fd6d05ab1e44b 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 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 @@
 \f
 (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))))))
+\f
 (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)))))
 \f
 ;;;; Procedures and Environments
 
@@ -299,6 +311,4 @@
 (define-type 'COMPLEX unparse-number)
 
 ;;; end UNPARSER-PACKAGE.
-))
-
 ))
\ No newline at end of file