From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 7 Mar 1993 20:56:23 +0000 (+0000)
Subject: Add hooks to the runtime system that are for use by SOS:
X-Git-Tag: 20090517-FFI~8429
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ddd86259559f5715daebb4f7d78ceb580c523bbf;p=mit-scheme.git

Add hooks to the runtime system that are for use by SOS:

* Add a slot to record types to hold the class wrapper so that records
  can have classes associated with them, and thus be dispatched on by
  generic procedures.

* Maintain a population of record types so that classes can be added
  to records retroactively when the object system is loaded.

* Add a new unparser hook that overrides the default unparser for
  records that satisfy RECORD? (records with explicit unparsers are
  unaffected).

* Add a new unparser hook that may override the representation of
  procedures, so that generic procedures can have a special
  representation.

* Change the DEFINE-STRUCTURE macro so that record-based structures
  don't have an explicit unparser unless the PRINT-PROCEDURE option is
  used.
---

diff --git a/v7/src/runtime/defstr.scm b/v7/src/runtime/defstr.scm
index 06a939124..af304271b 100644
--- a/v7/src/runtime/defstr.scm
+++ b/v7/src/runtime/defstr.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: defstr.scm,v 14.22 1992/12/28 21:56:38 cph Exp $
+$Id: defstr.scm,v 14.23 1993/03/07 20:56:20 cph Exp $
 
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+Copyright (c) 1988-93 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -129,7 +129,7 @@ differences:
 	(keyword-constructors '())
 	(copier-name false)
 	(predicate-name (symbol-append name '?))
-	(print-procedure `(,(absolute 'UNPARSER/STANDARD-METHOD) ',name))
+	(print-procedure default)
 	(type 'RECORD)
 	(type-name name)
 	(tag-expression)
@@ -279,7 +279,7 @@ differences:
 			  (cdr option-seen))))))
 	      (if predicate-name
 		  (check (assq 'PREDICATE options-seen)))
-	      (if print-procedure
+	      (if (and (not (eq? print-procedure default)) print-procedure)
 		  (check (assq 'PRINT-PROCEDURE options-seen)))))
 	(make-structure name
 			conc-name
@@ -293,13 +293,23 @@ differences:
 			       '()))
 			copier-name
 			(and named? predicate-name)
-			(and named? print-procedure)
+			(and named?
+			     (cond ((not (eq? print-procedure default))
+				    print-procedure)
+				   ((eq? type 'RECORD)
+				    false)
+				   (else
+				    `(,(absolute 'UNPARSER/STANDARD-METHOD)
+				      ',name))))
 			type
 			named?
 			(and named? type-name)
 			(and named? tag-expression)
 			offset
 			slots)))))
+
+(define default
+  (list 'DEFAULT))
 
 ;;;; Parse Slot-Descriptions
 
diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm
index 7afef06e8..f35542b73 100644
--- a/v7/src/runtime/make.scm
+++ b/v7/src/runtime/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 14.44 1993/03/01 17:40:20 gjr Exp $
+$Id: make.scm,v 14.45 1993/03/07 20:56:21 cph Exp $
 
 Copyright (c) 1988-1993 Massachusetts Institute of Technology
 
@@ -337,10 +337,10 @@ MIT in each case. |#
 	 ("list" . (RUNTIME LIST))
 	 ("symbol" . ())
 	 ("uproc" . (RUNTIME PROCEDURE))
+	 ("poplat" . (RUNTIME POPULATION))
 	 ("record" . (RUNTIME RECORD))))
       (files2
        '(("defstr" . (RUNTIME DEFSTRUCT))
-	 ("poplat" . (RUNTIME POPULATION))
 	 ("prop1d" . (RUNTIME 1D-PROPERTY))
 	 ("events" . (RUNTIME EVENT-DISTRIBUTOR))
 	 ("gdatab" . (RUNTIME GLOBAL-DATABASE))))
