From 17cb18c746e33c3b611b86ded393bfde9d048be2 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 28 Apr 2018 22:09:56 -0700 Subject: [PATCH] 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. --- src/runtime/predicate.scm | 1 + src/runtime/procedure.scm | 46 +++++++++++++++++++++++---------------- src/runtime/record.scm | 36 ++++++++++++++++++------------ src/runtime/runtime.pkg | 3 ++- 4 files changed, 52 insertions(+), 34 deletions(-) diff --git a/src/runtime/predicate.scm b/src/runtime/predicate.scm index da8dfc65d..458d9b8b5 100644 --- 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 72ced5cd8..6306ef4c8 100644 --- 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))) (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)) + ;; 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 f339b6eb1..c0c412e3d 100644 --- 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))) (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 8b8aed8ef..834c4aeb1 100644 --- 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 -- 2.25.1