Hi all, here are two patches. The first is for #847 and implements option #7 from Peter's list of possible fixes in that ticket, adding support for distinct boolean types to the scrutinizer. This turned out not to take all that much code, since they're treated very similarly to the number > fixnum/float types it already handled. Along with this are some types.db changes to take advantage of the greater precision, primarily in the result types of procedures that return some value or #f (but never #t), but also for some argument types (like that of `##sys#foreign-pointer-argument` as described in the ticket); hopefully I've gotten them all right.
https://bugs.call-cc.org/ticket/847 The second improves the types.db entries for `pointer-tag`, `string-any`, `string-every`, `make-pathname` and `mutex-lock!`. Cheers, Evan
>From b8c54b1d41dceb628bd5e298facf2c78cc1e334a Mon Sep 17 00:00:00 2001 From: Evan Hanson <[email protected]> Date: Mon, 27 Jan 2014 11:37:37 +1300 Subject: [PATCH 1/2] Add distinct boolean subtypes for true and false Fixes #847. --- NEWS | 2 + manual/Types | 4 +- scrutinizer.scm | 19 ++++++--- tests/typematch-tests.scm | 17 ++++++-- types.db | 96 ++++++++++++++++++++++----------------------- 5 files changed, 80 insertions(+), 58 deletions(-) diff --git a/NEWS b/NEWS index ed114c6..5b04028 100644 --- a/NEWS +++ b/NEWS @@ -27,6 +27,8 @@ - Possible race condition while handling TCP errors has been fixed. - The posix unit will no longer hang upon any error in Windows. - resize-vector no longer crashes when reducing the size of the vector. + - Distinct types for boolean true and false have been added to the + scrutinizer. - Platform support - CHICKEN can now be built on AIX (contributed by Erik Falor) diff --git a/manual/Types b/manual/Types index 7e0aa0b..93cdd0f 100644 --- a/manual/Types +++ b/manual/Types @@ -112,9 +112,10 @@ or {{:}} should follow the syntax given below: <tr><th>BASICTYPE</th><th>meaning</th></tr> <tr><td>{{*}}</td><td>any value</td></tr> <tr><td>{{blob}}</td><td>byte vector</td></tr> -<tr><td>{{boolean}}</td><td>boolean</td></tr> +<tr><td>{{boolean}}</td><td>true or false</td></tr> <tr><td>{{char}}</td><td>character</td></tr> <tr><td>{{eof}}</td><td>end-of-file object</td></tr> +<tr><td>{{false}}</td><td>boolean false</td></tr> <tr><td>{{fixnum}}</td><td>word-sized integer</td></tr> <tr><td>{{float}}</td><td>floating-point number</td></tr> <tr><td>{{list}}</td><td>null or pair</td></tr> @@ -128,6 +129,7 @@ or {{:}} should follow the syntax given below: <tr><td>{{procedure}}</td><td>unspecific procedure</td></tr> <tr><td>{{string}}</td><td>string</td></tr> <tr><td>{{symbol}}</td><td>symbol</td></tr> +<tr><td>{{true}}</td><td>boolean true</td></tr> <tr><td>{{vector}}</td><td>vector</td></tr> </table> diff --git a/scrutinizer.scm b/scrutinizer.scm index 695a757..77d9de2 100644 --- a/scrutinizer.scm +++ b/scrutinizer.scm @@ -68,7 +68,7 @@ ; | (forall (TVAR1 ...) VAL) ; | deprecated ; | (deprecated NAME) -; BASIC = * | string | symbol | char | number | boolean | list | pair | +; BASIC = * | string | symbol | char | number | boolean | true | false | list | pair | ; procedure | vector | null | eof | undefined | input-port | output-port | ; blob | noreturn | pointer | locative | fixnum | float | ; pointer-vector @@ -141,7 +141,8 @@ ((fixnum) 'fixnum) ((flonum) 'flonum) (else 'number))) ; in case... - ((boolean? lit) 'boolean) + ((boolean? lit) + (if lit 'true 'false)) ((null? lit) 'null) ((list? lit) `(list ,@(map constant-result lit))) @@ -207,7 +208,7 @@ ((or) (every always-true1 (cdr t))) ((forall) (always-true1 (third t))) (else #t))) - ((memq t '(* boolean undefined noreturn)) #f) + ((memq t '(* boolean true false undefined noreturn)) #f) (else #t))) (define (always-true t loc x) @@ -1105,6 +1106,12 @@ (match1 t1 (third t2))) ; assumes typeenv has already been extracted ((eq? t1 'noreturn) (not exact)) ((eq? t2 'noreturn) (not exact)) + ((eq? t1 'boolean) + (and (not exact) + (match1 '(or true false) t2))) + ((eq? t2 'boolean) + (and (not exact) + (match1 t1 '(or true false)))) ((eq? t1 'number) (and (not exact) (match1 '(or fixnum float) t2))) @@ -1317,6 +1324,7 @@ (merge-result-types rtypes1 rtypes2)))) #f ts))) + ((lset= eq? '(true false) ts) 'boolean) ((lset= eq? '(fixnum float) ts) 'number) (else (let* ((ts (append-map @@ -1475,6 +1483,7 @@ (else (case t2 ((procedure) (and (pair? t1) (eq? 'procedure (car t1)))) + ((boolean) (memq t1 '(true false))) ((number) (memq t1 '(fixnum float))) ((vector) (test t1 '(vector-of *))) ((list) (test t1 '(list-of *))) @@ -1767,7 +1776,7 @@ ((not (pair? t)) (if (memq t '(* fixnum eof char string symbol float number list vector pair undefined blob input-port output-port pointer locative boolean - pointer-vector null procedure noreturn)) + true false pointer-vector null procedure noreturn)) t (bomb "resolve: can't resolve unknown type-variable" t))) (else @@ -1974,7 +1983,7 @@ (l2 (validate-llist (cdr llist)))) (and l1 l2 (cons l1 l2)))))) (define (validate t #!optional (rec #t)) - (cond ((memq t '(* string symbol char number boolean list pair + (cond ((memq t '(* string symbol char number boolean true false list pair procedure vector null eof undefined input-port output-port blob pointer locative fixnum float pointer-vector deprecated noreturn values)) diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm index b5d9d94..bbd5a3c 100644 --- a/tests/typematch-tests.scm +++ b/tests/typematch-tests.scm @@ -103,7 +103,8 @@ (check "abc" 1.2 string) (check 'abc 1.2 symbol) (check #\x 1.2 char) -(check #t 1.2 boolean) +(check #t #f true) +(check #f #t false) (check (+ 1 2) 'a number) (check '(1) 1.2 (list fixnum)) (check '(a) 1.2 (list symbol)) @@ -126,7 +127,8 @@ (ms "abc" 1.2 string) (ms 'abc 1.2 symbol) (ms #\x 1.2 char) -(ms #t 1.2 boolean) +(ms #t #f true) +(ms #f #t false) (ms '(1) 1.2 (list fixnum)) (ms '(1 . 2) '() pair) (ms + 1.2 procedure) @@ -147,8 +149,8 @@ (define n 1) -(checkp boolean? #t boolean) -(checkp boolean? #f boolean) +(checkp boolean? #t true) +(checkp boolean? #f false) (checkp pair? '(1 . 2) pair) (checkp null? '() null) (checkp symbol? 'a symbol) @@ -248,6 +250,13 @@ (float 'float) (number 'number)))) +(assert + (eq? 'boolean + (compiler-typecase (vector-ref '#(#t #f) x) + (true 'true) + (false 'false) + (boolean 'boolean)))) + (mx float (vector-ref '#(1 2 3.4) 2)) (mx fixnum (vector-ref '#(1 2 3.4) 0)) (mx float (##sys#vector-ref '#(1 2 3.4) 2)) diff --git a/types.db b/types.db index d1aaa06..af13b12 100644 --- a/types.db +++ b/types.db @@ -172,27 +172,27 @@ (reverse (forall (a) (#(procedure #:clean #:enforce) reverse ((list-of a)) (list-of a)))) -(memq (forall (a b) (#(procedure #:clean) memq (a (list-of b)) (or boolean (list-of b)))) +(memq (forall (a b) (#(procedure #:clean) memq (a (list-of b)) (or false (list-of b)))) ((* list) (##core#inline "C_u_i_memq" #(1) #(2)))) -(memv (forall (a b) (#(procedure #:clean) memv (a (list-of b)) (or boolean (list-of b)))) +(memv (forall (a b) (#(procedure #:clean) memv (a (list-of b)) (or false (list-of b)))) (((or symbol procedure immediate) list) (##core#inline "C_u_i_memq" #(1) #(2)))) (member (forall (a b) (#(procedure #:clean) member (a (list-of b) #!optional (procedure (b a) *)) ; sic - (or boolean (list-of b)))) + (or false (list-of b)))) (((or symbol procedure immediate) list) (##core#inline "C_u_i_memq" #(1) #(2))) ((* (list-of (or symbol procedure immediate))) (##core#inline "C_u_i_memq" #(1) #(2)))) (assq (forall (a b) (#(procedure #:clean) assq (* (list-of (pair a b))) - (or boolean (pair a b)))) + (or false (pair a b)))) ((* (list-of pair)) (##core#inline "C_u_i_assq" #(1) #(2)))) (assv (forall (a b) (#(procedure #:clean) assv (* (list-of (pair a b))) - (or boolean (pair a b)))) + (or false (pair a b)))) (((or symbol immediate procedure) (list-of pair)) (##core#inline "C_u_i_assq" #(1) #(2))) ((* (list-of (pair (or symbol procedure immediate) *))) @@ -200,7 +200,7 @@ (assoc (forall (a b c) (#(procedure #:clean) assoc (a (list-of (pair b c)) #!optional (procedure (b a) *)) ; sic - (or boolean (pair b c)))) + (or false (pair b c)))) (((or symbol procedure immediate) (list-of pair)) (##core#inline "C_u_i_assq" #(1) #(2))) ((* (list-of (pair (or symbol procedure immediate) *))) @@ -493,7 +493,7 @@ ((fixnum) (##sys#fixnum->string #(1)))) (string->number (#(procedure #:clean #:enforce) string->number (string #!optional fixnum) - (or number boolean))) + (or number false))) (char? (#(procedure #:pure #:predicate char) char? (*) boolean)) @@ -815,8 +815,8 @@ (extension-information (#(procedure #:clean) extension-information (symbol) *)) (feature? (#(procedure #:clean) feature? (#!rest symbol) boolean)) (features (#(procedure #:clean) features () (list-of symbol))) -(file-exists? (#(procedure #:clean #:enforce) file-exists? (string) (or boolean string))) -(directory-exists? (#(procedure #:clean #:enforce) directory-exists? (string) (or boolean string))) +(file-exists? (#(procedure #:clean #:enforce) file-exists? (string) (or false string))) +(directory-exists? (#(procedure #:clean #:enforce) directory-exists? (string) (or false string))) (finite? (#(procedure #:clean #:enforce) finite? (number) boolean) ((fixnum) (let ((#(tmp) #(1))) '#t)) @@ -1049,7 +1049,7 @@ (set-parameterized-read-syntax! (#(procedure #:clean #:enforce) set-parameterized-read-syntax! - (char (or boolean (procedure (input-port fixnum) . *))) + (char (or false (procedure (input-port fixnum) . *))) undefined)) (set-port-name! (#(procedure #:clean #:enforce) set-port-name! (port string) undefined) @@ -1057,12 +1057,12 @@ (set-read-syntax! (#(procedure #:clean #:enforce) set-read-syntax! - (char (or boolean (procedure (input-port) . *))) + (char (or false (procedure (input-port) . *))) undefined)) (set-sharp-read-syntax! (#(procedure #:clean #:enforce) set-sharp-read-syntax! - (char (or boolean (procedure (input-port) . *))) undefined)) + (char (or false (procedure (input-port) . *))) undefined)) (setter (#(procedure #:clean #:enforce) setter (procedure) procedure)) (signal (procedure signal (*) . *)) @@ -1110,7 +1110,7 @@ ((string) #(1))) (##sys#foreign-symbol-argument (#(procedure #:clean #:enforce) ##sys#foreign-symbol-argument (symbol) symbol) ((symbol) #(1))) -(##sys#foreign-pointer-argument (#(procedure #:clean #:enforce) ##sys#foreign-pointer-argument (pointer) pointer) +(##sys#foreign-pointer-argument (#(procedure #:clean #:enforce) ##sys#foreign-pointer-argument ((or pointer false)) pointer) ((pointer) #(1))) (##sys#check-blob (#(procedure #:clean #:enforce) ##sys#check-blob (blob #!optional *) *) @@ -1274,11 +1274,11 @@ (string-translate* (#(procedure #:clean #:enforce) string-translate* (string (list-of (pair string string))) string)) (substring-ci=? (#(procedure #:clean #:enforce) substring-ci=? (string string #!optional fixnum fixnum fixnum) boolean)) -(substring-index (#(procedure #:clean #:enforce) substring-index (string string #!optional fixnum) (or boolean fixnum)) +(substring-index (#(procedure #:clean #:enforce) substring-index (string string #!optional fixnum) (or false fixnum)) ((* *) (##sys#substring-index #(1) #(2) '0)) ((* * *) (##sys#substring-index #(1) #(2) #(3)))) -(substring-index-ci (#(procedure #:clean #:enforce) substring-index-ci (string string #!optional fixnum) (or boolean fixnum)) +(substring-index-ci (#(procedure #:clean #:enforce) substring-index-ci (string string #!optional fixnum) (or false fixnum)) ((* *) (##sys#substring-index-ci #(1) #(2) '0)) ((* * *) (##sys#substring-index-ci #(1) #(2) #(3)))) @@ -1299,7 +1299,7 @@ (read-buffered (#(procedure #:enforce) read-buffered (#!optional input-port) string)) (read-byte (#(procedure #:enforce) read-byte (#!optional input-port) *)) (read-file (#(procedure #:enforce) read-file (#!optional (or input-port string) (procedure (input-port) *) fixnum) list)) -(read-line (#(procedure #:enforce) read-line (#!optional input-port (or boolean fixnum)) (or eof string))) +(read-line (#(procedure #:enforce) read-line (#!optional input-port (or false fixnum)) (or eof string))) (read-lines (#(procedure #:enforce) read-lines (#!optional (or input-port string) fixnum) (list-of string))) (read-string (#(procedure #:enforce) read-string (#!optional * input-port) string)) (read-string! (#(procedure #:enforce) read-string! (fixnum string #!optional input-port fixnum) fixnum)) @@ -1315,7 +1315,7 @@ (delete-file* (#(procedure #:clean #:enforce) delete-file* (string) *)) (file-copy (#(procedure #:clean #:enforce) file-copy (string string #!optional * fixnum) fixnum)) (file-move (#(procedure #:clean #:enforce) file-move (string string #!optional * fixnum) fixnum)) -(make-pathname (#(procedure #:clean #:enforce) make-pathname (* #!optional (or string boolean) (or string boolean)) string)) +(make-pathname (#(procedure #:clean #:enforce) make-pathname (* #!optional (or string false) (or string false)) string)) (directory-null? (#(procedure #:clean #:enforce) directory-null? (string) boolean)) (make-absolute-pathname (#(procedure #:clean #:enforce) make-absolute-pathname (* #!optional string string) string)) (create-temporary-directory (#(procedure #:clean #:enforce) create-temporary-directory () string)) @@ -1345,15 +1345,15 @@ ;; the car of each list is a number (for init-state), false or an alist; ;; the cdr is a list of alists, which contains a char (or vector) and two alists ;; These alists have types themselves, of course... -(irregex-dfa (#(procedure #:clean #:enforce) irregex-dfa ((struct regexp)) (or boolean vector)) +(irregex-dfa (#(procedure #:clean #:enforce) irregex-dfa ((struct regexp)) (or false vector)) (((struct regexp)) (##sys#slot #(1) '1))) -(irregex-dfa/search (#(procedure #:clean #:enforce) irregex-dfa/search ((struct regexp)) (or boolean vector)) +(irregex-dfa/search (#(procedure #:clean #:enforce) irregex-dfa/search ((struct regexp)) (or false vector)) (((struct regexp)) (##sys#slot #(1) '2))) ;; Procedure type returned by irregex-nfa is a matcher type (it is misnamed) ;; which is another complex procedure type. -(irregex-nfa (#(procedure #:clean #:enforce) irregex-nfa ((struct regexp)) (or boolean procedure)) +(irregex-nfa (#(procedure #:clean #:enforce) irregex-nfa ((struct regexp)) (or false procedure)) (((struct regexp)) (##sys#slot #(1) '3))) (irregex-flags (#(procedure #:clean #:enforce) irregex-flags ((struct regexp)) fixnum) @@ -1364,7 +1364,7 @@ (((struct regexp)) (##sys#slot #(1) '5))) (irregex-lengths (#(procedure #:clean #:enforce) irregex-lengths ((struct regexp)) - (vector-of (or boolean pair))) + (vector-of (or false pair))) (((struct regexp)) (##sys#slot #(1) '6))) ;; XXX: Submatch names ought to be symbols according to the docs, but this is @@ -1393,11 +1393,11 @@ ((* string fixnum fixnum) (and (irregex-match #(1) #(2) #(3) #(4)) '#t))) ;; These two return #f or a match object (irregex-match (#(procedure #:clean #:enforce) irregex-match (* string #!optional fixnum fixnum) - (or boolean (struct regexp-match)))) + (or false (struct regexp-match)))) ;; XXX chunker is a plain vector ;; Not marked clean because we don't know what chunker procedures will do (irregex-match/chunked (#(procedure #:enforce) irregex-match/chunked (* vector * #!optional fixnum) - (or boolean (struct regexp-match)))) + (or false (struct regexp-match)))) (irregex-match-data? (#(procedure #:pure #:predicate (struct regexp-match)) irregex-match-data? (*) boolean)) @@ -1426,12 +1426,12 @@ ;; These return #f or a match object (irregex-search (#(procedure #:clean #:enforce) irregex-search (* string #!optional fixnum fixnum) - (or boolean (struct regexp-match)))) + (or false (struct regexp-match)))) ;; XXX chunker is a plain vector (irregex-search/chunked (#(procedure #:enforce) irregex-search/chunked (* vector * #!optional fixnum *) - (or boolean (struct regexp-match)))) + (or false (struct regexp-match)))) (irregex-search/matches (#(procedure #:enforce) irregex-search/matches (* vector * * fixnum (struct regexp-match)) - (or boolean (struct regexp-match)))) + (or false (struct regexp-match)))) (irregex-match-valid-index? (#(procedure #:clean #:enforce) irregex-match-valid-index? ((struct regexp-match) *) boolean)) @@ -1464,7 +1464,7 @@ ((or number pointer locative procedure port)) (or pointer number))) -(allocate (#(procedure #:clean #:enforce) allocate (fixnum) (or boolean pointer))) +(allocate (#(procedure #:clean #:enforce) allocate (fixnum) (or false pointer))) (block-ref (#(procedure #:clean #:enforce) block-ref (* fixnum) *)) (block-set! (#(procedure #:enforce) block-set! (* fixnum *) *)) (extend-procedure (#(procedure #:clean #:enforce) extend-procedure (procedure *) procedure)) @@ -1475,7 +1475,7 @@ (locative-set! (#(procedure #:enforce) locative-set! (locative *) *)) (locative? (#(procedure #:pure #:predicate locative) locative? (*) boolean)) (make-locative (#(procedure #:clean #:enforce) make-locative (* #!optional fixnum) locative)) -(make-pointer-vector (#(procedure #:clean #:enforce) make-pointer-vector (fixnum #!optional pointer) pointer-vector)) +(make-pointer-vector (#(procedure #:clean #:enforce) make-pointer-vector (fixnum #!optional (or pointer false)) pointer-vector)) (make-record-instance (#(procedure #:clean) make-record-instance (symbol #!rest) *)) (make-weak-locative (#(procedure #:clean #:enforce) make-weak-locative (* #!optional fixnum) locative)) @@ -1534,13 +1534,13 @@ (pointer-vector? (#(procedure #:pure #:predicate pointer-vector) pointer-vector? (*) boolean)) -(pointer-vector-fill! (#(procedure #:clean #:enforce) pointer-vector-fill! (pointer-vector pointer) undefined)) +(pointer-vector-fill! (#(procedure #:clean #:enforce) pointer-vector-fill! (pointer-vector (or pointer false)) undefined)) (pointer-vector-length (#(procedure #:clean #:enforce) pointer-vector-length (pointer-vector) fixnum) ((pointer-vector) (##sys#slot #(1) '1))) -(pointer-vector-ref (#(procedure #:clean #:enforce) pointer-vector-ref (pointer-vector fixnum) pointer)) -(pointer-vector-set! (#(procedure #:clean #:enforce) pointer-vector-set! (pointer-vector fixnum pointer) undefined)) +(pointer-vector-ref (#(procedure #:clean #:enforce) pointer-vector-ref (pointer-vector fixnum) (or pointer false))) +(pointer-vector-set! (#(procedure #:clean #:enforce) pointer-vector-set! (pointer-vector fixnum (or pointer false)) undefined)) (pointer-s16-ref (#(procedure #:clean #:enforce) pointer-s16-ref (pointer) fixnum)) (pointer-s16-set! (#(procedure #:clean #:enforce) pointer-s16-set! (pointer fixnum) undefined)) (pointer-s32-ref (#(procedure #:clean #:enforce) pointer-s32-ref (pointer) number)) @@ -1548,7 +1548,7 @@ (pointer-s8-ref (#(procedure #:clean #:enforce) pointer-s8-ref (pointer) fixnum)) (pointer-s8-set! (#(procedure #:clean #:enforce) pointer-s8-set! (pointer fixnum) undefined)) -(pointer-tag (#(procedure #:clean #:enforce) pointer-tag ((or pointer locative procedure port)) (or boolean number)) +(pointer-tag (#(procedure #:clean #:enforce) pointer-tag ((or pointer locative procedure port)) (or false number)) (((or locative procedure port)) (let ((#(tmp) #(1))) '#f))) (pointer-u16-ref (#(procedure #:clean #:enforce) pointer-u16-ref (pointer) fixnum)) @@ -1698,7 +1698,7 @@ (file-position (#(procedure #:clean #:enforce) file-position ((or port fixnum)) fixnum)) (file-read (#(procedure #:clean #:enforce) file-read (fixnum fixnum #!optional *) list)) (file-read-access? (#(procedure #:clean #:enforce) file-read-access? (string) boolean)) -(file-select (#(procedure #:clean #:enforce) file-select ((or (list-of fixnum) fixnum boolean) (or (list-of fixnum) fixnum boolean) #!optional fixnum) * *)) +(file-select (#(procedure #:clean #:enforce) file-select ((or (list-of fixnum) fixnum false) (or (list-of fixnum) fixnum false) #!optional fixnum) * *)) (file-size (#(procedure #:clean #:enforce) file-size ((or string fixnum)) number)) (file-stat (#(procedure #:clean #:enforce) file-stat ((or string fixnum) #!optional *) (vector-of number))) (file-test-lock (#(procedure #:clean #:enforce) file-test-lock (port #!optional fixnum *) boolean)) @@ -1769,7 +1769,7 @@ (process-execute (#(procedure #:clean #:enforce) process-execute (string #!optional (list-of string) (list-of string)) noreturn)) -(process-fork (#(procedure #:enforce) process-fork (#!optional (or (procedure () . *) boolean) *) fixnum)) +(process-fork (#(procedure #:enforce) process-fork (#!optional (or (procedure () . *) false) *) fixnum)) (process-group-id (#(procedure #:clean #:enforce) process-group-id () fixnum)) (process-run (#(procedure #:clean #:enforce) process-run (string #!optional (list-of string)) fixnum)) @@ -1792,10 +1792,10 @@ (set-file-position! (#(procedure #:clean #:enforce) set-file-position! ((or port fixnum) fixnum #!optional fixnum) undefined)) (set-groups! (#(procedure #:clean #:enforce) set-groups! ((list-of fixnum)) undefined)) (set-root-directory! (#(procedure #:clean #:enforce) set-root-directory! (string) undefined)) -(set-signal-handler! (#(procedure #:clean #:enforce) set-signal-handler! (fixnum (or boolean (procedure (fixnum) . *))) undefined)) +(set-signal-handler! (#(procedure #:clean #:enforce) set-signal-handler! (fixnum (or false (procedure (fixnum) . *))) undefined)) (set-signal-mask! (#(procedure #:clean #:enforce) set-signal-mask! ((list-of fixnum)) undefined)) (setenv (#(procedure #:clean #:enforce) setenv (string string) undefined)) -(signal-handler (#(procedure #:clean #:enforce) signal-handler (fixnum) (or boolean (procedure (fixnum) . *)))) +(signal-handler (#(procedure #:clean #:enforce) signal-handler (fixnum) (or false (procedure (fixnum) . *)))) (signal-mask (#(procedure #:clean) signal-mask () fixnum)) (signal-mask! (#(procedure #:clean #:enforce) signal-mask! (fixnum) undefined)) (signal-masked? (#(procedure #:clean #:enforce) signal-masked? (fixnum) boolean)) @@ -2103,8 +2103,8 @@ (string-concatenate-reverse (#(procedure #:clean #:enforce) string-concatenate-reverse ((list-of string) #!optional string fixnum) string)) (string-concatenate-reverse/shared (#(procedure #:clean #:enforce) string-concatenate-reverse/shared ((list-of string) #!optional string fixnum) string)) (string-concatenate/shared (#(procedure #:clean #:enforce) string-concatenate/shared ((list-of string)) string)) -(string-contains (#(procedure #:clean #:enforce) string-contains (string string #!optional fixnum fixnum fixnum fixnum) (or fixnum boolean))) -(string-contains-ci (#(procedure #:clean #:enforce) string-contains-ci (string string #!optional fixnum fixnum fixnum fixnum) (or fixnum boolean))) +(string-contains (#(procedure #:clean #:enforce) string-contains (string string #!optional fixnum fixnum fixnum fixnum) (or fixnum false))) +(string-contains-ci (#(procedure #:clean #:enforce) string-contains-ci (string string #!optional fixnum fixnum fixnum fixnum) (or fixnum false))) (string-copy (#(procedure #:clean #:enforce) string-copy (string #!optional fixnum fixnum) string)) (string-copy! (#(procedure #:clean #:enforce) string-copy! (string fixnum string #!optional fixnum fixnum) undefined)) (string-count (#(procedure #:clean #:enforce) string-count (string * #!optional fixnum fixnum) fixnum)) @@ -2138,13 +2138,13 @@ (#(procedure #:enforce) string-index (string (or char (struct char-set) (procedure (char) *)) #!optional fixnum fixnum) - (or fixnum boolean))) + (or fixnum false))) (string-index-right (#(procedure #:enforce) string-index-right (string (or char (struct char-set) (procedure (char) *)) #!optional fixnum fixnum) - (or fixnum boolean))) + (or fixnum false))) (string-join (#(procedure #:clean #:enforce) string-join (list #!optional string symbol) string)) (string-kmp-partial-search (#(procedure #:enforce) string-kmp-partial-search (string vector string fixnum #!optional (procedure (char char) *) fixnum fixnum fixnum) fixnum)) @@ -2170,13 +2170,13 @@ (#(procedure #:enforce) string-skip (string (or char (struct char-set) (procedure (char) *)) #!optional fixnum fixnum) - (or fixnum boolean))) + (or fixnum false))) (string-skip-right (#(procedure #:enforce) string-skip-right (string (or char (struct char-set) (procedure (char) *)) #!optional fixnum fixnum) - (or fixnum boolean))) + (or fixnum false))) (string-suffix-ci? (#(procedure #:clean #:enforce) string-suffix-ci? (string string #!optional fixnum fixnum fixnum fixnum) boolean)) (string-suffix-length (#(procedure #:clean #:enforce) string-suffix-length (string string #!optional fixnum fixnum fixnum fixnum) fixnum)) @@ -2336,7 +2336,7 @@ (make-condition-variable (#(procedure #:clean) make-condition-variable (#!optional *) (struct condition-variable))) (make-mutex (#(procedure #:clean) make-mutex (#!optional *) (struct mutex))) (make-thread (#(procedure #:clean #:enforce) make-thread ((procedure () . *) #!optional *) (struct thread))) -(mutex-lock! (#(procedure #:clean #:enforce) mutex-lock! ((struct mutex) #!optional * (or boolean (struct thread))) boolean)) +(mutex-lock! (#(procedure #:clean #:enforce) mutex-lock! ((struct mutex) #!optional * (or false (struct thread))) boolean)) (mutex-name (#(procedure #:clean #:enforce) mutex-name ((struct mutex)) *) (((struct mutex)) (##sys#slot #(1) '1))) @@ -2624,12 +2624,12 @@ (tcp-abandon-port (#(procedure #:clean #:enforce) tcp-abandon-port (port) undefined)) (tcp-accept (#(procedure #:clean #:enforce) tcp-accept ((struct tcp-listener)) input-port output-port)) (tcp-accept-ready? (#(procedure #:clean #:enforce) tcp-accept-ready? ((struct tcp-listener)) boolean)) -(tcp-accept-timeout (#(procedure #:clean #:enforce) tcp-accept-timeout (#!optional (or boolean number)) (or boolean number))) +(tcp-accept-timeout (#(procedure #:clean #:enforce) tcp-accept-timeout (#!optional (or false number)) (or false number))) (tcp-addresses (#(procedure #:clean #:enforce) tcp-addresses (port) string string)) (tcp-buffer-size (#(procedure #:clean #:enforce) tcp-buffer-size (#!optional fixnum) fixnum)) (tcp-close (#(procedure #:clean #:enforce) tcp-close ((struct tcp-listener)) undefined)) (tcp-connect (#(procedure #:clean #:enforce) tcp-connect (string #!optional fixnum) input-port output-port)) -(tcp-connect-timeout (#(procedure #:clean #:enforce) tcp-connect-timeout (#!optional (or boolean number)) (or boolean number))) +(tcp-connect-timeout (#(procedure #:clean #:enforce) tcp-connect-timeout (#!optional (or false number)) (or false number))) (tcp-listen (#(procedure #:clean #:enforce) tcp-listen (fixnum #!optional fixnum *) (struct tcp-listener))) (tcp-listener-fileno (#(procedure #:clean #:enforce) tcp-listener-fileno ((struct tcp-listener)) fixnum) @@ -2640,8 +2640,8 @@ (tcp-listener? (#(procedure #:clean #:predicate (struct tcp-listener)) tcp-listener? (*) boolean)) (tcp-port-numbers (#(procedure #:clean #:enforce) tcp-port-numbers (port) fixnum fixnum)) -(tcp-read-timeout (#(procedure #:clean #:enforce) tcp-read-timeout (#!optional (or boolean number)) (or boolean number))) -(tcp-write-timeout (#(procedure #:clean #:enforce) tcp-write-timeout (#!optional (or boolean number)) (or boolean number))) +(tcp-read-timeout (#(procedure #:clean #:enforce) tcp-read-timeout (#!optional (or false number)) (or false number))) +(tcp-write-timeout (#(procedure #:clean #:enforce) tcp-write-timeout (#!optional (or false number)) (or false number))) ;; utils @@ -2649,7 +2649,7 @@ (read-all (#(procedure #:enforce) read-all (#!optional (or input-port string)) string)) (system* (#(procedure #:clean #:enforce) system* (string #!rest) undefined)) (qs (#(procedure #:clean #:enforce) qs (string) string)) -(compile-file (#(procedure #:clean #:enforce) compile-file (string #!rest) (or boolean string))) +(compile-file (#(procedure #:clean #:enforce) compile-file (string #!rest) (or false string))) (compile-file-options (#(procedure #:clean #:enforce) compile-file-options (#!optional (list-of string)) (list-of string))) (scan-input-lines (#(procedure #:enforce) scan-input-lines (* #!optional input-port) *)) (yes-or-no? (#(procedure #:enforce) yes-or-no? (string #!rest) *)) -- 1.7.10.4
>From 069b1fc0985ee61473f84fb90591d1ef589fe030 Mon Sep 17 00:00:00 2001 From: Evan Hanson <[email protected]> Date: Thu, 30 Jan 2014 20:23:11 +1300 Subject: [PATCH 2/2] types.db signature improvements - pointer-tag (result may be any Scheme object) - string-any, string-every (polymorphic result when predicate is a procedure) - make-pathname (specify allowed types for directory argument) - mutex-lock! (specify allowed types for timeout argument) --- types.db | 24 +++++++++++++----------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/types.db b/types.db index af13b12..ab012d2 100644 --- a/types.db +++ b/types.db @@ -1315,7 +1315,7 @@ (delete-file* (#(procedure #:clean #:enforce) delete-file* (string) *)) (file-copy (#(procedure #:clean #:enforce) file-copy (string string #!optional * fixnum) fixnum)) (file-move (#(procedure #:clean #:enforce) file-move (string string #!optional * fixnum) fixnum)) -(make-pathname (#(procedure #:clean #:enforce) make-pathname (* #!optional (or string false) (or string false)) string)) +(make-pathname (#(procedure #:clean #:enforce) make-pathname ((or string (list-of string) false) #!optional (or string false) (or string false)) string)) (directory-null? (#(procedure #:clean #:enforce) directory-null? (string) boolean)) (make-absolute-pathname (#(procedure #:clean #:enforce) make-absolute-pathname (* #!optional string string) string)) (create-temporary-directory (#(procedure #:clean #:enforce) create-temporary-directory () string)) @@ -1548,7 +1548,7 @@ (pointer-s8-ref (#(procedure #:clean #:enforce) pointer-s8-ref (pointer) fixnum)) (pointer-s8-set! (#(procedure #:clean #:enforce) pointer-s8-set! (pointer fixnum) undefined)) -(pointer-tag (#(procedure #:clean #:enforce) pointer-tag ((or pointer locative procedure port)) (or false number)) +(pointer-tag (#(procedure #:clean #:enforce) pointer-tag ((or pointer locative procedure port)) *) (((or locative procedure port)) (let ((#(tmp) #(1))) '#f))) (pointer-u16-ref (#(procedure #:clean #:enforce) pointer-u16-ref (pointer) fixnum)) @@ -2071,10 +2071,11 @@ (make-kmp-restart-vector (#(procedure #:clean #:enforce) make-kmp-restart-vector (string #!optional (procedure (* *) *) fixnum fixnum) vector)) (string-any - (#(procedure #:enforce) - string-any - ((or char (struct char-set) (procedure (char) *)) string #!optional fixnum fixnum) - boolean)) + (forall (a) + (#(procedure #:enforce) + string-any + ((or char (struct char-set) (procedure (char) a)) string #!optional fixnum fixnum) + (or boolean a)))) (string-append/shared (#(procedure #:clean #:enforce) string-append/shared (#!rest string) string) ((string string) (##sys#string-append #(1) #(2)))) @@ -2115,10 +2116,11 @@ (string-drop-right (#(procedure #:clean #:enforce) string-drop-right (string fixnum) string)) (string-every - (#(procedure #:enforce) - string-every - ((or char (struct char-set) (procedure (char) *)) string #!optional fixnum fixnum) - boolean)) + (forall (a) + (#(procedure #:enforce) + string-every + ((or char (struct char-set) (procedure (char) a)) string #!optional fixnum fixnum) + (or boolean a)))) (string-fill! (#(procedure #:clean #:enforce) string-fill! (string char #!optional fixnum fixnum) string)) @@ -2336,7 +2338,7 @@ (make-condition-variable (#(procedure #:clean) make-condition-variable (#!optional *) (struct condition-variable))) (make-mutex (#(procedure #:clean) make-mutex (#!optional *) (struct mutex))) (make-thread (#(procedure #:clean #:enforce) make-thread ((procedure () . *) #!optional *) (struct thread))) -(mutex-lock! (#(procedure #:clean #:enforce) mutex-lock! ((struct mutex) #!optional * (or false (struct thread))) boolean)) +(mutex-lock! (#(procedure #:clean #:enforce) mutex-lock! ((struct mutex) #!optional (or false number (struct time)) (or false (struct thread))) boolean)) (mutex-name (#(procedure #:clean #:enforce) mutex-name ((struct mutex)) *) (((struct mutex)) (##sys#slot #(1) '1))) -- 1.7.10.4
_______________________________________________ Chicken-hackers mailing list [email protected] https://lists.nongnu.org/mailman/listinfo/chicken-hackers