@@ -357,10 +357,10 @@ MIT in each case. |#
 		      'CONSTANT-SPACE/BASE
 		      constant-space/base)
   (package-initialize '(RUNTIME LIST) 'INITIALIZE-PACKAGE! true)
+  (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-PACKAGE! true)
   (package-initialize '(RUNTIME RECORD) 'INITIALIZE-PACKAGE! true)
   (package-initialize '(PACKAGE) 'FINALIZE-PACKAGE-RECORD-TYPE! true)
   (load-files files2)
-  (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-PACKAGE! true)
   (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-PACKAGE! true)
   (package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE! true)
   (package-initialize '(RUNTIME GLOBAL-DATABASE) 'INITIALIZE-PACKAGE! true)
diff --git a/v7/src/runtime/record.scm b/v7/src/runtime/record.scm
index 840b0eef6..cc4749dd5 100644
--- a/v7/src/runtime/record.scm
+++ b/v7/src/runtime/record.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: record.scm,v 1.19 1992/12/17 00:05:34 cph Exp $
+$Id: record.scm,v 1.20 1993/03/07 20:56:21 cph Exp $
 
-Copyright (c) 1989-1992 Massachusetts Institute of Technology
+Copyright (c) 1989-93 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -49,6 +49,30 @@ MIT in each case. |#
   (primitive-object-set! 3)
   (primitive-object-set-type 2))
 
+(define record-type-type)
+(define record-type-population)
+(define record-type-initialization-hook)
+
+(define (initialize-package!)
+  (set! record-type-type
+	(let ((record-type-type
+	       (%record false
+			false
+			"record-type"
+			'(RECORD-TYPE-APPLICATION-METHOD
+			  RECORD-TYPE-NAME
+			  RECORD-TYPE-FIELD-NAMES
+			  RECORD-TYPE-METHODS
+			  RECORD-TYPE-CLASS-WRAPPER)
+			'()
+			false)))
+	  (%record-set! record-type-type 0 record-type-type)
+	  (%record-type-has-application-method! record-type-type)
+	  record-type-type))
+  (set! record-type-population (make-population))
+  (set! record-type-initialization-hook false)
+  (add-to-population! record-type-population record-type-type))
+
 (define-integrable (%record? object)
   (object-type? (ucode-type record) object))
 
@@ -97,8 +121,12 @@ MIT in each case. |#
 		  false
 		  (->string type-name)
 		  (list-copy field-names)
+		  false
 		  false)))
     (%record-type-has-application-method! record-type)
