Allow a record to be both applicable and fasdumpable.

diff --git a/src/microcode/fixobj.h b/src/microcode/fixobj.h
index e1269bc522e058786804fc6f75bccbf9ddf89d83..5df8b48ec5737962522b6f13febb3bc4063992c6 100644 (file)
--- a/src/microcode/fixobj.h
+++ b/src/microcode/fixobj.h
@@ -51,7 +51,7 @@ USA.
 #define FIXOBJ_RECORD_APP_INDEX 0x12   /* Index of record applicator. */
 #define DUMMY_HISTORY          0x13    /* Empty history structure. */
 #define Bignum_One              0x14    /* Cache for bignum one. */
-/* #define UNUSED              0x15 */
+#define FIXOBJ_PROXIED_RECORD_TYPES    0x15
 #define Termination_Vector     0x16    /* Names for terminations. */
 #define Termination_Proc_Vector        0x17    /* Handlers for terminations. */
 /* #define UNUSED              0x18 */
@@ -141,7 +141,7 @@ USA.
   /* 0x12 */   "record-applicator-index",                              \
   /* 0x13 */   "dummy-history",                                        \
   /* 0x14 */   "bignum-one",                                           \
-  /* 0x15 */   0,                                                      \
+  /* 0x15 */   "proxied-record-types",                                 \
   /* 0x16 */   "microcode-terminations-vector",                        \
   /* 0x17 */   "microcode-terminations-procedures",                    \
   /* 0x18 */   0,                                                      \
@@ -184,7 +184,7 @@ USA.
   /* 0x3D */   "pc-sample/prob-comp-table",                            \
   /* 0x3E */   "pc-sample/ufo-table",                                  \
   /* 0x3F */   "compiled-code-bkpt-handler",                           \
-  /* 0x40 */   0               ,                                       \
+  /* 0x40 */   0,                                                      \
   /* 0x41 */   "callback-handler",                                     \
   /* 0x42 */   0,                                                      \
   /* 0x43 */   0,                                                      \

diff --git a/src/microcode/object.h b/src/microcode/object.h
index 063830c4d2ccf4b31e3600dd6dd76f5808eba8fe..ccaa59f0211e03e902401466d4d9753fed66e139 100644 (file)
--- a/src/microcode/object.h
+++ b/src/microcode/object.h
@@ -500,6 +500,8 @@ extern bool string_p (SCHEME_OBJECT);
    8 #!aux
    9 '()
    10 weak #f
+   ...
+   0x100 -> 0x1FF reserved for fasdumpable records
  */
 
 #define SHARP_F                        MAKE_OBJECT (TC_FALSE, 0)
@@ -507,6 +509,8 @@ extern bool string_p (SCHEME_OBJECT);
 #define UNSPECIFIC             MAKE_OBJECT (TC_CONSTANT, 1)
 #define DEFAULT_OBJECT         MAKE_OBJECT (TC_CONSTANT, 7)
 #define EMPTY_LIST             MAKE_OBJECT (TC_CONSTANT, 9)
+#define FASDUMP_RECORD_MARKER_START 0x100
+#define FASDUMP_RECORD_MARKER_END 0x200
 #define BROKEN_HEART_ZERO      MAKE_OBJECT (TC_BROKEN_HEART, 0)
 
 /* Last immediate reference trap. */

diff --git a/src/microcode/utabmd.c b/src/microcode/utabmd.c
index f91a3158955fbe6119deb9f42c88ec65a8c28cfb..a24b20463e010b18296a7491660bc028de03e07c 100644 (file)
--- a/src/microcode/utabmd.c
+++ b/src/microcode/utabmd.c
@@ -175,6 +175,11 @@ initialize_fixed_objects_vector (void)
   STORE_FIXOBJ (ARITY_DISPATCHER_TAG,
                (char_pointer_to_symbol
                 ("#[(microcode)arity-dispatcher-tag]")));
+  STORE_FIXOBJ (FIXOBJ_PROXIED_RECORD_TYPES,
+               (make_vector ((FASDUMP_RECORD_MARKER_END
+                              - FASDUMP_RECORD_MARKER_START),
+                             SHARP_F,
+                             false)));
 
 #ifdef __WIN32__
   NT_initialize_fov (fixed_objects);

diff --git a/src/microcode/vector.c b/src/microcode/vector.c
index 526dacb81674f5650fcd646192fe91e5c018acf6..3661c587b6fabefbfe806d2f9cf2cf411520cb6d 100644 (file)
--- a/src/microcode/vector.c
+++ b/src/microcode/vector.c
@@ -393,6 +393,8 @@ DEFINE_PRIMITIVE ("SUBVECTOR-FILL!", Prim_vector_fill, 4, 4, 0)
   PRIMITIVE_RETURN (UNSPECIFIC);
 }
 \f
