From 902e2f21d388addc1677726eddc03f5e7230f9d7 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 7 Jan 2017 22:29:55 -0800 Subject: [PATCH] Always register a record predicate. --- src/runtime/defstr.scm | 14 +--- src/runtime/predicate-metadata.scm | 28 ++++---- src/runtime/record.scm | 3 +- src/runtime/runtime.pkg | 1 + src/runtime/tagging.scm | 6 +- src/runtime/url.scm | 100 +++++++++++++++-------------- 6 files changed, 70 insertions(+), 82 deletions(-) diff --git a/src/runtime/defstr.scm b/src/runtime/defstr.scm index a8e486f3f..d4d133907 100644 --- a/src/runtime/defstr.scm +++ b/src/runtime/defstr.scm @@ -786,17 +786,9 @@ differences: `((DEFINE ,tag-name (,(absolute 'RECORD-TYPE-DISPATCH-TAG context) ,tag-expression)) - (DEFINE (,predicate-name OBJECT) - (DECLARE - (IGNORE-REFERENCE-TRAPS (SET ,(close tag-name context)))) - (AND (,(absolute '%RECORD? context) OBJECT) - (,(absolute 'NOT context) - (,(absolute 'ZERO? context) - (,(absolute '%RECORD-LENGTH context) OBJECT))) - (,(absolute 'EQ? context) - (,(absolute '%RECORD-REF context) OBJECT 0) - ;++ Work around a bug in the expander. - ,(close tag-name context))))))) + (DEFINE ,predicate-name + (,(absolute 'RECORD-PREDICATE context) + ,(close (structure/type-descriptor structure) context)))))) ((VECTOR) `((DEFINE (,predicate-name OBJECT) (AND (,(absolute 'VECTOR? context) OBJECT) diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm index 932009865..ab66b660b 100644 --- a/src/runtime/predicate-metadata.scm +++ b/src/runtime/predicate-metadata.scm @@ -188,7 +188,6 @@ USA. (lambda () (register-predicate! predicate? 'predicate) (register-predicate! tag-name? 'tag-name) - (register-predicate! tag? 'tag) (register-predicate! any-object? '(conjoin) 'description "any object") (register-predicate! no-object? '(disjoin) 'description "no object") @@ -205,6 +204,12 @@ USA. (define (any-object? object) object #t) (define (no-object? object) object #f) +(add-boot-init! + (lambda () + (register-predicate! %record? '%record) + (register-predicate! record? 'record '<= %record?) + (cleanup-boot-time-record-predicates!))) + ;;; Registration of standard predicates (add-boot-init! (lambda () @@ -214,12 +219,11 @@ USA. (register-predicate! char? 'char) (register-predicate! default-object? 'default-object) (register-predicate! eof-object? 'eof-object) - (register-predicate! input-port? 'input-port) + (register-predicate! input-port? 'input-port '<= port?) (register-predicate! list? 'list) (register-predicate! number? 'number) - (register-predicate! output-port? 'output-port) + (register-predicate! output-port? 'output-port '<= port?) (register-predicate! pair? 'pair) - (register-predicate! port? 'port) (register-predicate! procedure? 'procedure) (register-predicate! string? 'string) (register-predicate! symbol? 'symbol) @@ -283,12 +287,7 @@ USA. (register-predicate! procedure-arity? 'procedure-arity) (register-predicate! thunk? 'thunk '<= procedure?) (register-predicate! unary-procedure? 'unary-procedure '<= procedure?) - (register-predicate! unparser-method? 'unparser-method '<= procedure?) - - ;; MIT/GNU Scheme: URIs - (register-predicate! uri? 'uniform-resource-identifier) - (register-predicate! absolute-uri? 'absolute-uri '<= uri?) - (register-predicate! relative-uri? 'relative-uri '<= uri?))) + (register-predicate! unparser-method? 'unparser-method '<= procedure?))) (add-boot-init! (lambda () @@ -305,17 +304,15 @@ USA. (register-predicate! environment? 'environment) (register-predicate! equality-predicate? 'equality-predicate '<= binary-procedure?) - (register-predicate! hash-table? 'hash-table) + (register-predicate! i/o-port? 'i/o-port '<= (list input-port? output-port?)) (register-predicate! interned-symbol? 'interned-symbol '<= symbol?) (register-predicate! keyword? 'keyword '<= symbol?) (register-predicate! lambda-tag? 'lambda-tag) (register-predicate! named-structure? 'named-structure) (register-predicate! population? 'population) (register-predicate! promise? 'promise) - (register-predicate! record? 'record) (register-predicate! record-type? 'record-type) (register-predicate! stack-address? 'stack-address) - (register-predicate! thread? 'thread) (register-predicate! thread-mutex? 'thread-mutex) (register-predicate! undefined-value? 'undefined-value) (register-predicate! unicode-char? 'unicode-char '<= char?) @@ -323,7 +320,4 @@ USA. '<= index-fixnum?) (register-predicate! uninterned-symbol? 'uninterned-symbol '<= symbol?) (register-predicate! weak-list? 'weak-list) - (register-predicate! weak-pair? 'weak-pair) - - ;; Must be called after record? is registered: - (cleanup-boot-time-record-predicates!))) \ No newline at end of file + (register-predicate! weak-pair? 'weak-pair))) \ No newline at end of file diff --git a/src/runtime/record.scm b/src/runtime/record.scm index 58ea3a196..db1b093b4 100644 --- a/src/runtime/record.scm +++ b/src/runtime/record.scm @@ -290,8 +290,7 @@ USA. (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)) + (%register-record-predicate! predicate record-type) (%set-record-type-tag! record-type (predicate->tag predicate)))) boot-time-record-types) (set! boot-time-record-types) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 512cbea1e..f3b311cd8 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -3642,6 +3642,7 @@ USA. (export (runtime predicate-metadata) cleanup-boot-time-record-predicates!) (export (runtime tagging) + %record-type-descriptor %record-type-tag) (initialization (initialize-package!))) diff --git a/src/runtime/tagging.scm b/src/runtime/tagging.scm index cc4fa0e24..11576336f 100644 --- a/src/runtime/tagging.scm +++ b/src/runtime/tagging.scm @@ -182,8 +182,8 @@ USA. (else default-tag))))) (define-primitive-predicate-method 'record - (let ((default-tag (predicate->tag record?))) + (let ((default-tag (predicate->tag %record?))) (lambda (object) - (if (record-type? (%record-ref object 0)) - (%record-type-tag (%record-ref object 0)) + (if (record? object) + (%record-type-tag (%record-type-descriptor object)) default-tag)))))) \ No newline at end of file diff --git a/src/runtime/url.scm b/src/runtime/url.scm index b1c9cede7..e86945f17 100644 --- a/src/runtime/url.scm +++ b/src/runtime/url.scm @@ -870,55 +870,57 @@ USA. (define url:char-set:unreserved) (define url:char-set:unescaped) -(define (initialize-package!) - (set! char-set:uri-alpha - (string->char-set - "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ")) - (set! char-set:uri-digit (string->char-set "0123456789")) - (set! char-set:uri-hex (string->char-set "0123456789abcdefABCDEF")) - (set! char-set:uri-scheme - (char-set-union char-set:uri-alpha - char-set:uri-digit - (string->char-set "+-."))) - (let* ((sub-delims (string->char-set "!$&'()*+,;=")) - (unreserved - (char-set-union char-set:uri-alpha - char-set:uri-digit - (string->char-set "-._~"))) - (component-chars - (lambda (extra) - (char-set-union unreserved sub-delims (string->char-set extra))))) - (set! char-set:uri-userinfo (component-chars ":")) - (set! char-set:uri-ipvfuture char-set:uri-userinfo) - (set! char-set:uri-reg-name (component-chars "")) - (set! char-set:uri-segment (component-chars ":@")) - (set! char-set:uri-segment-nc (component-chars "@")) - (set! char-set:uri-query (component-chars ":@/?")) - (set! char-set:uri-fragment char-set:uri-query) - (set! char-set:uri-sloppy-auth (component-chars ":@[]"))) - - (set! parser:userinfo (component-parser-* char-set:uri-userinfo)) - (set! matcher:reg-name (component-matcher-* char-set:uri-reg-name)) - (set! parser:segment (component-parser-* char-set:uri-segment)) - (set! parser:segment-nz (component-parser-+ char-set:uri-segment)) - (set! parser:segment-nz-nc (component-parser-+ char-set:uri-segment-nc)) - (set! parser:query (component-parser-* char-set:uri-query)) - (set! parser:fragment (component-parser-* char-set:uri-fragment)) - - (set! interned-uris (make-string-hash-table)) - (set! interned-uri-authorities (make-string-hash-table)) - - ;; backwards compatibility: - (set! url:char-set:unreserved - (char-set-union char-set:uri-alpha - char-set:uri-digit - (string->char-set "!$'()*+,-._"))) - (set! url:char-set:unescaped - (char-set-union url:char-set:unreserved - (string->char-set ";/?:@&="))) - - (set! uri-merge-defaults (make-uri-merge-defaults)) - unspecific) +(add-boot-init! + (lambda () + (set! char-set:uri-alpha + (string->char-set + "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ")) + (set! char-set:uri-digit (string->char-set "0123456789")) + (set! char-set:uri-hex (string->char-set "0123456789abcdefABCDEF")) + (set! char-set:uri-scheme + (char-set-union char-set:uri-alpha + char-set:uri-digit + (string->char-set "+-."))) + (let* ((sub-delims (string->char-set "!$&'()*+,;=")) + (unreserved + (char-set-union char-set:uri-alpha + char-set:uri-digit + (string->char-set "-._~"))) + (component-chars + (lambda (extra) + (char-set-union unreserved sub-delims (string->char-set extra))))) + (set! char-set:uri-userinfo (component-chars ":")) + (set! char-set:uri-ipvfuture char-set:uri-userinfo) + (set! char-set:uri-reg-name (component-chars "")) + (set! char-set:uri-segment (component-chars ":@")) + (set! char-set:uri-segment-nc (component-chars "@")) + (set! char-set:uri-query (component-chars ":@/?")) + (set! char-set:uri-fragment char-set:uri-query) + (set! char-set:uri-sloppy-auth (component-chars ":@[]"))) + + (set! parser:userinfo (component-parser-* char-set:uri-userinfo)) + (set! matcher:reg-name (component-matcher-* char-set:uri-reg-name)) + (set! parser:segment (component-parser-* char-set:uri-segment)) + (set! parser:segment-nz (component-parser-+ char-set:uri-segment)) + (set! parser:segment-nz-nc (component-parser-+ char-set:uri-segment-nc)) + (set! parser:query (component-parser-* char-set:uri-query)) + (set! parser:fragment (component-parser-* char-set:uri-fragment)) + + (set! interned-uris (make-string-hash-table)) + (set! interned-uri-authorities (make-string-hash-table)) + + ;; backwards compatibility: + (set! url:char-set:unreserved + (char-set-union char-set:uri-alpha + char-set:uri-digit + (string->char-set "!$'()*+,-._"))) + (set! url:char-set:unescaped + (char-set-union url:char-set:unreserved + (string->char-set ";/?:@&="))) + + (set! uri-merge-defaults (make-uri-merge-defaults)) + (register-predicate! absolute-uri? 'absolute-uri '<= uri?) + (register-predicate! relative-uri? 'relative-uri '<= uri?))) ;;;; Partial URIs -- 2.25.1