Implement new flag `*unparse-with-maximum-readability?*' which causes

the unparser to output `#@<n>' for things that would otherwise print
out as unreadable representations.

Fix some bugs in the `define-structure' constructor options.

diff --git a/v7/src/runtime/boot.scm b/v7/src/runtime/boot.scm
index 2d8cb5a169b9215307b86c2e67be952e5f0c4471..5f1eee81fc083192507ae42f3c3ef47d99b38188 100644 (file)
--- a/v7/src/runtime/boot.scm
+++ b/v7/src/runtime/boot.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/boot.scm,v 14.2 1988/08/05 20:16:26 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/boot.scm,v 14.3 1989/08/09 11:08:31 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -40,17 +40,24 @@ MIT in each case. |#
 (define (unparser/standard-method name #!optional unparser)
   (lambda (state object)
     (if (not (unparser-state? state)) (error "Bad unparser state" state))
-    (let ((port (unparser-state/port state)))
-      (write-string "#[" port)
-      (if (string? name)
-         (write-string name port)
-         (unparse-object state name))
-      (write-char #\Space port)
-      (write-string (number->string (hash object)) port)
-      (if (and (not (default-object? unparser)) unparser)
-         (begin (write-char #\Space port)
-                (unparser state object)))
-      (write-char #\] port))))
+    (let ((port (unparser-state/port state))
+         (hash-string (number->string (hash object))))
+      (if *unparse-with-maximum-readability?*
+         (begin
+           (write-string "#@" port)
+           (write-string hash-string port))
+         (begin
+           (write-string "#[" port)
+           (if (string? name)
+               (write-string name port)
+               (unparse-object state name))
+           (write-char #\space port)
+           (write-string hash-string port)
+           (if (and (not (default-object? unparser)) unparser)
+               (begin (write-char #\Space port)
+                      (unparser state object)))
+           (write-char #\] port))))))
+
 (define-integrable interrupt-bit/stack     #x0001)
 (define-integrable interrupt-bit/global-gc #x0002)
 (define-integrable interrupt-bit/gc        #x0004)

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 3bcde19cdffddb278e914a05999b7f7dbc16bf07..601e44d544be60cc4d3b8a3c17dffdf64c5703d1 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.44 1989/08/07 07:36:56 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.45 1989/08/09 11:08:34 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -1709,7 +1709,9 @@ MIT in each case. |#
 (define-package (runtime unparser)
   (files "unpars")
   (parent ())
-  (export ()     *unparser-list-breadth-limit*
+  (export ()
+         *unparse-with-maximum-readability?*
+         *unparser-list-breadth-limit*
          *unparser-list-depth-limit*
          *unparser-radix*
          current-unparser-table

diff --git a/v7/src/runtime/unpars.scm b/v7/src/runtime/unpars.scm
index 95f552051c9d4aae19f62d5047ecdfd057facd82..2dd5eef93fec755e52c3b3ebdc0c8035bfa7fbb1 100644 (file)
--- a/v7/src/runtime/unpars.scm
+++ b/v7/src/runtime/unpars.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unpars.scm,v 14.13 1989/08/09 11:08:39 cph Exp $
 
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -46,6 +46,7 @@ MIT in each case. |#
   (set! *unparser-list-depth-limit* false)
   (set! *unparse-primitives-by-name?* false)
   (set! *unparse-uninterned-symbols-by-name?* false)
+  (set! *unparse-with-maximum-readability?* false)
   (set! system-global-unparser-table (make-system-global-unparser-table))
   (set-current-unparser-table! system-global-unparser-table))
 
@@ -54,6 +55,7 @@ MIT in each case. |#
 (define *unparser-list-depth-limit*)
 (define *unparse-primitives-by-name?*)
 (define *unparse-uninterned-symbols-by-name?*)
+(define *unparse-with-maximum-readability?*)
 (define system-global-unparser-table)
 (define *current-unparser-table*)
 
@@ -198,41 +200,58 @@ MIT in each case. |#
 (define-integrable (*unparse-hash object)
   (*unparse-string (number->string (hash object))))
 
+(define (*unparse-readable-hash object)
+  (*unparse-string "#@")
+  (*unparse-hash object))
+
 (define (*unparse-with-brackets name object thunk)
-  (*unparse-string "#[")
-  (if (string? name)
-      (*unparse-string name)
-      (*unparse-object name))
-  (if object
-      (begin (*unparse-char #\Space)
-            (*unparse-hash object)))
-  (if thunk
-      (begin (*unparse-char #\Space)
-            (thunk)))
-  (*unparse-char #\]))
+  (if (and *unparse-with-maximum-readability?* object)
+      (*unparse-readable-hash object)
+      (begin
+       (*unparse-string "#[")
+       (if (string? name)
+           (*unparse-string name)
+           (*unparse-object name))
+       (if object
+           (begin
+             (*unparse-char #\Space)
+             (*unparse-hash object)))
+       (if thunk
+           (begin
+             (*unparse-char #\Space)
+             (thunk)))
+       (*unparse-char #\]))))
 \f
 ;;;; Unparser Methods
 
 (define (unparse/default object)
-  (let ((type (user-object-type object))
-       (gc-type ((ucode-primitive primitive-object-gc-type 1) object)))
-    (case gc-type
-      ((1 2 3 4 -3 -4)                 ; cell pair triple quad vector compiled
+  (let ((type (user-object-type object)))
+    (case ((ucode-primitive primitive-object-gc-type 1) object)
+      ((1 2 3 4 -3 -4)         ; cell pair triple quad vector compiled
        (*unparse-with-brackets type object false))
-      (else                            ; non pointer, gc special, undefined
+      ((0)                     ; non pointer
        (*unparse-with-brackets type object
-                              (lambda ()
-                                (*unparse-datum object)))))))
+        (lambda ()
+          (*unparse-datum object))))
+      (else                    ; undefined, gc special
+       (*unparse-with-brackets type false
+        (lambda ()
+          (*unparse-datum object)))))))
 
 (define (user-object-type object)
   (let ((type-code (object-type object)))
     (let ((type-name (microcode-type/code->name type-code)))
       (if type-name
-         (let ((entry (assq type-name renamed-user-object-types)))
-           (if entry (cdr entry) type-name))
+         (rename-user-object-type type-name)
          (intern
           (string-append "undefined-type:" (number->string type-code)))))))
 
+(define (rename-user-object-type type-name)
+  (let ((entry (assq type-name renamed-user-object-types)))
+    (if entry
+       (cdr entry)
+       type-name)))
+
 (define renamed-user-object-types
   '((FIXNUM . NUMBER)
     (BIGNUM . NUMBER)
@@ -454,9 +473,13 @@ MIT in each case. |#
   (let ((unparse-name
         (lambda ()
           (*unparse-object (primitive-procedure-name procedure)))))
-    (if *unparse-primitives-by-name?*
-       (unparse-name)
-       (*unparse-with-brackets 'PRIMITIVE-PROCEDURE false unparse-name))))
+    (cond (*unparse-primitives-by-name?*
+          (unparse-name))
+         (*unparse-with-maximum-readability?*
+          (*unparse-readable-hash procedure))
+         (else
+          (*unparse-with-brackets 'PRIMITIVE-PROCEDURE false unparse-name)))))
+
 (define (unparse/compiled-entry entry)
   (let* ((type (compiled-entry-type entry))
         (closure?

diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm
index 6df9f4f330f137b8630673e3754f339c33b9374f..29201de1c6bec3b27dab2867eba49143848d116e 100644 (file)
--- a/v7/src/runtime/version.scm
+++ b/v7/src/runtime/version.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.49 1989/08/07 07:37:05 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.50 1989/08/09 11:08:43 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -45,7 +45,7 @@ MIT in each case. |#
                     '()))
   (add-system! microcode-system)
   (add-event-receiver! event:after-restore snarf-microcode-version!)
-  (add-identification! "Runtime" 14 49))
+  (add-identification! "Runtime" 14 50))
 (define microcode-system)
 
 (define (snarf-microcode-version!)

diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index acf82be4c3155cb877db5ae98e950b2b134efbfa..3506d736dbfa740a4af70b0f8c6b7ada031ec105 100644 (file)
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.44 1989/08/07 07:36:56 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.45 1989/08/09 11:08:34 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -1709,7 +1709,9 @@ MIT in each case. |#
 (define-package (runtime unparser)
   (files "unpars")
   (parent ())
-  (export ()     *unparser-list-breadth-limit*
+  (export ()
+         *unparse-with-maximum-readability?*
+         *unparser-list-breadth-limit*
          *unparser-list-depth-limit*
          *unparser-radix*
          current-unparser-table