+static SCHEME_OBJECT record_marker (SCHEME_OBJECT);
+
 /* An applicable record is one whose tag is FIXOBJ_RECORD_TAG and
    which has an applicator at FIXOBJ_RECORD_APP_INDEX within that tag.
    It is applied just like an entity: the record is passed as the
@@ -402,21 +404,24 @@ DEFINE_PRIMITIVE ("SUBVECTOR-FILL!", Prim_vector_fill, 4, 4, 0)
 SCHEME_OBJECT
 record_applicator (SCHEME_OBJECT record)
 {
-  SCHEME_OBJECT metatag = (VECTOR_REF (fixed_objects, FIXOBJ_RECORD_TAG));
-  SCHEME_OBJECT index_object
-    = (VECTOR_REF (fixed_objects, FIXOBJ_RECORD_APP_INDEX));
+  SCHEME_OBJECT marker = (record_marker (record));
+  return ((RECORD_P (marker))
+         && ((VECTOR_REF (marker, 0))
+             == (VECTOR_REF (fixed_objects, FIXOBJ_RECORD_TAG))))
+    ? (VECTOR_REF (marker,
+                  (FIXNUM_TO_ULONG (VECTOR_REF (fixed_objects,
+                                                FIXOBJ_RECORD_APP_INDEX)))))
+    : SHARP_F;
+}
 
-  if ((RECORD_P (metatag))
-      && (FIXNUM_P (index_object))
-      && (FIXNUM_TO_ULONG_P (index_object)))
-    {
-      unsigned long index = (FIXNUM_TO_ULONG (index_object));
-      SCHEME_OBJECT tag = (VECTOR_REF (record, 0));
-      if (RECORD_P (tag)
-         && ((VECTOR_REF (tag, 0)) == metatag)
-         && (index < (VECTOR_LENGTH (tag)))) {
-       return (VECTOR_REF (tag, index));
-      }
-    }
-  return SHARP_F;
+static SCHEME_OBJECT
+record_marker (SCHEME_OBJECT record)
+{
+  SCHEME_OBJECT marker = (VECTOR_REF (record, 0));
+  return (((OBJECT_TYPE (marker)) == TC_CONSTANT)
+         && ((OBJECT_DATUM (marker)) >= FASDUMP_RECORD_MARKER_START)
+         && ((OBJECT_DATUM (marker)) < FASDUMP_RECORD_MARKER_END))
+    ? (VECTOR_REF ((VECTOR_REF (fixed_objects, FIXOBJ_PROXIED_RECORD_TYPES)),
+                  ((OBJECT_DATUM (marker)) - FASDUMP_RECORD_MARKER_START)))
+    : marker;
 }

diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index 0821af908e78bb961de4bb1f80c08d6cff9beaa8..7fa99276f2f9d46075e94b895f0d08b958aa4c8d 100644 (file)
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -82,15 +82,19 @@ USA.
 (define (%valid-default-inits? default-inits n-fields)
   (fix:= n-fields (length default-inits)))
 
+(defer-boot-action 'record-procedures
+  (lambda ()
+    (set! %valid-default-inits?
+         (named-lambda (%valid-default-inits? default-inits n-fields)
+           (and (fix:= n-fields (length default-inits))
+                (every (lambda (init)
+                         (or (not init)
+                             (thunk? init)))
+                       default-inits))))
+    unspecific))
+
 (define (initialize-record-procedures!)
-  (set! %valid-default-inits?
-       (named-lambda (%valid-default-inits? default-inits n-fields)
-         (and (fix:= n-fields (length default-inits))
-              (every (lambda (init)
-                       (or (not init)
-                           (thunk? init)))
-                     default-inits))))
-  (%initialize-applicator-context!))
+  (run-deferred-boot-actions 'record-procedures))
 \f
 (define %record-metatag)
 (define record-type?)
@@ -159,8 +163,6 @@ USA.
   (guarantee record-type? record-type 'set-record-type-applicator!)
   (if applicator
       (guarantee procedure? applicator 'set-record-type-applicator!))
-  (if (%record-type-fasdumpable? record-type)
-      (error "Record types can't be applicable and fasdumpable:" record-type))
   (%set-record-type-applicator! record-type applicator))
 \f
 (define (record? object)
@@ -191,18 +193,25 @@ USA.
 (register-predicate! %record-type-proxy? 'record-type-proxy)
 
 (define (set-record-type-fasdumpable! type proxy)
-  (guarantee record-type? type 'set-record-type-fasdumpable!)
-  (guarantee %record-type-proxy? proxy 'set-record-type-fasdumpable!)
-  (if (%record-type-applicator type)
-      (error "Record types can't be applicable and fasdumpable:" type))
-  (without-interrupts
-   (lambda ()
-     (if (%record-type-fasdumpable? type)
-        (error "Record type already fasdumpable:" type))
-     (if (%proxy->record-type proxy)
-        (error "Record-type proxy already in use:" proxy))
-     (%set-proxied-record-type! proxy type)
-     (%set-record-type-instance-marker! type proxy))))
+  (defer-boot-action 'record-procedures
+    (lambda ()
+      (set-record-type-fasdumpable! type proxy))))
+
+(defer-boot-action 'record-procedures
+  (lambda ()
+    (set! set-record-type-fasdumpable!
+         (named-lambda (set-record-type-fasdumpable! type proxy)
+           (guarantee record-type? type 'set-record-type-fasdumpable!)
+           (guarantee %record-type-proxy? proxy 'set-record-type-fasdumpable!)
+           (without-interrupts
+            (lambda ()
+              (if (%record-type-fasdumpable? type)
+                  (error "Record type already fasdumpable:" type))
+              (if (%proxy->record-type proxy)
+                  (error "Record-type proxy already in use:" proxy))
+              (%set-proxied-record-type! proxy type)
+              (%set-record-type-instance-marker! type proxy)))))
+    unspecific))
 
 (define-integrable (%record-type-proxy->index marker)
   (fix:- (object-new-type (ucode-type fixnum) marker) #x100))
@@ -217,10 +226,10 @@ USA.
   (vector-set! %proxied-record-types (%record-type-proxy->index proxy) type))
 
 (define %proxied-record-types)
-(add-boot-init!
- (lambda ()
-   (set! %proxied-record-types (make-vector #x100 #f))
-   unspecific))
+(defer-boot-action 'record-procedures
+  (lambda ()
+    (set! %proxied-record-types (fixed-objects-item 'proxied-record-types))
+    unspecific))
 
 (define record-type-proxy:pathname (%index->record-type-proxy 0))
 (define record-type-proxy:host (%index->record-type-proxy 1))