diff --git a/mats/primvars.ms b/mats/primvars.ms index 6b7f2bab8..777713574 100644 --- a/mats/primvars.ms +++ b/mats/primvars.ms @@ -300,13 +300,14 @@ [((in ...) ...) #`(((in ...) #,outs) ...)]))) (define do-entry (lambda (x) - (syntax-case x (feature sig flags ->) + (syntax-case x (feature sig pred flags ->) [(prim [feature f] . more) (if (memq (datum f) feature*) (do-entry #'(prim . more)) #'(void))] [(prim [flags flag ...]) (do-entry #'(prim [sig] [flags flag ...]))] - [(prim [sig [(in ...) ... -> (out ...)] ...] [flags flag ...]) + [(prim [sig sigs ...] [flags flag ...]) (do-entry #'(prim [sig sigs ...] [pred #f] [flags flag ...]))] + [(prim [sig [(in ...) ... -> (out ...)] ...] [pred p] [flags flag ...]) (with-syntax ([(unprefixed . prim) (prim-name #'prim)]) (with-syntax ([((((in ...) (out ...)) ...) ...) (map ins-and-outs #'(((in ...) ...) ...) #'((out ...) ...))]) diff --git a/rktboot/primdata.rkt b/rktboot/primdata.rkt index 1b3f773a2..1f7c8c522 100644 --- a/rktboot/primdata.rkt +++ b/rktboot/primdata.rkt @@ -68,7 +68,8 @@ (define-values (flags sigs) (for/fold ([flags group-flags] [sigs null]) ([spec (in-list specs)]) (match spec - [`[sig ,sigs ...] (values flags sigs )] + [`[sig ,sigs ...] (values flags sigs)] + [`[pred ,pred] (values flags sigs)] [`[flags ,flags ...] (values (append flags group-flags) sigs)] [`[feature ,features ...] (values flags sigs)]))) (define plain-id (if (pair? id) diff --git a/s/cptypes-lattice.ss b/s/cptypes-lattice.ss index d3872fb9c..2b2e07dc2 100644 --- a/s/cptypes-lattice.ss +++ b/s/cptypes-lattice.ss @@ -65,10 +65,6 @@ flonum-pred real-pred number-pred - exact-pred - inexact-pred - integer-pred - flinteger-pred flzero-pred $fixmediate-pred $list-pred ; immutable lists @@ -201,6 +197,7 @@ number*-pred real*-pred ratnum-pred flonum-pred flinteger-pred flzero-pred exact*-pred inexact-pred + exact-complex-pred inexact-complex-pred char-pred symbol-pred interned-symbol-pred uninterned-symbol-pred gensym-pred) @@ -262,6 +259,8 @@ (define flzero-pred (make-pred-multiplet flzero-mask)) (define exact*-pred (make-pred-multiplet exact*-pred-mask)) (define inexact-pred (make-pred-multiplet inexact-pred-mask)) + (define exact-complex-pred (make-pred-multiplet exact-complex-mask)) + (define inexact-complex-pred (make-pred-multiplet inexact-complex-mask)) (define char-pred (make-pred-multiplet char-mask)) (define symbol-pred (make-pred-multiplet symbol-pred-mask)) (define interned-symbol-pred (make-pred-multiplet interned-symbol-mask)) @@ -292,6 +291,7 @@ (define maybe-bytevector-pred (make-pred-or false-rec 'bottom 'bytevector 'bottom 'bottom)) (define eof/bytevector-pred (make-pred-or eof-rec 'bottom 'bytevector 'bottom 'bottom)) (define maybe-pair-pred (make-pred-or false-rec 'bottom 'pair 'bottom 'bottom)) + (define maybe-port-pred (make-pred-or false-rec 'bottom 'port 'bottom 'bottom)) (define maybe-symbol/string-pred (make-pred-or false-rec symbol-pred 'string 'bottom 'bottom)) (define maybe-$record-pred (make-pred-or false-rec 'bottom 'bottom 'bottom '$record)) (define maybe-char-pred (make-pred-or false-rec char-pred 'bottom 'bottom 'bottom)) @@ -466,17 +466,29 @@ [rational (cons 'exact-integer real-pred)] [integer integer-pred] [(uinteger sub-integer) (cons 'bottom integer-pred)] - [(cflonum inexact-number) inexact-pred] + [inexact-number inexact-pred] [exact-number exact-pred] + [$inexactnum inexact-complex-pred] + [$exactnum exact-complex-pred] + [integer integer-pred] + [flinteger flinteger-pred] [number number-pred] [sub-number (cons 'bottom number-pred)] [maybe-number maybe-number-pred] + [port 'port] + [(textual-input-port textual-output-port textual-port + binary-input-port binary-output-port binary-port + input-port output-port file-port) '(bottom . port)] + [(sub-port) '(bottom . normalptr)] + [(maybe-textual-input-port maybe-textual-output-port + maybe-binary-input-port maybe-binary-output-port) (cons false-rec maybe-port-pred)] + [$record '$record] [(record rtd) '(bottom . $record)] ; not sealed [(maybe-rtd) (cons false-rec maybe-$record-pred)] - [(transcoder textual-input-port textual-output-port binary-input-port binary-output-port) '(bottom . $record)] ; opaque - [(maybe-transcoder maybe-textual-input-port maybe-textual-output-port maybe-binary-input-port maybe-binary-output-port input-port output-port) (cons false-rec maybe-$record-pred)] + [(transcoder) '(bottom . $record)] ; opaque, sealed + [(maybe-transcoder) (cons false-rec maybe-$record-pred)] [(rcd sfd timeout) '(bottom . $record)] ; not opaque, sealed [(maybe-rcd maybe-sub-rcd maybe-sfd maybe-timeout) (cons false-rec maybe-$record-pred)] diff --git a/s/cptypes.ss b/s/cptypes.ss index 2ed528530..60044f2e9 100644 --- a/s/cptypes.ss +++ b/s/cptypes.ss @@ -573,7 +573,6 @@ Notes: (cond [(#3%$record? d) '$record] ;check first to avoid double representation of rtd [(okay-to-copy? d) ir] - [(and (integer? d) (exact? d)) 'exact-integer] [(list? d) '$list-pair] ; quoted list should not be modified. [(pair? d) 'pair] [(box? d) 'box] @@ -602,48 +601,6 @@ Notes: [else (if (not extend?) 'bottom '$record)])] [else (if (not extend?) 'bottom '$record)])) - ; Recognize predicates and get the corresponding - ; type using the notation in primdata.ss - ; TODO: Move this info to primdata.ss - (define (primref-name->predicate name) - (case name - [pair? 'pair] - [box? 'box] - [$record? '$record] - [fixnum? 'fixnum] - [bignum? 'bignum] - [ratnum? 'ratnum] - [flonum? 'flonum] - [real? 'real] - [number? 'number] - [vector? 'vector] - [string? 'string] - [bytevector? 'bytevector] - [fxvector? 'fxvector] - [flvector? 'flvector] - [gensym? 'gensym] - [uninterned-symbol? 'uninterned-symbol] - [symbol? 'symbol] - [char? 'char] - [boolean? 'boolean] - [procedure? 'procedure] - [not 'false] - [null? 'null] - [eof-object? 'eof-object] - [bwp-object? 'bwp-object] - [$immediate? '$immediate] - [list? 'list] - [list-assuming-immutable? 'list-assuming-immutable] - [record? 'record] - [record-type-descriptor? 'rtd] - [integer? 'integer] - [rational? 'rational] - [cflonum? 'cflonum] - [else #f])) ; this function is used only to detect predicates. - - (define (primref->predicate pr extend?) - (primref-name/nqm->predicate (primref-name->predicate (primref-name pr)) extend?)) - (define check-constant-is? (case-lambda [(x) @@ -695,6 +652,10 @@ Notes: (let ([rest ($sgetprop (primref-name pr) '*rest-type* #f)]) (primref-name/nqm->predicate rest extend?))]))])))) + (define (primref->predicate pr extend?) + (let ([type ($sgetprop (primref-name pr) '*pred-type* #f)]) + (primref-name/nqm->predicate type extend?))) + (define (primref->unsafe-primref pr) (lookup-primref 3 (primref-name pr))) @@ -1163,76 +1124,6 @@ Notes: (pred-env-add/ref ntypes val (rtd->record-predicate rtd #t) plxc)) #f)]))]) - (define-specialize 2 exact? - [(n) (let ([r (get-type n)]) - (cond - [(predicate-implies? r exact-pred) - (values (make-seq ctxt n true-rec) - true-rec ntypes #f #f)] - [(predicate-disjoint? r exact-pred) - (values (make-seq ctxt n false-rec) - false-rec ntypes #f #f)] - [else - (values `(call ,preinfo ,pr ,n) - ret - ntypes - (pred-env-add/ref ntypes n exact-pred plxc) - (pred-env-add/not/ref ntypes n exact-pred plxc))]))]) - - (define-specialize 2 inexact? - [(n) (let ([r (get-type n)]) - (cond - [(predicate-implies? r inexact-pred) - (values (make-seq ctxt n true-rec) - true-rec ntypes #f #f)] - [(predicate-disjoint? r inexact-pred) - (values (make-seq ctxt n false-rec) - false-rec ntypes #f #f)] - [else - (values `(call ,preinfo ,pr ,n) - ret - ntypes - (pred-env-add/ref ntypes n inexact-pred plxc) - (pred-env-add/not/ref ntypes n inexact-pred plxc))]))]) - - (define-specialize 2 integer? - [(n) (let ([r (get-type n)]) - (cond - [(predicate-implies? r integer-pred) - (values (make-seq ctxt n true-rec) - true-rec ntypes #f #f)] - [(predicate-disjoint? r integer-pred) - (values (make-seq ctxt n false-rec) - false-rec ntypes #f #f)] - [(predicate-implies? r flonum-pred) - (values `(call ,preinfo ,(lookup-primref 3 'flinteger?) ,n) - ret - ntypes - (pred-env-add/ref ntypes n flinteger-pred plxc) - (pred-env-add/not/ref ntypes n flinteger-pred plxc))] - [else - (values `(call ,preinfo ,pr ,n) - ret - ntypes - (pred-env-add/ref ntypes n integer-pred plxc) - (pred-env-add/not/ref ntypes n integer-pred plxc))]))]) - - (define-specialize 2 flinteger? - [(n) (let ([r (get-type n)]) - (cond - [(predicate-implies? r flinteger-pred) - (values (make-seq ctxt n true-rec) - true-rec ntypes #f #f)] - [(predicate-disjoint? r flinteger-pred) - (values (make-seq ctxt n false-rec) - false-rec ntypes #f #f)] - [else - (values `(call ,preinfo ,pr ,n) - ret - ntypes - (pred-env-add/ref ntypes n flinteger-pred plxc) - (pred-env-add/not/ref ntypes n flinteger-pred plxc))]))]) - (define-specialize 2 zero? [(n) (let ([r (get-type n)]) (cond @@ -1440,25 +1331,30 @@ Notes: (with-output-language (Lsrc Expr) (define (fold-predicate preinfo pr e* ret r* ctxt ntypes oldtypes plxc) - ; assume they never raise an error - ; TODO?: Move to a define-specialize - (let ([val (car e*)] - [val-type (car r*)]) + (if (and (eq? (primref-name pr) 'integer?) + (predicate-implies? (car r*) flonum-pred)) + (do-fold-predicate preinfo (lookup-primref 3 'flinteger?) e* ret r* ctxt ntypes oldtypes plxc) + (do-fold-predicate preinfo pr e* ret r* ctxt ntypes oldtypes plxc))) + + (define (do-fold-predicate preinfo pr e* ret r* ctxt ntypes oldtypes plxc) + (let ([e (car e*)] + [r (predicate-intersect (car r*) + (primref->argument-predicate pr 0 1 #t))]) (cond - [(predicate-implies? val-type (primref->predicate pr #f)) - (values (make-seq ctxt val true-rec) + [(predicate-implies? r (primref->predicate pr #f)) + (values (make-seq ctxt `(call ,preinfo ,pr ,e) true-rec) true-rec ntypes #f #f)] - [(predicate-disjoint? val-type (primref->predicate pr #t)) - (values (make-seq ctxt val false-rec) + [(predicate-disjoint? r (primref->predicate pr #t)) + (values (make-seq ctxt `(call ,preinfo ,pr ,e) false-rec) false-rec ntypes #f #f)] [else - (values `(call ,preinfo ,pr ,val) + (values `(call ,preinfo ,pr ,e) ret ntypes (and (eq? ctxt 'test) - (pred-env-add/ref ntypes val (primref->predicate pr #t) plxc)) + (pred-env-add/ref ntypes e (primref->predicate pr #t) plxc)) (and (eq? ctxt 'test) - (pred-env-add/not/ref ntypes val (primref->predicate pr #f) plxc)))]))) + (pred-env-add/not/ref ntypes e (primref->predicate pr #f) plxc)))]))) (define (fold-call/primref preinfo pr e* ctxt oldtypes plxc) (fold-primref/unrestricted preinfo pr e* ctxt oldtypes plxc)) diff --git a/s/primdata.ss b/s/primdata.ss index e4317c6a1..b7e4abd57 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -36,7 +36,7 @@ ) (define-symbol-flags* ([libraries (rnrs) (rnrs arithmetic fixnums)] [flags primitive proc]) - (fixnum? [sig [(ptr) -> (boolean)]] [flags pure unrestricted cp02]) + (fixnum? [sig [(ptr) -> (boolean)]] [pred fixnum] [flags pure unrestricted cp02]) (fixnum-width [sig [() -> (fixnum)]] [flags pure unrestricted true cp02]) (least-fixnum [sig [() -> (fixnum)]] [flags pure unrestricted true cp02]) (greatest-fixnum [sig [() -> (fixnum)]] [flags pure unrestricted true cp02]) @@ -89,14 +89,14 @@ ) (define-symbol-flags* ([libraries (rnrs) (rnrs arithmetic flonums)] [flags primitive proc]) - (flonum? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) + (flonum? [sig [(ptr) -> (boolean)]] [pred flonum] [flags pure unrestricted mifoldable discard]) (real->flonum [sig [(real) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs]) (fl=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments]) ; restricted to 2+ arguments (fl (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments]) ; restricted to 2+ arguments (fl<=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments]) ; restricted to 2+ arguments (fl>? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments]) ; restricted to 2+ arguments (fl>=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments]) ; restricted to 2+ arguments - (flinteger? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs cptypes2]) + (flinteger? [sig [(flonum) -> (boolean)]] [pred flinteger] [flags pure mifoldable discard safeongoodargs]) (flzero? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs cptypes2]) (flpositive? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) (flnegative? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) @@ -183,17 +183,17 @@ (eqv? [sig [(ptr ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard cp02 cptypes2 ieee r5rs]) (eq? [sig [(ptr ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard cp02 cptypes2 ieee r5rs]) (equal? [sig [(ptr ptr) -> (boolean)]] [flags unrestricted mifoldable discard cp02 ieee r5rs]) - (procedure? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs cp02]) - (number? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs]) + (procedure? [sig [(ptr) -> (boolean)]] [pred procedure] [flags pure unrestricted mifoldable discard ieee r5rs cp02]) + (number? [sig [(ptr) -> (boolean)]] [pred number] [flags pure unrestricted mifoldable discard ieee r5rs]) (complex? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs]) - (real? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs]) - (rational? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs]) - (integer? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs cptypes2]) + (real? [sig [(ptr) -> (boolean)]] [pred real] [flags pure unrestricted mifoldable discard ieee r5rs]) + (rational? [sig [(ptr) -> (boolean)]] [pred rational] [flags pure unrestricted mifoldable discard ieee r5rs]) + (integer? [sig [(ptr) -> (boolean)]] [pred integer] [flags pure unrestricted mifoldable discard ieee r5rs]) (real-valued? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (rational-valued? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (integer-valued? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) - (exact? [sig [(number) -> (boolean)]] [flags pure mifoldable discard safeongoodargs cptypes2 ieee r5rs]) - (inexact? [sig [(number) -> (boolean)]] [flags pure mifoldable discard safeongoodargs cptypes2 ieee r5rs]) + (exact? [sig [(number) -> (boolean)]] [pred exact-number] [flags pure mifoldable discard safeongoodargs ieee r5rs]) + (inexact? [sig [(number) -> (boolean)]] [pred inexact-number] [flags pure mifoldable discard safeongoodargs ieee r5rs]) (inexact [sig [(number) -> (inexact-number)]] [flags arith-op mifoldable discard safeongoodargs]) (exact [sig [(number) -> (exact-number)]] [flags arith-op mifoldable discard]) ; no safeongoodargs because it fails with +inf.0 ((r6rs: <) [sig [(real real real ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs cptypes2]) ; restricted to 2+ arguments @@ -250,10 +250,10 @@ (angle [sig [(number) -> (real)]] [flags arith-op mifoldable discard ieee r5rs]) ; not safeongoodargs due to 0 ((r6rs: number->string) [sig [(number) (number sub-ufixnum) (number sub-ufixnum sub-ufixnum) -> (string)]] [flags alloc ieee r5rs]) ; radix restricted to 2, 4, 8, 16 ((r6rs: string->number) [sig [(string) (string sub-ufixnum) -> (maybe-number)]] [flags discard ieee r5rs]) ; radix restricted to 2, 4, 8, 16 - (not [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs cp02]) - (boolean? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs]) + (not [sig [(ptr) -> (boolean)]] [pred false] [flags pure unrestricted mifoldable discard ieee r5rs cp02]) + (boolean? [sig [(ptr) -> (boolean)]] [pred boolean] [flags pure unrestricted mifoldable discard ieee r5rs]) (boolean=? [sig [(boolean boolean boolean ...) -> (boolean)]] [flags pure mifoldable discard cp03 safeongoodargs]) - (pair? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs]) + (pair? [sig [(ptr) -> (boolean)]] [pred pair] [flags pure unrestricted mifoldable discard ieee r5rs]) (cons [sig [(ptr ptr) -> (#1=(ptr . ptr))]] [flags unrestricted alloc ieee r5rs]) ; c..r non-alphabetic so marks come before references (car [sig [(#1#) -> (ptr)]] [flags mifoldable discard cp02 safeongoodargs ieee r5rs]) @@ -286,8 +286,8 @@ (cdaddr [sig [(#14#) -> (ptr)]] [flags mifoldable discard ieee r5rs]) (cadddr [sig [(#15=(ptr . #7#)) -> (ptr)]] [flags mifoldable discard ieee r5rs]) (cddddr [sig [(#15#) -> (ptr)]] [flags mifoldable discard ieee r5rs]) - (null? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs]) - (list? [sig [(ptr) -> (boolean)]] [flags unrestricted mifoldable discard ieee r5rs]) + (null? [sig [(ptr) -> (boolean)]] [pred null] [flags pure unrestricted mifoldable discard ieee r5rs]) + (list? [sig [(ptr) -> (boolean)]] [pred list] [flags unrestricted mifoldable discard ieee r5rs]) (list [sig [(ptr ...) -> (list)]] [flags unrestricted alloc cp02 cptypes2 ieee r5rs]) (length [sig [(list) -> (length)]] [flags mifoldable discard true ieee r5rs]) (append [sig [() -> (null)] [(list ... ptr) -> (ptr)]] [flags discard ieee r5rs cp02]) @@ -296,11 +296,11 @@ (list-ref [sig [(pair sub-index) -> (ptr)]] [flags mifoldable discard ieee r5rs cp02]) (map [sig [(procedure list list ...) -> (list)]] [flags cp02 cp03 ieee r5rs true]) (for-each [sig [(procedure list list ...) -> (ptr ...)]] [flags cp02 cp03 ieee r5rs]) - (symbol? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs]) + (symbol? [sig [(ptr) -> (boolean)]] [pred symbol] [flags pure unrestricted mifoldable discard ieee r5rs]) (symbol->string [sig [(symbol) -> (string)]] [flags true mifoldable discard safeongoodargs ieee r5rs]) (symbol=? [sig [(symbol symbol symbol ...) -> (boolean)]] [flags pure mifoldable discard cp03 safeongoodargs]) (string->symbol [sig [(string) -> (interned-symbol)]] [flags true mifoldable discard safeongoodargs ieee r5rs]) - (char? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs]) + (char? [sig [(ptr) -> (boolean)]] [pred char] [flags pure unrestricted mifoldable discard ieee r5rs]) (char->integer [sig [(char) -> (fixnum)]] [flags pure mifoldable discard safeongoodargs true ieee r5rs]) (integer->char [sig [(sub-ufixnum) -> (char)]] [flags pure mifoldable discard true ieee r5rs]) ((r6rs: char<=?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments @@ -308,7 +308,7 @@ ((r6rs: char=?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs cp03]) ; restricted to 2+ arguments ((r6rs: char>=?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments ((r6rs: char>?) [sig [(char char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments - (string? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs]) + (string? [sig [(ptr) -> (boolean)]] [pred string] [flags pure unrestricted mifoldable discard ieee r5rs]) (make-string [sig [(length) (length char) -> (string)]] [flags alloc ieee r5rs]) (string [sig [(char ...) -> (string)]] [flags alloc ieee r5rs cp02 safeongoodargs]) (string-length [sig [(string) -> (length)]] [flags pure true ieee r5rs mifoldable discard safeongoodargs]) @@ -324,7 +324,7 @@ (list->string [sig [(sub-list) -> (string)]] [flags alloc ieee r5rs]) (string-for-each [sig [(procedure string string ...) -> (ptr ...)]] [flags cp03]) (string-copy [sig [(string) -> (string)]] [flags alloc safeongoodargs ieee r5rs]) - (vector? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs]) + (vector? [sig [(ptr) -> (boolean)]] [pred vector] [flags pure unrestricted mifoldable discard ieee r5rs]) (make-vector [sig [(length) (length ptr) -> (vector)]] [flags alloc ieee r5rs]) (vector [sig [(ptr ...) -> (vector)]] [flags unrestricted alloc ieee r5rs cp02]) (vector-length [sig [(vector) -> (length)]] [flags pure true ieee r5rs mifoldable discard safeongoodargs]) @@ -351,7 +351,7 @@ (define-symbol-flags* ([libraries (rnrs) (rnrs bytevectors)] [flags primitive proc]) (native-endianness [sig [() -> (symbol)]] [flags pure unrestricted alloc cp02]) - (bytevector? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) + (bytevector? [sig [(ptr) -> (boolean)]] [pred bytevector] [flags pure unrestricted mifoldable discard]) (make-bytevector [sig [(length) (length u8/s8) -> (bytevector)]] [flags alloc]) (bytevector-length [sig [(bytevector) -> (length)]] [flags true mifoldable discard safeongoodargs]) (bytevector=? [sig [(bytevector bytevector) -> (boolean)]] [flags mifoldable discard cp03 safeongoodargs]) @@ -551,10 +551,10 @@ (define-symbol-flags* ([libraries (rnrs) (rnrs io ports) (rnrs io simple)] [flags primitive proc]) (eof-object [sig [() -> (eof-object)]] [flags pure unrestricted mifoldable discard true]) - (eof-object? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs]) - (input-port? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs]) + (eof-object? [sig [(ptr) -> (boolean)]] [pred eof-object][flags pure unrestricted mifoldable discard ieee r5rs]) + (input-port? [sig [(ptr) -> (boolean)]] [pred input-port] [flags pure unrestricted mifoldable discard ieee r5rs]) ((r6rs: current-input-port) [sig [() -> (textual-input-port)]] [flags ieee r5rs]) - (output-port? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs]) + (output-port? [sig [(ptr) -> (boolean)]] [pred output-port] [flags pure unrestricted mifoldable discard ieee r5rs]) ((r6rs: current-output-port) [sig [() -> (textual-output-port)]] [flags ieee r5rs]) ((r6rs: current-error-port) [sig [() -> (textual-output-port)]] [flags]) ) @@ -577,10 +577,10 @@ (transcoder-error-handling-mode [sig [(transcoder) -> (symbol)]] [flags pure mifoldable discard true]) (bytevector->string [sig [(bytevector transcoder) -> (string)]] [flags alloc]) ; leave off alloc if transcoders can be user-defined (string->bytevector [sig [(string transcoder) -> (bytevector)]] [flags alloc]) ; leave off alloc if transcoders can be user-defined - (port? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) + (port? [sig [(ptr) -> (boolean)]] [pred port] [flags pure unrestricted mifoldable discard]) (port-transcoder [sig [(port) -> (ptr)]] [flags pure mifoldable discard]) - (textual-port? [sig [(port) -> (boolean)]] [flags pure mifoldable discard]) - (binary-port? [sig [(port) -> (boolean)]] [flags pure mifoldable discard]) + (textual-port? [sig [(port) -> (boolean)]] [pred textual-port] [flags pure mifoldable discard]) + (binary-port? [sig [(port) -> (boolean)]] [pred binary-port] [flags pure mifoldable discard]) (transcoded-port [sig [(binary-port transcoder) -> (textual-port)]] [flags alloc]) (port-has-port-position? [sig [(port) -> (boolean)]] [flags pure mifoldable discard]) (port-position [sig [(port) -> (ptr)]] [flags]) @@ -756,7 +756,7 @@ (define-symbol-flags* ([libraries (rnrs) (rnrs records procedural)] [flags primitive proc]) (make-record-type-descriptor [sig [(symbol maybe-rtd maybe-symbol ptr ptr vector) -> (rtd)]] [flags pure alloc cp02]) - (record-type-descriptor? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard cp02]) + (record-type-descriptor? [sig [(ptr) -> (boolean)]] [pred rtd] [flags pure unrestricted mifoldable discard cp02]) (make-record-constructor-descriptor [sig [(rtd maybe-sub-rcd maybe-procedure) -> (rcd)]] [flags pure true cp02]) ((r6rs: record-constructor) [sig [(rcd) -> (procedure)]] [flags cp02]) ; user-supplied protocol can do anything (record-predicate [sig [(rtd) -> (procedure)]] [flags pure alloc cp02]) @@ -1153,7 +1153,7 @@ (asinh [sig [(number) -> (number)]] [flags arith-op mifoldable discard]) (atanh [sig [(number) -> (number)]] [flags arith-op mifoldable discard]) (atom? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) - (bignum? [sig [(ptr) -> (boolean)]] [flags pure unrestricted cp02]) + (bignum? [sig [(ptr) -> (boolean)]] [pred bignum] [flags pure unrestricted cp02]) (binary-port-input-buffer [sig [(binary-input-port) -> (bytevector)]] [flags discard]) (binary-port-input-count [sig [(binary-input-port) -> (length)]] [flags discard true]) (binary-port-input-index [sig [(binary-input-port) -> (index)]] [flags discard]) @@ -1165,12 +1165,12 @@ (block-read [sig [(textual-input-port string) (textual-input-port string length) -> (eof/length)]] [flags true]) (block-write [sig [(textual-output-port string) (textual-output-port string length) -> (void)]] [flags true]) (box [sig [(ptr) -> (box)]] [flags unrestricted alloc]) - (box? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) + (box? [sig [(ptr) -> (boolean)]] [pred box] [flags pure unrestricted mifoldable discard]) (box-cas! [sig [(box ptr ptr) -> (boolean)]] [flags cptypes2]) (box-immobile [sig [(ptr) -> (box)]] [flags unrestricted alloc]) (box-immutable [sig [(ptr) -> (box)]] [flags unrestricted alloc]) (break [sig [(ptr ...) -> (ptr ...)]] [flags]) - (bwp-object? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) + (bwp-object? [sig [(ptr) -> (boolean)]] [pred bwp-object] [flags pure unrestricted mifoldable discard]) (bytes-allocated [sig [() -> (uint)] [(ptr) -> (uint)] [(ptr maybe-sub-symbol) -> (uint)]] [flags alloc]) (bytes-deallocated [sig [() -> (uint)]] [flags unrestricted alloc]) (bytes-finalized [sig [() -> (uint)]] [flags unrestricted alloc]) @@ -1215,7 +1215,7 @@ (cfl-imag-part [sig [(cflonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs]) (cfl-magnitude-squared [sig [(cflonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs]) (cfl-real-part [sig [(cflonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs]) - (cflonum? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) + (cflonum? [sig [(ptr) -> (boolean)]] [pred inexact-number] [flags pure unrestricted mifoldable discard]) (char<=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments (char (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments (char=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard cp03 safeongoodargs]) ; not restricted to 2+ arguments @@ -1327,7 +1327,7 @@ (file-length [sig [(sub-port) -> (uint)]] [flags]) (file-modification-time [sig [(pathname) (pathname ptr) -> (time)]] [flags discard]) (file-position [sig [(sub-port) -> (sub-ptr)] [(sub-port sub-ptr) -> (void)]] [flags]) - (file-port? [sig [(port) -> (boolean)]] [flags pure mifoldable discard]) + (file-port? [sig [(port) -> (boolean)]] [pred file-port] [flags pure mifoldable discard]) (port-file-compressed! [sig [(port) -> (void)]] [flags]) (file-regular? [sig [(pathname) (pathname ptr) -> (boolean)]] [flags discard]) (file-symbolic-link? [sig [(pathname) -> (boolean)]] [flags discard]) @@ -1349,7 +1349,7 @@ (flvector-length [sig [(flvector) -> (length)]] [flags pure mifoldable discard true safeongoodargs]) (flvector-ref [sig [(flvector sub-index) -> (flonum)]] [flags mifoldable discard cp02]) (flvector-set! [sig [(flvector sub-index flonum) -> (void)]] [flags true]) - (flvector? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) + (flvector? [sig [(ptr) -> (boolean)]] [pred flvector] [flags pure unrestricted mifoldable discard]) (flush-output-port [sig [() (output-port) -> (void)]] [flags true]) ; not restricted to 1 argument (foreign-entry? [sig [(string) -> (boolean)]] [flags discard]) (foreign-entry [sig [(string) -> (uptr)]] [flags discard true]) @@ -1415,9 +1415,9 @@ (fxvector-length [sig [(fxvector) -> (length)]] [flags pure mifoldable discard true safeongoodargs]) (fxvector-ref [sig [(fxvector sub-index) -> (fixnum)]] [flags mifoldable discard cp02]) (fxvector-set! [sig [(fxvector sub-index fixnum) -> (void)]] [flags true]) - (fxvector? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) + (fxvector? [sig [(ptr) -> (boolean)]] [pred fxvector] [flags pure unrestricted mifoldable discard]) (gensym [sig [() (string) (string string) -> (gensym)]] [flags alloc safeongoodargs]) - (gensym? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) + (gensym? [sig [(ptr) -> (boolean)]] [pred gensym] [flags pure unrestricted mifoldable discard]) (gensym->unique-string [sig [(gensym) -> (string)]] [flags true mifoldable]) ; can't discard ... if we have our hands on it, it must be in the oblist after this (get-bytevector-some! [sig [(binary-input-port bytevector length length) -> (eof/length)]] [flags true]) (get-datum/annotations [sig [(textual-input-port sfd uint) -> (ptr uint)]] [flags]) @@ -1461,7 +1461,7 @@ (list* [sig [(ptr) -> (ptr)] [(ptr ptr ptr ...) -> ((ptr . ptr))]] [flags unrestricted discard cp02]) (list->flvector [sig [(sub-list) -> (flvector)]] [flags alloc]) (list->fxvector [sig [(sub-list) -> (fxvector)]] [flags alloc]) - (list-assuming-immutable? [sig [(ptr) -> (boolean)]] [flags unrestricted mifoldable discard]) + (list-assuming-immutable? [sig [(ptr) -> (boolean)]] [pred list-assuming-immutable] [flags unrestricted mifoldable discard]) (list-copy [sig [(list) -> (list)]] [flags alloc]) (list-head [sig [(sub-ptr sub-index) -> (list)]] [flags alloc]) (literal-identifier=? [sig [(identifier identifier) -> (boolean)]] [flags pure mifoldable discard cp03]) @@ -1624,10 +1624,10 @@ (pseudo-random-generator-next! [sig [(pseudo-random-generator) -> (number)] [(sub-number pseudo-random-generator) -> (number)]] [flags]) (pseudo-random-generator? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (random [sig [(sub-number) -> (number)]] [flags alloc]) - (ratnum? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) + (ratnum? [sig [(ptr) -> (boolean)]] [pred ratnum] [flags pure unrestricted mifoldable discard]) (read-token [sig [() (textual-input-port) (textual-input-port sfd uint) -> (symbol ptr maybe-uint maybe-uint)]] [flags]) (real-time [sig [() -> (uint)]] [flags unrestricted alloc]) - (record? [sig [(ptr) (ptr rtd) -> (boolean)]] [flags pure mifoldable discard cp02 cptypes2]) + (record? [sig [(ptr) (ptr rtd) -> (boolean)]] [pred record] [flags pure mifoldable discard safeongoodargs cp02 cptypes2]) (record-constructor [sig [(sub-ptr) -> (procedure)]] [flags cp02]) ; accepts rtd or rcd (record-constructor-descriptor? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard cp02]) (record-equal-procedure [sig [(record record) -> (maybe-procedure)]] [flags discard]) @@ -1811,7 +1811,7 @@ (unbox [sig [(box) -> (ptr)]] [flags mifoldable discard cp02 safeongoodargs]) (unget-u8 [sig [(binary-input-port eof/u8) -> (void)]] [flags true]) (unget-char [sig [(textual-input-port eof/char) -> (void)]] [flags true]) - (uninterned-symbol? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) + (uninterned-symbol? [sig [(ptr) -> (boolean)]] [pred uninterned-symbol] [flags pure unrestricted mifoldable discard]) (unlock-object [sig [(ptr) -> (void)]] [flags unrestricted true]) (unread-char [sig [(char) (char textual-input-port) -> (void)]] [flags true]) (unregister-guardian [sig [(guardian) -> (list)]] [flags true]) @@ -1957,7 +1957,7 @@ ($event [flags single-valued]) ($event-and-resume [flags]) ($event-and-resume* [flags]) - ($exactnum? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable]) + ($exactnum? [sig [(ptr) -> (boolean)]] [pred $exactnum] [flags pure unrestricted mifoldable]) ($exactnum-imag-part [flags single-valued]) ($exactnum-real-part [flags single-valued]) ($expand/cte/optimize [sig [(ptr) (ptr environment) -> (ptr)]] [flags]) @@ -2181,10 +2181,10 @@ ($hashtable-veclen [flags discard]) ($ht-minlen [flags single-valued discard]) ($ht-veclen [flags single-valued discard]) - ($immediate? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable]) + ($immediate? [sig [(ptr) -> (boolean)]] [pred $immediate] [flags pure unrestricted mifoldable]) ($impoops [flags abort-op]) ($import-library [flags single-valued]) - ($inexactnum? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable]) + ($inexactnum? [sig [(ptr) -> (boolean)]] [pred $inexactnum] [flags pure unrestricted mifoldable]) ($inexactnum-imag-part [flags single-valued]) ($inexactnum-real-part [flags single-valued]) ($insert-profile-src! [flags]) @@ -2331,7 +2331,7 @@ ($recompile-condition? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable]) ($recompile-importer-path [flags single-valued]) ($record [flags single-valued cp02 cptypes2 unrestricted alloc]) ; first arg should be an rtd, but we don't check - ($record? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable]) + ($record? [sig [(ptr) -> (boolean)]] [pred $record] [flags pure unrestricted mifoldable]) ($record-cas! [sig [(record sub-index ptr ptr) -> (boolean)]] [flags single-valued cptypes2]) ($record-equal-procedure [flags single-valued discard]) ($record-hash-procedure [flags single-valued discard]) diff --git a/s/priminfo.ss b/s/priminfo.ss index 19a794d85..97275d29e 100644 --- a/s/priminfo.ss +++ b/s/priminfo.ss @@ -14,11 +14,11 @@ ;;; limitations under the License. (module priminfo (priminfo-unprefixed priminfo-libraries priminfo-mask priminfo-arity primvec get-priminfo - priminfo-arguments-type priminfo-rest-type priminfo-last-type priminfo-result-type) + priminfo-arguments-type priminfo-rest-type priminfo-last-type priminfo-result-type priminfo-pred-type) (define-record-type priminfo (nongenerative) (sealed #t) - (fields unprefixed libraries mask arity arguments-type rest-type last-type result-type)) + (fields unprefixed libraries mask arity arguments-type rest-type last-type result-type pred-type)) (define make-parameterlike box) @@ -200,7 +200,7 @@ ($oops 'prims "unexpected two values of last argument ~s and ~s in signature with ~s" found (car psig*) psignature*)])))) (define put-priminfo! - (lambda (prim unprefixed lib* mask sig*) + (lambda (prim unprefixed lib* mask sig* pred-type) (when (eq-hashtable-contains? prim-db prim) (warningf 'define-symbol-type "extra entry for ~s" prim)) (unless (any-set? (prim-mask (or primitive system keyword system-keyword)) mask) @@ -232,7 +232,8 @@ arguments-type (and arguments-type (parsed-signature->rest-type psig*)) ; if arguments-type is confused, clean rest-type and last-type (and arguments-type (parsed-signature->last-type psig*)) - result-type)))))) + result-type + pred-type)))))) (define-syntax define-symbol-flags* (lambda (x) @@ -254,16 +255,19 @@ [((in ...) ...) #`(((in ...) #,outs) ...)]))) (define do-entry (lambda (x) - (syntax-case x (feature sig flags ->) + (syntax-case x (feature sig flags pred ->) [(prim [feature f] . more) #`(when-feature f #,(do-entry #'(prim . more)))] - [(prim [flags flag ...]) (do-entry #'(prim [sig] [flags flag ...]))] - [(prim [sig [(in ...) ... -> (out ...)] ...] [flags flag ...]) + [(prim [flags flag ...]) (do-entry #'(prim [sig] [pred #f] [flags flag ...]))] + [(prim [pred p] [flags flag ...]) (do-entry #'(prim [sig] [pred p] [flags flag ...]))] + [(prim [sig sigs ...] [flags flag ...]) (do-entry #'(prim [sig sigs ...] [pred #f] [flags flag ...]))] + [(prim [sig [(in ...) ... -> (out ...)] ...] [pred p] [flags flag ...]) (with-syntax ([(unprefixed . prim) (prim-name #'prim)]) (with-syntax ([((((in ...) (out ...)) ...) ...) (map ins-and-outs #'(((in ...) ...) ...) #'((out ...) ...))]) #'(put-priminfo! 'prim 'unprefixed '(lib ...) (prim-mask (or shared-flag ... flag ...)) - '([(in ...) . (out ...)] ... ...))))]))) + '([(in ...) . (out ...)] ... ...) + 'p)))]))) #`(begin #,@(map do-entry #'(entry ...))))]))) (include "primdata.ss") diff --git a/s/primvars.ss b/s/primvars.ss index bc8dd2806..87178e20f 100644 --- a/s/primvars.ss +++ b/s/primvars.ss @@ -17,13 +17,14 @@ (include "primref.ss") (define record-prim! - (lambda (prim unprefixed flags arity arguments-type rest-type last-type result-type) + (lambda (prim unprefixed flags arity arguments-type rest-type last-type result-type pred-type) (unless (eq? unprefixed prim) ($sputprop prim '*unprefixed* unprefixed)) ($sputprop prim '*flags* flags) (when arguments-type ($sputprop prim '*arguments-type* arguments-type)) (when rest-type ($sputprop prim '*rest-type* rest-type)) (when last-type ($sputprop prim '*last-type* last-type)) (when result-type ($sputprop prim '*result-type* result-type)) + (when pred-type ($sputprop prim '*pred-type* pred-type)) (when (any-set? (prim-mask (or primitive system)) flags) ($sputprop prim '*prim2* (make-primref prim flags arity)) ($sputprop prim '*prim3* (make-primref prim (fxlogor flags (prim-mask unsafe)) arity))))) @@ -42,7 +43,8 @@ '#,(datum->syntax #'* (vector-map priminfo-arguments-type v-info)) '#,(datum->syntax #'* (vector-map priminfo-rest-type v-info)) '#,(datum->syntax #'* (vector-map priminfo-last-type v-info)) - '#,(datum->syntax #'* (vector-map priminfo-result-type v-info))))))) + '#,(datum->syntax #'* (vector-map priminfo-result-type v-info)) + '#,(datum->syntax #'* (vector-map priminfo-pred-type v-info))))))) (for-each (lambda (x) (for-each (lambda (key) ($sremprop x key)) '(*prim2* *prim3* *flags* *unprefixed*))) (oblist)) setup)