Integrate applicable records into the procedure abstraction.

Also, don't allow applicable records to be made non-applicable.  This sort of
satisfies the idea that predicates aren't time-varying, provided that the record
type's applicator is set immediately after definition.

diff --git a/src/runtime/predicate.scm b/src/runtime/predicate.scm
index da8dfc65df5250f741ea1ad7b8ddb1ec64e864cc..458d9b8b57744d7a16f0fe605e110a90c1652383 100644 (file)
--- a/src/runtime/predicate.scm
+++ b/src/runtime/predicate.scm
@@ -274,6 +274,7 @@ USA.
    (register-predicate! record? 'record
                        '<= %record?
                        '<= named-structure?)
+   (register-predicate! applicable-record? 'applicable-record '<= record?)
    (register-predicate! stack-address? 'stack-address)
    (register-predicate! thread-mutex? 'thread-mutex)
    (register-predicate! undefined-value? 'undefined-value)

diff --git a/src/runtime/procedure.scm b/src/runtime/procedure.scm
index 72ced5cd878627d5be0a6ce0181bcfbd79322ecb..6306ef4c8ea73feaa5e1b02d31f33b56e78b3c62 100644 (file)
--- a/src/runtime/procedure.scm
+++ b/src/runtime/procedure.scm
@@ -84,14 +84,17 @@ USA.
          (else (error:wrong-type-argument procedure "procedure" caller)))))
 
 (define (skip-entities object)
-  (if (%entity? object)
-      (skip-entities (if (%entity-is-apply-hook? object)
-                        (apply-hook-procedure object)
-                        (entity-procedure object)))
-      object))
+  (cond ((%entity? object)
+        (skip-entities (if (%entity-is-apply-hook? object)
+                           (apply-hook-procedure object)
+                           (entity-procedure object))))
+       ((applicable-record? object)
+        (skip-entities (record-applicator object)))
+       (else
+        object)))
 \f
 (define (procedure-arity procedure)
-  (let loop ((p procedure))
+  (define (loop p)
     (cond ((%primitive-procedure? p)
           (let ((arity ((ucode-primitive primitive-procedure-arity) p)))
             (if (fix:< arity 0)
@@ -110,21 +113,26 @@ USA.
          ((%entity? p)
           (if (%entity-is-apply-hook? p)
               (loop (apply-hook-procedure p))
-              (let ((arity (loop (entity-procedure p))))
-                (let ((min (car arity))
-                      (max (cdr arity)))
-                  (cond ((not max)
-                         (cons (if (fix:> min 0) (fix:- min 1) 0)
-                               #f))
-                        ((fix:> max 0)
-                         (cons (fix:- min 1)
-                               (fix:- max 1)))
-                        (else
-                         (error "Illegal arity for entity:"
-                                (entity-procedure p))))))))
+              (let ((p* (entity-procedure p)))
+                (or (%arity-1 (loop p*))
+                    (error "Illegal arity for entity:" p*)))))
+         ((applicable-record? p)
+          (let ((p* (record-applicator p)))
+            (or (%arity-1 (loop p*))
+                (error "Illegal arity for record applicator:" p*))))
          (else
-          (error:not-a procedure? procedure 'procedure-arity)))))
+          (error:not-a procedure? procedure 'procedure-arity))))
 
+  (define (%arity-1 arity)
+    (let ((min (car arity))
+         (max (cdr arity)))
+      (and (or (not max)
+              (fix:> max 0))
+          (cons (if (fix:> min 0) (fix:- min 1) 0)
+                (and max (fix:- max 1))))))
+
+  (loop procedure))
+\f
 ;; Here because it's needed during cold load for interpreted code.
 (define (scode-lambda-arity l)
   (cond ((object-type? (ucode-type lambda) l)

diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index f339b6eb1756b69ebc06e2a1b0c9467ec50b5593..c0c412e3de4c45f186e267bded0e4b40fd3ef15d 100644 (file)
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -136,7 +136,7 @@ USA.
          (and (%record? object)
               (or (eq? (%record-type-instance-marker type)
                        (%record-ref object 0))
-                  (let ((type* (%marker->type (%record-ref object 0))))
+                  (let ((type* (%record->type object)))
                     (and type*
                          (%record-type< type* type)))))))
        (type
@@ -154,6 +154,12 @@ USA.
                          record?))
     type))
 
+(define (%record->type record)
+  (let ((marker (%record-ref record 0)))
+    (cond ((record-type? marker) marker)
+         ((%record-type-proxy? marker) (%proxy->record-type marker))
+         (else #f))))
+
 (define (%record-type< t1 t2)
   (let ((parent (%record-type-parent t1)))
     (and parent
@@ -225,29 +231,31 @@ USA.
   (guarantee record-type? record-type 'record-type-parent)
   (%record-type-parent record-type))
 
-(define (record-type-applicator record-type)
-  (guarantee record-type? record-type 'record-type-applicator)
-  (%record-type-applicator record-type))
-
 (define (set-record-type-applicator! record-type applicator)
   (guarantee record-type? record-type 'set-record-type-applicator!)
-  (if applicator
-      (guarantee procedure? applicator 'set-record-type-applicator!))
+  (guarantee procedure? applicator 'set-record-type-applicator!)
   (%set-record-type-applicator! record-type applicator))
+
+(define (record-applicator record)
+  (or (%record-type-applicator (record-type-descriptor record))
+      (error:not-a applicable-record? record 'record-applicator)))
 \f
 (define (record? object)
   (and (%record? object)
-       (%marker->type (%record-ref object 0))))
+       (%record->type object)
+       #t))
+
+(define (applicable-record? object)
+  (and (%record? object)
+       (let ((record-type (%record->type object)))
+        (and record-type
+             (%record-type-applicator record-type)
+             #t))))
 
 (define (record-type-descriptor record)
-  (or (%marker->type (%record-ref record 0))
+  (or (%record->type record)
       (error:not-a record? record 'record-type-descriptor)))
 
-(define (%marker->type marker)
-  (cond ((record-type? marker) marker)
-       ((%record-type-proxy? marker) (%proxy->record-type marker))
-       (else #f)))
-
 (define (%record-type-fasdumpable? type)
   (%record-type-proxy? (%record-type-instance-marker type)))
 

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 8b8aed8efb07eb9327dce6f6b87da68bb0dc9568..834c4aeb10452dc2254e46882448fa55202f7ac6 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3729,6 +3729,7 @@ USA.
   (export () deprecated:record
          set-record-type-unparser-method!)
   (export ()
+         applicable-record?
          condition-type:no-such-slot
          condition-type:slot-error
          condition-type:uninitialized-slot
@@ -3747,12 +3748,12 @@ USA.
          named-vector?
          new-make-record-type
          record-accessor
+         record-applicator
          record-constructor
          record-copy
          record-keyword-constructor
          record-modifier
          record-predicate
-         record-type-applicator
          record-type-default-value-by-index
          record-type-descriptor
          record-type-dispatch-tag      ;can be deleted after 9.3 release