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 06a939124e2193caecdb8b005324b50e605f2b78..af304271b84645695f6838198879e38fb3e7cc47 100644 (file)
--- 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))
 \f
 ;;;; Parse Slot-Descriptions
 

diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm
index 7afef06e8b62d78cf23d786e0cf2d7be2fb0d5e9..f35542b73c05cdacdb5524fba67f56ad57d043f5 100644 (file)
--- 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 840b0eef6a7f98112c665b6edbb50296ecbe5dc6..cc4749dd50194a35ff39a550d7b47182b7c51d1b 100644 (file)
--- 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 67d53df6a6475787458d9706c6c6cd03681388f6..58262b8a2b4dc1a33366dfe7aeec8cfcfe3363b8 100644 (file)
--- 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 dff494dcf27c9284a7a8ce053143cdb2887dba86..30f4c9d4f5ef268449f4c32ab488534e5e71a16c 100644 (file)
--- 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)
 \f
 (define (unparse/pair pair)
   (let ((prefix (unparse-list/prefix-pair? pair)))
@@ -520,61 +529,80 @@ MIT in each case. |#
 \f
 ;;;; 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))))
 \f
 ;;;; Miscellaneous
 

diff --git a/v8/src/runtime/make.scm b/v8/src/runtime/make.scm
index 7afef06e8b62d78cf23d786e0cf2d7be2fb0d5e9..f35542b73c05cdacdb5524fba67f56ad57d043f5 100644 (file)
--- 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 67d53df6a6475787458d9706c6c6cd03681388f6..58262b8a2b4dc1a33366dfe7aeec8cfcfe3363b8 100644 (file)
--- 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!)))