From: Chris Hanson Date: Sun, 8 Jan 2017 05:30:05 +0000 (-0800) Subject: Register record-type predicates. X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~182 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1d7bef451f917cb78000b5c05543cf5f1e85e3a1;p=mit-scheme.git Register record-type predicates. --- diff --git a/src/runtime/parametric-predicate.scm b/src/runtime/parametric-predicate.scm index d223c6388..3cb939f2f 100644 --- a/src/runtime/parametric-predicate.scm +++ b/src/runtime/parametric-predicate.scm @@ -247,8 +247,6 @@ USA. (lambda () (register-predicate! parametric-predicate? 'parametric-predicate '<= predicate?) - (register-predicate! predicate-template? 'predicate-template) - (register-predicate! parameter-binding? 'parameter-binding) (register-predicate! template-pattern? 'template-pattern '<= non-empty-list?))) diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm index f6766b528..932009865 100644 --- a/src/runtime/predicate-metadata.scm +++ b/src/runtime/predicate-metadata.scm @@ -323,4 +323,7 @@ USA. '<= index-fixnum?) (register-predicate! uninterned-symbol? 'uninterned-symbol '<= symbol?) (register-predicate! weak-list? 'weak-list) - (register-predicate! weak-pair? 'weak-pair))) \ No newline at end of file + (register-predicate! weak-pair? 'weak-pair) + + ;; Must be called after record? is registered: + (cleanup-boot-time-record-predicates!))) \ No newline at end of file diff --git a/src/runtime/record.scm b/src/runtime/record.scm index 08c85fe0e..58ea3a196 100644 --- a/src/runtime/record.scm +++ b/src/runtime/record.scm @@ -75,8 +75,9 @@ USA. (%record #f #f "record-type" - '#(DISPATCH-TAG NAME FIELD-NAMES DEFAULT-INITS EXTENSION) - (vector-cons 5 #f) + '#(DISPATCH-TAG NAME FIELD-NAMES DEFAULT-INITS EXTENSION TAG) + (vector-cons 6 #f) + #f #f))) (set! record-type-type-tag (make-dispatch-tag type)) (%record-set! type 0 record-type-type-tag) @@ -146,11 +147,15 @@ USA. (->type-name type-name) names (vector-cons n #f) + #f #f)) (tag (make-dispatch-tag record-type))) (%record-set! record-type 1 tag) (if (not (default-object? default-inits)) (%set-record-type-default-inits! record-type default-inits caller)) + (%set-record-type-predicate! record-type + (lambda (object) + (%tagged-record? tag object))) (if (not (default-object? unparser-method)) (set-record-type-unparser-method! record-type unparser-method)) (if (not (default-object? entity-unparser-method)) @@ -182,6 +187,12 @@ USA. (define-integrable (%set-record-type-extension! record-type extension) (%record-set! record-type 5 extension)) +(define-integrable (%record-type-tag record-type) + (%record-ref record-type 6)) + +(define-integrable (%set-record-type-tag! record-type tag) + (%record-set! record-type 6 tag)) + (define-integrable (%record-type-n-fields record-type) (vector-length (%record-type-field-names record-type))) @@ -194,7 +205,7 @@ USA. (define (record-type-name record-type) (guarantee-record-type record-type 'RECORD-TYPE-NAME) - (%record-type-name record-type)) + (string-copy (%record-type-name record-type))) (define (record-type-field-names record-type) (guarantee-record-type record-type 'RECORD-TYPE-FIELD-NAMES) @@ -253,6 +264,39 @@ USA. (guarantee-record-type record-type 'SET-RECORD-TYPE-EXTENSION!) (%set-record-type-extension! record-type extension)) +(define boot-time-record-types '()) + +(define (%set-record-type-predicate! record-type predicate) + (set! boot-time-record-types (cons record-type boot-time-record-types)) + (%set-record-type-tag! record-type predicate)) + +(define (%record-type-predicate record-type) + (%record-type-tag record-type)) + +(define (%set-record-type-predicate!/after-boot record-type predicate) + (%register-record-predicate! predicate record-type) + (%set-record-type-tag! record-type (predicate->tag predicate))) + +(define (%register-record-predicate! predicate record-type) + (register-predicate! predicate + (string->symbol (%record-type-name record-type)) + '<= record?)) + +(define (%record-type-predicate/after-boot! record-type) + (tag->predicate (%record-type-tag record-type))) + +(define (cleanup-boot-time-record-predicates!) + (set! %set-record-type-predicate! %set-record-type-predicate!/after-boot) + (set! %record-type-predicate %record-type-predicate/after-boot!) + (for-each (lambda (record-type) + (let ((predicate (%record-type-tag record-type))) + (if (not (predicate? predicate)) + (%register-record-predicate! predicate record-type)) + (%set-record-type-tag! record-type (predicate->tag predicate)))) + boot-time-record-types) + (set! boot-time-record-types) + unspecific) + ;;;; Unparser Methods (define set-record-type-unparser-method! @@ -512,9 +556,7 @@ USA. (define (record-predicate record-type) (guarantee-record-type record-type 'RECORD-PREDICATE) - (let ((tag (record-type-dispatch-tag record-type))) - (lambda (object) - (%tagged-record? tag object)))) + (%record-type-predicate record-type)) (define (record-accessor record-type field-name) (guarantee-record-type record-type 'RECORD-ACCESSOR) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index d92d672b7..512cbea1e 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -3639,6 +3639,10 @@ USA. (export (runtime unparser) structure-tag/entity-unparser-method structure-tag/unparser-method) + (export (runtime predicate-metadata) + cleanup-boot-time-record-predicates!) + (export (runtime tagging) + %record-type-tag) (initialization (initialize-package!))) (define-package (runtime tagging) diff --git a/src/runtime/tagging.scm b/src/runtime/tagging.scm index fd67b8723..cc4fa0e24 100644 --- a/src/runtime/tagging.scm +++ b/src/runtime/tagging.scm @@ -184,4 +184,6 @@ USA. (define-primitive-predicate-method 'record (let ((default-tag (predicate->tag record?))) (lambda (object) - default-tag))))) \ No newline at end of file + (if (record-type? (%record-ref object 0)) + (%record-type-tag (%record-ref object 0)) + default-tag)))))) \ No newline at end of file