suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

improve the way '() is treated as a constant

Browse Source 
so it fits in with stronger and whatnot and
the other list contracts
This commit is contained in:
Robby Findler 2014-12-13 14:54:31 -06:00
parent 63f7cf1568
commit c3e92093f6
3 changed files with 19 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/racket-test/tests/racket/contract/stronger.rkt
View File

@ -150,6 +150,8 @@
(or/c (-> string?) (-> integer? integer?) integer?) (or/c (-> string?) (-> integer? integer?) integer?)
(or/c (-> integer? integer?) integer?)) (or/c (-> integer? integer?) integer?))
(ctest #t contract-stronger? (list/c) '())
(ctest #t contract-stronger? (list/c) '())
(ctest #t contract-stronger? (cons/c boolean? integer?) (cons/c boolean? integer?)) (ctest #t contract-stronger? (cons/c boolean? integer?) (cons/c boolean? integer?))
(ctest #f contract-stronger? (cons/c boolean? integer?) (cons/c integer? boolean?)) (ctest #f contract-stronger? (cons/c boolean? integer?) (cons/c integer? boolean?))
(ctest #t contract-stronger? (cons/c number? (listof number?)) (non-empty-listof number?)) (ctest #t contract-stronger? (cons/c number? (listof number?)) (non-empty-listof number?))

11
racket/collects/racket/contract/private/guts.rkt
View File

@ -52,7 +52,7 @@
contract-custom-write-property-proc contract-custom-write-property-proc
(rename-out [contract-custom-write-property-proc custom-write-property-proc]) (rename-out [contract-custom-write-property-proc custom-write-property-proc])
set-listof-any-and-cons/c-anyany!) set-some-basic-contracts!)
(define (contract-custom-write-property-proc stct port display?) (define (contract-custom-write-property-proc stct port display?)
(write-string "#<" port) (write-string "#<" port)
@ -220,9 +220,11 @@
;; bang it in here and use it only after it's been banged in. ;; bang it in here and use it only after it's been banged in.
(define listof-any #f) (define listof-any #f)
(define consc-anyany #f) (define consc-anyany #f)
(define (set-listof-any-and-cons/c-anyany! l p) (define list/c-empty #f)
(define (set-some-basic-contracts! l p mt)
(set! listof-any l) (set! listof-any l)
(set! consc-anyany p)) (set! consc-anyany p)
(set! list/c-empty mt))
(define (coerce-contract/f x [name name-default]) (define (coerce-contract/f x [name name-default])
(define (coerce-simple-value x) (define (coerce-simple-value x)
@ -239,7 +241,8 @@
x x
#f #f
(memq x the-known-good-contracts))])] (memq x the-known-good-contracts))])]
[(or (symbol? x) (boolean? x) (char? x) (null? x) (keyword? x)) [(null? x) list/c-empty]
[(or (symbol? x) (boolean? x) (char? x) (keyword? x))
(make-eq-contract x (make-eq-contract x
(if (name-default? name) (if (name-default? name)
(if (or (null? x) (if (or (null? x)

14
racket/collects/racket/contract/private/misc.rkt
View File

@ -1135,8 +1135,11 @@
(higher-order-list/c ctc-args)])) (higher-order-list/c ctc-args)]))
(define (list/c-name-proc c) (define (list/c-name-proc c)
(apply build-compound-type-name (define args (generic-list/c-args c))
'list/c (generic-list/c-args c))) (cond
[(null? args) ''()]
[else (apply build-compound-type-name 'list/c args)]))
(define ((list/c-first-order c) x) (define ((list/c-first-order c) x)
(and (list? x) (and (list? x)
(= (length x) (length (generic-list/c-args c))) (= (length x) (length (generic-list/c-args c)))
@ -2108,5 +2111,8 @@
[else "th"]))) [else "th"])))
;; this is a hack to work around cyclic linking issues; ;; this is a hack to work around cyclic linking issues;
;; see definition of set-listof-any-and-cons/c-anyany! ;; see definition of set-some-basic-contracts!
(set-listof-any-and-cons/c-anyany! (listof any/c) (cons/c any/c any/c)) (set-some-basic-contracts!
(listof any/c)
(cons/c any/c any/c)
(list/c))