Refactor record implementation to support setting descriptions during boot.

Also clean up the way boot deferrals are done to make this simpler.

diff --git a/src/runtime/global.scm b/src/runtime/global.scm
index a4c156b4448504a2fde9960a831f6f060b1aed2e..b24344481b99d3e25bfd742b7f2959d51a7b2c3b 100644 (file)
--- a/src/runtime/global.scm
+++ b/src/runtime/global.scm
@@ -340,6 +340,12 @@ USA.
 
 (define unspecific
   (object-new-type (ucode-type constant) 1))
+
+(define (strip-angle-brackets name)
+  (if (and (string-prefix? "<" name)
+          (string-suffix? ">" name))
+      (substring name 1 (fix:- (string-length name) 1))
+      name))
 \f
 (define (for-each-interned-symbol procedure)
   (with-obarray-lock

diff --git a/src/runtime/pp.scm b/src/runtime/pp.scm
index e5cd492c5224a83d8b18bb5d1b5324e17a973e4b..bfcc3cebbdae7f769912bb5bfc7fa601fc2ea511 100644 (file)
--- a/src/runtime/pp.scm
+++ b/src/runtime/pp.scm
@@ -189,7 +189,7 @@ USA.
                     (cons (list i (%record-ref object i)) d)))))
         ((and (entity? object)
               (record? (entity-extra object)))
-         (record-entity-description object))
+        ((record-entity-describer (entity-extra object)) object))
        ((weak-pair? object)
         `((WEAK-CAR ,(weak-car object))
           (WEAK-CDR ,(weak-cdr object))))

diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index 0ffa46a549fcc6a87edceb2bf2fe6f97475f3465..d1155d92221f467c161dd3bf569f8ed2e8531d03 100644 (file)
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -65,10 +65,6 @@ USA.
       result)))
 \f
 (define record-type-type-tag)
-(define unparse-record)
-(define record-entity-unparser)
-(define record-description)
-(define record-entity-describer)
 
 (define (initialize-record-type-type!)
   (let* ((type
@@ -85,56 +81,51 @@ USA.
   (initialize-structure-type-type!))
 
 (define (initialize-record-procedures!)
-  (set! unparse-record (make-generic-procedure 2 'UNPARSE-RECORD))
-  (set-generic-procedure-default-generator! unparse-record
-    (let ((record-method (standard-unparser-method 'RECORD #f)))
-      (lambda (generic tags)
-       generic
-       (let ((tag (cadr tags)))
-         (cond ((record-type? (dispatch-tag-contents tag))
-                (standard-unparser-method
-                 (let ((name (%record-type-name (dispatch-tag-contents tag))))
-                   (if (and (string-prefix? "<" name)
-                            (string-suffix? ">" name))
-                       (substring name 1 (fix:- (string-length name) 1))
-                       name))
-                 #f))
-               ((eq? tag record-type-type-tag)
-                (standard-unparser-method 'RECORD-TYPE
-                  (lambda (type port)
-                    (write-char #\space port)
-                    (display (%record-type-name type) port))))
-               ((eq? tag (built-in-dispatch-tag 'DISPATCH-TAG))
-                (simple-unparser-method 'DISPATCH-TAG
-                  (lambda (tag)
-                    (list (dispatch-tag-contents tag)))))
-               (else record-method))))))
-  (set! record-entity-unparser
-       (make-generic-procedure 1 'RECORD-ENTITY-UNPARSER))
-  (set-generic-procedure-default-generator! record-entity-unparser
-    (let ((default-method
-          (let ((method (standard-unparser-method 'ENTITY #f)))
-            (lambda (extra) extra method))))
-      (lambda (generic tags)
-       generic tags                    ;ignore
-       default-method)))
   (set! %set-record-type-default-inits!
        %set-record-type-default-inits!/after-boot)
-  (set! set-record-type-unparser-method!
-       set-record-type-unparser-method!/after-boot)
-  (set! set-record-type-entity-unparser-method!
-       set-record-type-entity-unparser-method!/after-boot)
-  (for-each (lambda (deferral)
-             ((car deferral) (car (cdr deferral)) (cdr (cdr deferral))))
-           deferred-unparser-methods)
-  (set! deferred-unparser-methods)
-  (set! record-description (make-generic-procedure 1 'RECORD-DESCRIPTION))
-  (set-generic-procedure-default-generator! record-description
-                                            record-description/default)
-  (set! record-entity-describer
-        (make-generic-procedure 1 'RECORD-ENTITY-DESCRIBER))
-  (set-generic-procedure-default-generator! record-entity-describer
-                                            record-entity-describer/default))
+  (process-deferred-generic-inits!)
+  (process-deferred-property-recordings!))
+
+(define (defer-generic-init arity name setter default)
+  (set! deferred-generic-inits
+       (cons (cons (cons arity name) (cons setter default))
+             deferred-generic-inits))
+  unspecific)
+
+(define (process-deferred-generic-inits!)
+  (for-each (lambda (p)
+             (let ((g (make-generic-procedure (car (car p)) (cdr (car p)))))
+               (set-generic-procedure-default-generator! g (cdr (cdr p)))
+               ((car (cdr p)) g)))
+           deferred-generic-inits)
+  (set! deferred-generic-inits)
+  unspecific)
+
+(define deferred-generic-inits '())
+
+(define (deferred-property-recorder setter handler)
+  (set! deferred-procedure-settings
+       (cons (cons setter handler)
+             deferred-procedure-settings))
+  (lambda args
+    (set! deferred-property-recordings
+         (cons (cons handler args)
+               deferred-property-recordings))
+    unspecific))
+
+(define (process-deferred-property-recordings!)
+  (for-each (lambda (p)
+             ((car p) (cdr p)))
+           deferred-procedure-settings)
+  (set! deferred-procedure-settings)
+  (for-each (lambda (p)
+             ((ucode-primitive apply) (car p) (cdr p)))
+           deferred-property-recordings)
+  (set! deferred-property-recordings)
+  unspecific)
+
+(define deferred-procedure-settings '())
+(define deferred-property-recordings '())
 \f
 (define (make-record-type type-name field-names
                          #!optional
@@ -301,111 +292,144 @@ USA.
 \f
 ;;;; Unparser Methods
 
-(define (unparser-method-deferral handler)
-  (lambda (record-type method)
-    (let loop ((ms deferred-unparser-methods))
-      (if (pair? ms)
-         (if (eq? (caar ms) record-type)
-             (set-cdr! (car ms) method)
-             (loop (cdr ms)))
-         (begin
-           (set! deferred-unparser-methods
-                 (cons (cons handler (cons record-type method))
-                       deferred-unparser-methods))
-           unspecific)))))
-
-(define deferred-unparser-methods '())
-
-(define set-record-type-unparser-method!/after-boot
-  (named-lambda (set-record-type-unparser-method! record-type method)
-    (guarantee-record-type record-type 'SET-RECORD-TYPE-UNPARSER-METHOD!)
-    (if (and method (not (unparser-method? method)))
-       (error:not-a unparser-method? method 'SET-RECORD-TYPE-UNPARSER-METHOD!))
-    (let ((tag (%record-type-dispatch-tag record-type)))
-      (remove-generic-procedure-generators
-       unparse-record
-       (list (record-type-dispatch-tag rtd:unparser-state) tag))
-      (if method
-         (add-generic-procedure-generator unparse-record
-           (lambda (generic tags)
-             generic
-             (and (eq? (cadr tags) tag) method)))))))
+(define unparse-record)
+(defer-generic-init 2 'unparse-record
+  (lambda (generic)
+    (set! unparse-record generic)
+    unspecific)
+  (lambda (generic tags)
+    (declare (ignore generic))
+    (let ((tag (cadr tags)))
+      (cond ((record-type? (dispatch-tag-contents tag))
+            (standard-unparser-method
+             (strip-angle-brackets
+              (%record-type-name (dispatch-tag-contents tag)))
+             #f))
+           ((eq? tag record-type-type-tag)
+            (standard-unparser-method 'record-type
+              (lambda (type port)
+                (write-char #\space port)
+                (display (%record-type-name type) port))))
+           ((eq? tag (built-in-dispatch-tag 'dispatch-tag))
+            (simple-unparser-method 'dispatch-tag
+              (lambda (tag)
+                (list (dispatch-tag-contents tag)))))
+           (else
+            (standard-unparser-method 'record #f))))))
 
 (define set-record-type-unparser-method!
-  (unparser-method-deferral set-record-type-unparser-method!/after-boot))
-
-(define set-record-type-entity-unparser-method!/after-boot
-  (named-lambda (set-record-type-entity-unparser-method! record-type method)
-    (guarantee-record-type record-type 'SET-RECORD-TYPE-ENTITY-UNPARSER-METHOD!)
-    (if (and method (not (unparser-method? method)))
-       (error:not-a unparser-method? method
-                    'SET-RECORD-TYPE-ENTITY-UNPARSER-METHOD!))
-    (let ((tag (%record-type-dispatch-tag record-type)))
-      (remove-generic-procedure-generators record-entity-unparser (list tag))
-      (if method
-         ;; Kludge to make generic dispatch work.
-         (let ((method (lambda (extra) extra method)))
-           (add-generic-procedure-generator record-entity-unparser
+  (deferred-property-recorder
+    (lambda (real-recorder)
+      (set! set-record-type-unparser-method! real-recorder)
+      unspecific)
+    (named-lambda (set-record-type-unparser-method! record-type method)
+      (guarantee-record-type record-type 'set-record-type-unparser-method!)
+      (if (and method (not (unparser-method? method)))
+         (error:not-a unparser-method? method
+                      'set-record-type-unparser-method!))
+      (let ((tag (%record-type-dispatch-tag record-type)))
+       (remove-generic-procedure-generators
+        unparse-record
+        (list (record-type-dispatch-tag rtd:unparser-state) tag))
+       (if method
+           (add-generic-procedure-generator unparse-record
              (lambda (generic tags)
-               generic
-               (and (eq? (car tags) tag) method))))))))
+               (declare (ignore generic))
+               (and (eq? (cadr tags) tag)
+                    method))))))))
 
-(define set-record-type-entity-unparser-method!
-  (unparser-method-deferral set-record-type-entity-unparser-method!/after-boot))
-
-;;; To mimic UNPARSE-RECORD.  Dunno whether anyone cares.
+(define record-entity-unparser)
+(defer-generic-init 1 'record-entity-unparser
+  (lambda (generic)
+    (set! record-entity-unparser generic)
+    unspecific)
+  (lambda (generic tags)
+    (declare (ignore generic tags))
+    (lambda (extra)
+      (declare (ignore extra))
+      (standard-unparser-method 'entity #f))))
 
-(define (unparse-record-entity state entity)
-  (if (entity? entity)
-      (guarantee-record (entity-extra entity) 'UNPARSE-RECORD-ENTITY)
-      (error:wrong-type-argument entity "record entity"
-                                'UNPARSE-RECORD-ENTITY))
-  ((record-entity-unparser (entity-extra entity)) state entity))
+(define set-record-type-entity-unparser-method!
+  (deferred-property-recorder
+    (lambda (real-recorder)
+      (set! set-record-type-entity-unparser-method! real-recorder)
+      unspecific)
+    (named-lambda (set-record-type-entity-unparser-method! record-type method)
+      (guarantee-record-type record-type
+                            'set-record-type-entity-unparser-method!)
+      (if (and method (not (unparser-method? method)))
+         (error:not-a unparser-method? method
+                      'set-record-type-entity-unparser-method!))
+      (let ((tag (%record-type-dispatch-tag record-type)))
+       (remove-generic-procedure-generators record-entity-unparser (list tag))
+       (if method
+           ;; Kludge to make generic dispatch work.
+           (let ((method (lambda (extra) extra method)))
+             (add-generic-procedure-generator record-entity-unparser
+               (lambda (generic tags)
+                 generic
+                 (and (eq? (car tags) tag) method)))))))))
 \f
-(define (record-description/default generic tags)
-  generic
-  (if (record-type? (dispatch-tag-contents (car tags)))
-      (lambda (record)
-        (let ((type (%record-type-descriptor record)))
-          (map (lambda (field-name)
-                 `(,field-name
-                   ,((record-accessor type field-name) record)))
-               (record-type-field-names type))))
-      (lambda (record)
-        (let loop ((i (fix:- (%record-length record) 1)) (d '()))
-          (if (fix:< i 0)
-              d
-              (loop (fix:- i 1)
-                    (cons (list i (%record-ref record i)) d)))))))
-
-;; It's not kosher to use this during the cold load.
-(define (set-record-type-describer! record-type describer)
-  (guarantee-record-type record-type 'SET-RECORD-TYPE-DESCRIBER!)
-  (if describer
-      (guarantee unary-procedure? describer 'SET-RECORD-TYPE-DESCRIBER!))
-  (define-unary-generic-handler record-description record-type describer))
-
-(define (record-entity-description entity)
-  ((record-entity-describer (entity-extra entity)) entity))
-
-(define (record-entity-describer/default generic tags)
-  generic tags
-  (lambda (extra)
-    extra
-    (lambda (entity)
-      entity
-      #f)))
-
-;; It's not kosher to use this during the cold load.
-(define (set-record-type-entity-describer! record-type describer)
-  (guarantee-record-type record-type 'SET-RECORD-TYPE-ENTITY-DESCRIBER!)
-  (if describer
-      (guarantee unary-procedure? describer 'SET-RECORD-TYPE-ENTITY-DESCRIBER!))
-  (define-unary-generic-handler record-entity-describer record-type
-    ;; Kludge to make generic dispatch work.
+(define record-description)
+(defer-generic-init 1 'record-description
+  (lambda (generic)
+    (set! record-description generic)
+    unspecific)
+  (lambda (generic tags)
+    (declare (ignore generic))
+    (if (record-type? (dispatch-tag-contents (car tags)))
+       (lambda (record)
+         (let ((type (%record-type-descriptor record)))
+           (map (lambda (field-name)
+                  `(,field-name
+                    ,((record-accessor type field-name) record)))
+                (record-type-field-names type))))
+       (lambda (record)
+         (let loop ((i (fix:- (%record-length record) 1)) (d '()))
+           (if (fix:< i 0)
+               d
+               (loop (fix:- i 1)
+                     (cons (list i (%record-ref record i)) d))))))))
+
+(define set-record-type-describer!
+  (deferred-property-recorder
+    (lambda (real-recorder)
+      (set! set-record-type-describer! real-recorder)
+      unspecific)
+    (named-lambda (set-record-type-describer! record-type describer)
+      (guarantee-record-type record-type 'SET-RECORD-TYPE-DESCRIBER!)
+      (if describer
+         (guarantee unary-procedure? describer 'SET-RECORD-TYPE-DESCRIBER!))
+      (define-unary-generic-handler record-description record-type describer))))
+
+(define record-entity-describer)
+(defer-generic-init 1 'record-entity-describer
+  (lambda (generic)
+    (set! record-entity-describer generic)
+    unspecific)
+  (lambda (generic tags)
+    (declare (ignore generic tags))
     (lambda (extra)
-      extra
-      describer)))
+      (declare (ignore extra))
+      (lambda (entity)
+       (declare (ignore entity))
+       #f))))
+
+(define set-record-type-entity-describer!
+  (deferred-property-recorder
+    (lambda (real-recorder)
+      (set! set-record-type-entity-describer! real-recorder)
+      unspecific)
+    (named-lambda (set-record-type-entity-describer! record-type describer)
+      (guarantee-record-type record-type 'SET-RECORD-TYPE-ENTITY-DESCRIBER!)
+      (if describer
+         (guarantee unary-procedure? describer
+                    'SET-RECORD-TYPE-ENTITY-DESCRIBER!))
+      (define-unary-generic-handler record-entity-describer record-type
+       ;; Kludge to make generic dispatch work.
+       (lambda (extra)
+         extra
+         describer)))))
 
 (define (define-unary-generic-handler generic record-type handler)
   (let ((tag (%record-type-dispatch-tag record-type)))

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index e2e36ff395b25416e5808cd7cbe6ae68fca3c9d2..b9825a61b91b06ecf8510506e60d6b3297b7a7d9 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -556,6 +556,8 @@ USA.
          with-interrupt-mask
          with-values
          write-to-string)
+  (export (runtime)
+         strip-angle-brackets)
   (import (runtime thread)
          with-obarray-lock)
   (initialization (initialize-package!)))
@@ -3748,9 +3750,6 @@ USA.
          record-accessor
          record-constructor
          record-copy
-         record-description
-         record-entity-description
-         record-entity-unparser
          record-keyword-constructor
          record-modifier
          record-predicate
@@ -3771,11 +3770,13 @@ USA.
          set-record-type-entity-unparser-method!
          set-record-type-extension!
          set-record-type-unparser-method!
-         unparse-record
-         unparse-record-entity)
+         unparse-record)
+  (export (runtime pretty-printer)
+         record-entity-describer)
   (export (runtime record-slot-access)
          record-type-field-index)
   (export (runtime unparser)
+         record-entity-unparser
          structure-tag/entity-unparser-method
          structure-tag/unparser-method)
   (export (runtime predicate-metadata)