Change record support to understand that a record is applicable only

when its type is a record whose length field has been specially
marked.

diff --git a/v7/src/runtime/record.scm b/v7/src/runtime/record.scm
index 9f52c2813b33fec6cd41fe54e8f1f16dc036514b..1f8f899fa607970037ecfd8f9f827419da5fe8b0 100644 (file)
--- a/v7/src/runtime/record.scm
+++ b/v7/src/runtime/record.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: record.scm,v 1.17 1992/12/07 19:06:52 cph Exp $
+$Id: record.scm,v 1.18 1992/12/10 01:25:37 cph Exp $
 
 Copyright (c) 1989-1992 Massachusetts Institute of Technology
 
@@ -39,12 +39,15 @@ MIT in each case. |#
 ;;; conforms to R4RS proposal
 
 (declare (usual-integrations))
-
+\f
 (define-primitives
   (%record -1)
   (%record-length 1)
   (%record-ref 2)
-  (%record-set! 3))
+  (%record-set! 3)
+  (primitive-object-ref 2)
+  (primitive-object-set! 3)
+  (primitive-object-set-type 2))
 
 (define-integrable (%record? object)
   (object-type? (ucode-type record) object))
@@ -61,18 +64,42 @@ MIT in each case. |#
 (define (%record-copy record)
   (let ((length (%record-length record)))
     (let ((result (object-new-type (ucode-type record) (make-vector length))))
+      ;; Clobber RESULT's length field with that of RECORD, since
+      ;; there is important information in the type of that field that
+      ;; is not preserved by %RECORD-LENGTH.
+      (primitive-object-set! result 0 (primitive-object-ref record 0))
       (do ((index 0 (+ index 1)))
          ((= index length))
        (%record-set! result index (%record-ref record index)))
       result)))
+
+(define (%record-application-method record)
+  ;; This procedure must match the code in "microcode/interp.c".
+  (let ((record-type (%record-ref record 0)))
+    (and (and (object-type? (ucode-type constant)
+                           (primitive-object-ref record-type 0))
+             (>= (%record-length record-type) 2))
+        (let ((method (%record-ref record-type 1)))
+          (and (not (eq? method record))
+               method)))))
+
+(define (%record-type-has-application-method! record-type)
+  (primitive-object-set!
+   record-type
+   0
+   (primitive-object-set-type (ucode-type constant)
+                             (primitive-object-ref record-type 0))))
 \f
 (define (make-record-type type-name field-names)
   (guarantee-list-of-unique-symbols field-names 'MAKE-RECORD-TYPE)
-  (%record record-type-type
-          false
-          (->string type-name)
-          (list-copy field-names)
-          false))
+  (let ((record-type
+        (%record record-type-type
+                 false
+                 (->string type-name)
+                 (list-copy field-names)
+                 false)))
+    (%record-type-has-application-method! record-type)
+    record-type))
 
 (define (record-type? object)
   (and (%record? object)
@@ -131,6 +158,7 @@ MIT in each case. |#
                          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)
 

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index ee44b3738a034208623f25155bf6dc75ece1ef23..96688621acd3ab7886a54d9ce6c4c70bcca1cf53 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.166 1992/12/07 19:06:56 cph Exp $
+$Id: runtime.pkg,v 14.167 1992/12/10 01:25:45 cph Exp $
 
 Copyright (c) 1988-1992 Massachusetts Institute of Technology
 
@@ -1695,10 +1695,13 @@ MIT in each case. |#
   (export ()
          %make-record
          %record
+         %record-application-method
          %record-copy
          %record-length
          %record-ref
          %record-set!
+         %record-type-has-application-method!
+         %record-unparser-method
          %record?
          make-record-type
          record-accessor
@@ -1717,8 +1720,6 @@ MIT in each case. |#
          record?
          set-record-type-application-method!
          set-record-type-unparser-method!)
-  (export (runtime unparser)
-         %record-unparser-method)
   (initialization (initialize-package!)))
 
 (define-package (runtime reference-trap)

diff --git a/v7/src/runtime/uproc.scm b/v7/src/runtime/uproc.scm
index 1ebaa83f189598bf85731b35d382b01408775584..602fa940324ee336c2ad8a103973ea4c59f87b2b 100644 (file)
--- a/v7/src/runtime/uproc.scm
+++ b/v7/src/runtime/uproc.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: uproc.scm,v 1.4 1992/12/03 19:18:07 cph Exp $
+$Id: uproc.scm,v 1.5 1992/12/10 01:25:52 cph Exp $
 
 Copyright (c) 1990-92 Massachusetts Institute of Technology
 
@@ -83,12 +83,11 @@ MIT in each case. |#
         (skip-entities (if (%entity-is-apply-hook? object)
                            (apply-hook-procedure object)
                            (entity-procedure object))))
-       ((and (%record? object)
-             (let ((type (%record-ref object 0)))
-               (and (%record? type)
-                    (>= (%record-length type) 2)
-                    (%record-ref type 1))))
-        => skip-entities)
+       ((%record? object)
+        (let ((method (%record-application-method record)))
+          (if method
+              (skip-entities method)
+              object)))
        (else
         object)))
 \f

diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index ee44b3738a034208623f25155bf6dc75ece1ef23..96688621acd3ab7886a54d9ce6c4c70bcca1cf53 100644 (file)
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.166 1992/12/07 19:06:56 cph Exp $
+$Id: runtime.pkg,v 14.167 1992/12/10 01:25:45 cph Exp $
 
 Copyright (c) 1988-1992 Massachusetts Institute of Technology
 
@@ -1695,10 +1695,13 @@ MIT in each case. |#
   (export ()
          %make-record
          %record
+         %record-application-method
          %record-copy
          %record-length
          %record-ref
          %record-set!
+         %record-type-has-application-method!
+         %record-unparser-method
          %record?
          make-record-type
          record-accessor
@@ -1717,8 +1720,6 @@ MIT in each case. |#
          record?
          set-record-type-application-method!
          set-record-type-unparser-method!)
-  (export (runtime unparser)
-         %record-unparser-method)
   (initialization (initialize-package!)))
 
 (define-package (runtime reference-trap)