From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 9 Aug 1989 11:08:43 +0000 (+0000)
Subject: Implement new flag `*unparse-with-maximum-readability?*' which causes
X-Git-Tag: 20090517-FFI~11862
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f8b35dacc7ce99d5dbc05ca4f06d189769368227;p=mit-scheme.git

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 2d8cb5a16..5f1eee81f 100644
--- 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 3bcde19cd..601e44d54 100644
--- 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 95f552051..2dd5eef93 100644
--- 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 #\]))))
 
 ;;;; 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 6df9f4f33..29201de1c 100644
--- 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 acf82be4c..3506d736d 100644
--- 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