From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 10 Dec 1992 01:25:52 +0000 (+0000)
Subject: Change record support to understand that a record is applicable only
X-Git-Tag: 20090517-FFI~8660
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=deccc32658977b67f18ff6b403fcae1ba64b7f1d;p=mit-scheme.git

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 9f52c2813..1f8f899fa 100644
--- 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))
-
+
 (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))))
 
 (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 ee44b3738..96688621a 100644
--- 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 1ebaa83f1..602fa9403 100644
--- 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)))
 
diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index ee44b3738..96688621a 100644
--- 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)