+    (add-to-population! record-type-population record-type)
+    (if record-type-initialization-hook
+	(record-type-initialization-hook record-type))
     record-type))
 
 (define (record-type? object)
@@ -131,36 +159,31 @@ MIT in each case. |#
   (%record-ref record-type 3))
 
 (define (record-type-unparser-method record-type)
-  (guarantee-record-type record-type 'RECORD-TYPE-UNPARSER-METHOD)
-  (%record-type/unparser-method record-type))
-
-(define-integrable (%record-type/unparser-method record-type)
-  (%record-ref record-type 4))
+  (record-type-method record-type 'UNPARSER))
 
 (define (set-record-type-unparser-method! record-type method)
-  (guarantee-record-type record-type 'SET-RECORD-TYPE-UNPARSER-METHOD!)
   (if (not (or (not method) (procedure? method)))
       (error:wrong-type-argument method "unparser method"
 				 'SET-RECORD-TYPE-UNPARSER-METHOD!))
-  (%record-set! record-type 4 method))
-
-(define record-type-type)
-
-(define (initialize-package!)
-  (set! record-type-type
-	(let ((record-type-type
-	       (%record false
-			false
-			"record-type"
-			'(RECORD-TYPE-APPLICATION-METHOD
-			  RECORD-TYPE-NAME
-			  RECORD-TYPE-FIELD-NAMES
-			  RECORD-TYPE-UNPARSER-METHOD)
-			false)))
-	  (%record-set! record-type-type 0 record-type-type)
-	  (%record-type-has-application-method! record-type-type)
-	  record-type-type))
-  unspecific)
+  (set-record-type-method! record-type 'UNPARSER method))
+
+(define (record-type-method record-type keyword)
+  (guarantee-record-type record-type 'RECORD-TYPE-METHOD)
+  (let ((entry (assq keyword (%record-ref record-type 4))))
+    (and entry
+	 (cdr entry))))
+
+(define (set-record-type-method! record-type keyword method)
+  (guarantee-record-type record-type 'SET-RECORD-TYPE-METHOD!)
+  (let ((methods (%record-ref record-type 4)))
+    (let ((entry (assq keyword methods)))
+      (if method
+	  (if entry
+	      (set-cdr! entry method)
+	      (%record-set! record-type 4
+			    (cons (cons keyword method) methods)))
+	  (if entry
+	      (%record-set! record-type 4 (delq! entry methods)))))))
 
 (define (record-type-field-index record-type field-name procedure-name)
   (let loop ((field-names (%record-type/field-names record-type)) (index 1))
@@ -209,18 +232,14 @@ MIT in each case. |#
   (guarantee-record record 'RECORD-COPY)
   (%record-copy record))
 
-(define (%record-unparser-method record)
-  ;; Used by unparser.  Assumes RECORD has type-code RECORD.
-  (let ((type (%record-ref record 0)))
-    (and (record-type? type)
-	 (or (%record-type/unparser-method type)
-	     (unparser/standard-method (record-type-name type))))))
-
 (define (record-description record)
   (let ((type (record-type-descriptor record)))
-    (map (lambda (field-name)
-	   `(,field-name ,((record-accessor type field-name) record)))
-	 (record-type-field-names type))))
+    (let ((method (record-type-method type 'DESCRIPTION)))
+      (if method
+	  (method record)
+	  (map (lambda (field-name)
+		 `(,field-name ,((record-accessor type field-name) record)))
+	       (record-type-field-names type))))))
 
 (define (record-predicate record-type)
   (guarantee-record-type record-type 'RECORD-PREDICATE)
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 67d53df6a..58262b8a2 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.174 1993/01/29 16:42:08 cph Exp $
+$Id: runtime.pkg,v 14.175 1993/03/07 20:56:22 cph Exp $
 
 Copyright (c) 1988-1993 Massachusetts Institute of Technology
 
@@ -1712,7 +1712,6 @@ MIT in each case. |#
 	  %record-ref
 	  %record-set!
 	  %record-type-has-application-method!
-	  %record-unparser-method
 	  %record?
 	  make-record-type
 	  record-accessor
@@ -1724,12 +1723,14 @@ MIT in each case. |#
 	  record-type-application-method
 	  record-type-descriptor
 	  record-type-field-names
+	  record-type-method
 	  record-type-name
 	  record-type-unparser-method
 	  record-type?
 	  record-updater
 	  record?
 	  set-record-type-application-method!
+	  set-record-type-method!
 	  set-record-type-unparser-method!)
   (initialization (initialize-package!)))
 
diff --git a/v7/src/runtime/unpars.scm b/v7/src/runtime/unpars.scm
index dff494dcf..30f4c9d4f 100644
--- a/v7/src/runtime/unpars.scm
+++ b/v7/src/runtime/unpars.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: unpars.scm,v 14.29 1992/12/07 19:07:00 cph Exp $
+$Id: unpars.scm,v 14.30 1993/03/07 20:56:23 cph Exp $
 
-Copyright (c) 1988-92 Massachusetts Institute of Technology
+Copyright (c) 1988-93 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -41,6 +41,8 @@ MIT in each case. |#
   (set! string-delimiters
 	(char-set-union char-set:not-graphic (char-set #\" #\\)))
   (set! hook/interned-symbol unparse-symbol)
+  (set! hook/unparse-record false)
+  (set! hook/procedure-unparser false)
   (set! *unparser-radix* 10)
   (set! *unparser-list-breadth-limit* false)
   (set! *unparser-list-depth-limit* false)
@@ -435,10 +437,17 @@ MIT in each case. |#
   (vector-ref vector index))
 
 (define (unparse/record record)
-  (let ((method (%record-unparser-method record)))
-    (if method
-	(invoke-user-method method record)
-	(unparse/default record))))
+  (if (record? record)
+      (let ((type (record-type-descriptor record)))
+	(let ((method
+	       (or (record-type-unparser-method type)
+		   hook/unparse-record)))
+	  (if method
+	      (invoke-user-method method record)
+	      (*unparse-with-brackets (record-type-name type) record #f))))
+      (unparse/default record)))
+
+(define hook/unparse-record)
 
 (define (unparse/pair pair)
   (let ((prefix (unparse-list/prefix-pair? pair)))
@@ -520,61 +529,80 @@ MIT in each case. |#
 
 ;;;; Procedures and Environments
 
+(define hook/procedure-unparser)
+
+(define (unparse-procedure procedure usual-method)
+  (let ((method
+	 (and hook/procedure-unparser
+	      (hook/procedure-unparser procedure))))
+    (if method
+	(invoke-user-method method procedure)
+	(usual-method))))
+
 (define (unparse/compound-procedure procedure)
-  (*unparse-with-brackets 'COMPOUND-PROCEDURE procedure
-    (lambda-components* (procedure-lambda procedure)
-      (lambda (name required optional rest body)
-	required optional rest body
+  (unparse-procedure procedure
+    (lambda ()
+      (*unparse-with-brackets 'COMPOUND-PROCEDURE procedure
 	(and *unparse-compound-procedure-names?*
-	     (not (eq? name lambda-tag:unnamed))
-	     (lambda () (*unparse-object name)))))))
+	     (lambda-components* (procedure-lambda procedure)
+	       (lambda (name required optional rest body)
+		 required optional rest body
+		 (and (not (eq? name lambda-tag:unnamed))
+		      (lambda () (*unparse-object name))))))))))
 
 (define (unparse/primitive-procedure procedure)
-  (let ((unparse-name
-	 (lambda ()
-	   (*unparse-object (primitive-procedure-name procedure)))))
-    (cond (*unparse-primitives-by-name?*
-	   (unparse-name))
-	  (*unparse-with-maximum-readability?*
-	   (*unparse-readable-hash procedure))
-	  (else
-	   (*unparse-with-brackets 'PRIMITIVE-PROCEDURE false unparse-name)))))
+  (unparse-procedure procedure
+    (lambda ()
+      (let ((unparse-name
+	     (lambda ()
+	       (*unparse-object (primitive-procedure-name procedure)))))
+	(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))
+	 (procedure? (eq? type 'COMPILED-PROCEDURE))
 	 (closure?
-	  (and (eq? type 'COMPILED-PROCEDURE)
+	  (and procedure?
 	       (compiled-code-block/manifest-closure?
-		(compiled-code-address->block entry)))))
-    (*unparse-with-brackets
-     (if closure? 'COMPILED-CLOSURE type)
-     entry
-     (lambda ()
-       (let ((name
-	      (and (eq? type 'COMPILED-PROCEDURE)
-		   (compiled-procedure/name entry))))
-	 (with-values (lambda () (compiled-entry/filename entry))
-	   (lambda (filename block-number)
-	     (*unparse-char #\()
-	     (if name
-		 (*unparse-string name))
-	     (if filename
-		 (begin
-		   (if name
-		       (*unparse-char #\Space))
-		   (*unparse-object (pathname-name filename))
-		   (if block-number
-		       (begin
-			 (*unparse-char #\Space)
-			 (*unparse-hex block-number)))))
-	     (*unparse-char #\)))))
-       (*unparse-char #\Space)
-       (*unparse-hex (compiled-entry/offset entry))
-       (*unparse-char #\Space)
-       (if closure?
-	   (begin (*unparse-datum (compiled-closure->entry entry))
-		  (*unparse-char #\Space)))
-       (*unparse-datum entry)))))
+		(compiled-code-address->block entry))))
+	 (usual-method
+	  (lambda ()
+	    (*unparse-with-brackets (if closure? 'COMPILED-CLOSURE type)
+				    entry
+	      (lambda ()
+		(let ((name (and procedure? (compiled-procedure/name entry))))
+		  (with-values (lambda () (compiled-entry/filename entry))
+		    (lambda (filename block-number)
+		      (*unparse-char #\()
+		      (if name
+			  (*unparse-string name))
+		      (if filename
+			  (begin
+			    (if name
+				(*unparse-char #\Space))
+			    (*unparse-object (pathname-name filename))
+			    (if block-number
+				(begin
+				  (*unparse-char #\Space)
+				  (*unparse-hex block-number)))))
+		      (*unparse-char #\)))))
+		(*unparse-char #\Space)
+		(*unparse-hex (compiled-entry/offset entry))
+		(if closure?
+		    (begin
+		      (*unparse-char #\Space)
+		      (*unparse-datum (compiled-closure->entry entry))))
+		(*unparse-char #\Space)
+		(*unparse-datum entry))))))
+    (if procedure?
+	(unparse-procedure entry usual-method)
+	(usual-method))))
 
 ;;;; Miscellaneous
 
diff --git a/v8/src/runtime/make.scm b/v8/src/runtime/make.scm
index 7afef06e8..f35542b73 100644
--- a/v8/src/runtime/make.scm
+++ b/v8/src/runtime/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 14.44 1993/03/01 17:40:20 gjr Exp $
+$Id: make.scm,v 14.45 1993/03/07 20:56:21 cph Exp $
 
 Copyright (c) 1988-1993 Massachusetts Institute of Technology
 
@@ -337,10 +337,10 @@ MIT in each case. |#
 	 ("list" . (RUNTIME LIST))
 	 ("symbol" . ())
 	 ("uproc" . (RUNTIME PROCEDURE))
+	 ("poplat" . (RUNTIME POPULATION))
 	 ("record" . (RUNTIME RECORD))))
       (files2
        '(("defstr" . (RUNTIME DEFSTRUCT))
-	 ("poplat" . (RUNTIME POPULATION))
 	 ("prop1d" . (RUNTIME 1D-PROPERTY))
 	 ("events" . (RUNTIME EVENT-DISTRIBUTOR))
 	 ("gdatab" . (RUNTIME GLOBAL-DATABASE))))
@@ -357,10 +357,10 @@ MIT in each case. |#
 		      'CONSTANT-SPACE/BASE
 		      constant-space/base)
   (package-initialize '(RUNTIME LIST) 'INITIALIZE-PACKAGE! true)
+  (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-PACKAGE! true)
   (package-initialize '(RUNTIME RECORD) 'INITIALIZE-PACKAGE! true)
   (package-initialize '(PACKAGE) 'FINALIZE-PACKAGE-RECORD-TYPE! true)
   (load-files files2)
-  (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-PACKAGE! true)
   (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-PACKAGE! true)
   (package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE! true)
   (package-initialize '(RUNTIME GLOBAL-DATABASE) 'INITIALIZE-PACKAGE! true)
diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index 67d53df6a..58262b8a2 100644
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.174 1993/01/29 16:42:08 cph Exp $
+$Id: runtime.pkg,v 14.175 1993/03/07 20:56:22 cph Exp $
 
 Copyright (c) 1988-1993 Massachusetts Institute of Technology
 
@@ -1712,7 +1712,6 @@ MIT in each case. |#
 	  %record-ref
 	  %record-set!
 	  %record-type-has-application-method!
-	  %record-unparser-method
 	  %record?
 	  make-record-type
 	  record-accessor
@@ -1724,12 +1723,14 @@ MIT in each case. |#
 	  record-type-application-method
 	  record-type-descriptor
 	  record-type-field-names
+	  record-type-method
 	  record-type-name
 	  record-type-unparser-method
 	  record-type?
 	  record-updater
 	  record?
 	  set-record-type-application-method!
+	  set-record-type-method!
 	  set-record-type-unparser-method!)
   (initialization (initialize-package!)))