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

Remove trailing whitespace.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-06-30 12:44:41 -04:00
parent b5e4515752
commit 43efe6adf0
118 changed files with 798 additions and 798 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/tests/typed-scheme/fail/bad-any.rkt
View File

@ -2,7 +2,7 @@
(exn-pred exn:fail:contract?)
#lang scheme/load
(module m typed-scheme
(module m typed-scheme
(: f Any)
(define f (lambda: ([x : Number]) (add1 x)))
(provide f))

2
collects/tests/typed-scheme/fail/cnt-struct-err.rkt
View File

@ -9,7 +9,7 @@
(provide (all-defined-out)))
(module n2 scheme/base
(require 'm scheme/match)
(match my-x
[(struct x (f)) (f #f)]))

6
collects/tests/typed-scheme/fail/duplicate-ann.rkt
View File

@ -1,7 +1,7 @@
#lang scheme/load
(module square typed-scheme
;(provide: [square (Integer -> Integer)])
(provide: [square (Integer -> Integer)])
;(: square (Number -> Number))
@ -10,9 +10,9 @@
)
(module squareclient typed-scheme
(require 'square)
(square 10) ;; 100
(integer? 10.1) ;; #f
(square 10.1) ;; 102.009999...

14
collects/tests/typed-scheme/fail/ht-infer.rkt
View File

@ -1,26 +1,26 @@
#lang scheme/load
(module before typed/scheme
(provide (all-defined-out))
(define-struct: Sigil ())
(: list->english ((Listof String) -> String))
(define (list->english strs) (error 'fail))
(define-type-alias (Set X) (HashTable X '()))
(: empty-set (All (T) (-> (Set T))))
(define (empty-set) (error 'fail))
(: set->list (All (T) ((Set T) -> (Listof T))))
(define (set->list set) (error 'fail))
)
(module after typed/scheme
(require 'before)
(: f ((Set Sigil) -> Any))
(define (f x1)
(let* ([x2 (set->list x1)])

2
collects/tests/typed-scheme/fail/port-to-list.rkt
View File

@ -1,4 +1,4 @@
#lang typed/racket
#lang typed/racket
(car (car
(parameterize ((current-input-port (open-input-string "2")))
((inst port->list (List Number))))))

8
collects/tests/typed-scheme/fail/pr10594.rkt
View File

@ -3,19 +3,19 @@
#lang scheme/load
(module T typed-scheme
(define-struct: [a] thing ([get : a]))
(: thing->string ((thing String) -> String))
(define (thing->string x)
(string-append "foo" (thing-get x)))
(provide (all-defined-out)))
(module U scheme
(require 'T)
(thing->string (make-thing 5)))
(require 'U)

8
collects/tests/typed-scheme/fail/pr11686.rkt
View File

@ -4,18 +4,18 @@
#lang racket/load
(module T typed/racket
(struct: [X] doll ([contents : X]))
(define-type RussianDoll
(Rec RD (U 'center (doll RD))))
(: f (RussianDoll -> RussianDoll))
(define (f rd) rd)
(: md (All (x) (x -> (doll x))))
(define md doll)
(provide (all-defined-out)))
(module U racket

4
collects/tests/typed-scheme/fail/set-tests.rkt
View File

@ -1,8 +1,8 @@
;; should FAIL!
#lang typed-scheme
(let*: ((x : Any 1)
(let*: ((x : Any 1)
(f : (-> Void) (lambda () (set! x (quote foo)))))
(if (number? x) (begin (f) (add1 x)) 12))

12
collects/tests/typed-scheme/fail/undefined.rkt
View File

@ -3,20 +3,20 @@
#lang scheme/load
(module A scheme
(define (f x) (add1 x))
(provide f))
(module B typed/scheme
(require/typed 'A [f (Integer -> Integer)])
(let ()
(: x Integer)
(define x (f x))
(void)))
(require 'B)

12
collects/tests/typed-scheme/main.rkt
View File

@ -29,23 +29,23 @@
(define (cfile file)
((compile-zos #f) (list file) 'auto))
(define (exn-pred p)
(let ([sexp (with-handlers
([exn:fail? (lambda _ #f)])
(call-with-input-file*
p
(lambda (prt)
(lambda (prt)
(read-line prt 'any) (read prt))))])
(match sexp
[(list-rest 'exn-pred e)
(eval `(exn-matches . ,e) (namespace-anchor->namespace a))]
[_
[_
(exn-matches ".*Type Checker.*" exn:fail:syntax?)])))
(define (mk-tests dir loader test)
(lambda ()
(define path (build-path (this-expression-source-directory) dir))
(define path (build-path (this-expression-source-directory) dir))
(define tests
(for/list ([p (directory-list path)]
#:when (scheme-file? p)
@ -64,10 +64,10 @@
(make-test-suite dir tests)))
(define (dr p)
(parameterize ([current-namespace (make-base-empty-namespace)])
(parameterize ([current-namespace (make-base-empty-namespace)])
(dynamic-require `(file ,(if (string? p) p (path->string p))) #f)))
(define succ-tests (mk-tests "succeed"
(define succ-tests (mk-tests "succeed"
dr
(lambda (p thnk) (check-not-exn thnk))))
(define fail-tests (mk-tests "fail"

2
collects/tests/typed-scheme/optimizer/tests/real-part-loop.rkt
View File

@ -28,7 +28,7 @@ TR opt: real-part-loop.rkt 33:17 3.6 -- float-arg-expr in complex ops
(ann
(let loop ([v 0.0+1.0i])
(if (> (real-part v) 70000.2)
(if (> (real-part v) 70000.2)
0
(loop (+ v 3.6))))
Integer)

2
collects/tests/typed-scheme/run.rkt
View File

@ -22,7 +22,7 @@
["--just" path "run only this test" (single (just-one path))]
["--nightly" "for the nightly builds" (begin (nightly? #t) (unit? #t) (opt? #t))]
["--all" "run all tests" (begin (unit? #t) (int? #t) (opt? #t) (missed-opt? #t) (bench? #t))]
["--gui" "run using the gui"
["--gui" "run using the gui"
(if (gui-available?)
(begin (exec go))
(error "GUI not available"))])

2
collects/tests/typed-scheme/succeed/barland.rkt
View File

@ -1,4 +1,4 @@
#lang typed-scheme
#lang typed-scheme
(define-type-alias top Any)
(define-type-alias set (top -> top))

10
collects/tests/typed-scheme/succeed/batched-queue.scm
View File

@ -1,4 +1,4 @@
#lang typed-scheme
#lang typed-scheme
;; CHANGES
;; added annotations on all bound variables and structs
;; require typed foldl
@ -7,7 +7,7 @@
;; added annotation on use of polymorphic functions in higher-order contexts
;; fixme -- how do we require polymorphic functions?
#;(require (only (lib "list.ss") foldl))
#;(require (only (lib "list.ss") foldl))
#;(require (only "typed-list.ss" foldl))
(define-type-alias number Number)
@ -64,11 +64,11 @@
(car (queue-front q)))
(pdefine: (a) (elements: [q : (queue a)]) : (Listof a)
(append (queue-front q)
(append (queue-front q)
(reverse (queue-rear q))))
(pdefine: (a b) (fold [f : (a b -> b)] [init : b] [q : (queue a)]) : b
(foldl f
(foldl f
(foldl f init (queue-front q))
(reverse (queue-rear q))))
@ -77,7 +77,7 @@
(+ (length (queue-front q))
(length (queue-rear q))))
;; 12 definitions checked
;; 12 definitions checked
;; generators removed
;; TESTS

2
collects/tests/typed-scheme/succeed/broken-let-syntax.rkt
View File

@ -1,5 +1,5 @@
#lang typed-scheme
(let: ([x : Number 1])
(let-syntax ([m (syntax-rules ()
[(_) x])])

4
collects/tests/typed-scheme/succeed/cl-tests.rkt
View File

@ -4,13 +4,13 @@
(define-type-alias top Any)
(define: a : (number -> number) (lambda: ([x : number]) x))
(define: f : (case-lambda (number -> number)
(define: f : (case-lambda (number -> number)
(boolean boolean -> boolean))
(case-lambda
[(#{x : number}) (add1 x)]
[(#{a : boolean} #{b : boolean}) (and a b)]))
(define: f* : (case-lambda (number -> number)
(define: f* : (case-lambda (number -> number)
(boolean boolean -> boolean))
(case-lambda:
[([x : number]) (add1 x)]

4
collects/tests/typed-scheme/succeed/even-odd.rkt
View File

@ -12,12 +12,12 @@
(: append-one (case-lambda (EvenParity -> OddParity)
(OddParity -> EvenParity)
(OddParity -> EvenParity)
(Bitstring -> Bitstring)))
(define (append-one l)
(if (null? l)
(make-O '())
(if (Z? l)
(if (Z? l)
(make-Z (append-one (Z-b l)))
(make-O (append-one (O-b l))))))

4
collects/tests/typed-scheme/succeed/exceptions.rkt
View File

@ -11,7 +11,7 @@
(parameterize ((abort k))
body ...))))))
(call-with-exception-handler
(call-with-exception-handler
(lambda (v) (displayln v) ((abort) v))
(lambda ()
(with-abort 2)
@ -31,7 +31,7 @@
(with-abort (raise-syntax-error #f "stx-err" 45))
(with-abort (raise-syntax-error #f "stx-err" 4 5))
(with-abort (raise-syntax-error #f "stx-err" 4 5 (list #'stx)))
(void)
))

2
collects/tests/typed-scheme/succeed/fixnum.rkt
View File

@ -14,7 +14,7 @@
(define (check f a b)
(if (f a b)
#t
(error (format "Check (~a ~a ~a) failed" f a b))))
(error (format "Check (~a ~a ~a) failed" f a b))))
(check = (fx+ 1 2) 3)
(check = (fx- 2 3) -1)

2
collects/tests/typed-scheme/succeed/float-internal-err.rkt
View File

@ -7,6 +7,6 @@
(: tfo-align Any)
(define (tfo-align) 0.0
(let* ((x (FLOAT* 0.0 (FLOATsin 0.))))
0))

2
collects/tests/typed-scheme/succeed/flonum.rkt
View File

@ -9,7 +9,7 @@
(define (check f a b)
(if (f a b)
#t
(error (format "Check (~a ~a ~a) failed" f a b))))
(error (format "Check (~a ~a ~a) failed" f a b))))
(: check-pred (All (a) ((a -> Boolean) a -> Boolean)))
(define (check-pred pred v)

2
collects/tests/typed-scheme/succeed/flvector.rkt
View File

@ -15,7 +15,7 @@
(define (check f a b)
(if (f a b)
#t
(error (format "Check (~a ~a ~a) failed" f a b))))
(error (format "Check (~a ~a ~a) failed" f a b))))
;; Check the FlVector type is exported
(define: v : FlVector (flvector 1. 2. 3.))

2
collects/tests/typed-scheme/succeed/fold-left-inst.rkt
View File

@ -5,7 +5,7 @@
(if (or (null? as)
(ormap null? bss))
c
(apply (inst fold-left c a b ... b) f
(apply (inst fold-left c a b ... b) f
(apply f c (car as) (map car bss))
(cdr as) (map cdr bss))))

16
collects/tests/typed-scheme/succeed/fold-left.rkt
View File

@ -5,7 +5,7 @@
(if (or (null? as)
(ormap null? bss))
c
(apply fold-left f
(apply fold-left f
(apply f c (car as) (map car bss))
(cdr as) (map cdr bss))))
@ -19,21 +19,21 @@
(car as) (map car bss))))
;; Matthias -- tell me why this returns 4.
((plambda: (x ...) [xs : x ... x]
(apply fold-left
((plambda: (x ...) [xs : x ... x]
(apply fold-left
(lambda: ([a : Integer] [b : Integer] . [xs : x ... x])
(+ a b))
3
(list 1 2 3)
3
(list 1 2 3)
(map list xs)))
3 4 5)
((plambda: (x ...) [xs : x ... x]
((plambda: (x ...) [xs : x ... x]
(apply fold-right
(lambda: ([a : Integer] [b : Integer] . [xs : x ... x])
(+ a b))
3
(list 1 2 3)
3
(list 1 2 3)
(map list xs)))
3 4 5)

32
collects/tests/typed-scheme/succeed/foldo.rkt
View File

@ -1,37 +1,37 @@
(module foldo mzscheme
(require (lib "file.ss")(lib "match.ss"))
(provide apply-to-scheme-files)
(define-syntax (define-excluder stx)
(define (path->clause c)
(syntax-case c ()
[(item ...)
#`[`(#,@(reverse (syntax-e #'(item ...))) ,_ (... ...)) #t]]
[item
#`[`(item) #t]]))
(syntax-case stx ()
[(_ name path ...)
(with-syntax ([(match-clause ...) (map path->clause (syntax-e #'(path ...)))])
#`(define (name p )
#`(define (name p )
(let* ([dirnames (map path->string (explode-path p))])
(match (reverse dirnames) ; goofy backwards matching because ... matches greedily
match-clause ...
[_ #f]))))]))
(define-excluder default-excluder
(define-excluder default-excluder
"compiled" ".git")
(define exclude-directory? (make-parameter default-excluder))
;; ----------------------------------------
;; apply-to-scheme-files: (path[file] -> X) path[directory] -> (listof X)
;; applies the given function to each .ss or .scm file in the given directory
;; hierarchy; returns all results in a list
(define (apply-to-scheme-files f root )
;;FOLD-FILES
;;FOLD-FILES
(fold-files
(lambda (path kind acc)
(case kind
@ -42,17 +42,17 @@
[(regexp-match #rx"(rkt|rktl|ss|scm)$" extension)
(let ([resl (f path)])
(if resl
(cons resl acc)
(cons resl acc)
acc ))]
[else acc ]))]
[(dir)
[(dir)
(let* ([p (normalize-path path root)])
(if ((exclude-directory?) p)
(values acc #f)
acc ))]
(values acc #f)
acc ))]
[(link) acc ]
[else (error "never happen")]))
[else (error "never happen")]))
'()
root
))
))
)

22
collects/tests/typed-scheme/succeed/foo.scm
View File

@ -10,7 +10,7 @@
(provide x)
(set! x 4)
(when #t 3))
(module trequire typed-scheme
(require 'bang-tests)
@ -18,31 +18,31 @@
(module require-tests typed-scheme
(provide z)
(require/typed x Number 'm)
(+ x 3)
(require/typed y (Number -> Number) 'm)
(require/typed x Number 'm)
(+ x 3)
(require/typed y (Number -> Number) 'm)
(define: z : Number (y (+ x 4))))
(module provide-type typed-scheme
(define-type-alias top2 Any)
(define-typed-struct (a) container ([v : a]))
(container-v (make-container 3))
(provide top2 container container-v make-container)
)
(module require-type typed-scheme
(require 'provide-type)
(let: ([x : top2 3])
x)
(define: (f [x : (container Number)]) : Number
(container-v x))
(f (make-container (ann 7 : Number)))
)

2
collects/tests/typed-scheme/succeed/hw01.scm
View File

@ -103,7 +103,7 @@
(define (list-length loa)
(list-length-helper loa 0))
|#
;; tests:
(= 0 (list-length '()))
(= 2 (list-length '(1 2)))

2
collects/tests/typed-scheme/succeed/icfp-examples.rkt
View File

@ -23,7 +23,7 @@
(define: y : Any "foo")
(if (and (number? x) (string? y))
(+ x (string-length y))
0)
0)
;; Example 6 has an intentional error
(define: z : (U Number String) 7)

4
collects/tests/typed-scheme/succeed/inst-dots.rkt
View File

@ -2,6 +2,6 @@
(require typed-scheme/base-env/extra-procs)
((inst map Number Number Number Number Number Number Number)
+
((inst map Number Number Number Number Number Number Number)
+
(list 1 2 3) (list 2 3 4) (list 1 2 3) (list 2 3 4) (list 1 2 3) (list 2 3 4))

4
collects/tests/typed-scheme/succeed/kw.rkt
View File

@ -1,7 +1,7 @@
#lang typed-scheme
(lambda ()
(open-input-file "foo" #:mode 'binary)
(lambda ()
(open-input-file "foo" #:mode 'binary)
(open-input-file "foo" #:mode 'text)
(open-input-file "foo"))

114
collects/tests/typed-scheme/succeed/leftist-heap.rkt
View File

@ -33,27 +33,27 @@
(define-type-alias symbol Symbol)
(define-type-alias top Any)
(define-type-alias list-of Listof)
(require
(require
(except-in srfi/67 current-compare =? <?)
#;"typed-list.ss"
#;srfi/42
#;(only mzlib/list foldl))
#;(provide (all-defined))
(provide comparator Heap elements empty fold heap-node? find-min empty? insert insert* delete-min size union)
#;(define-type-alias top top)
(define-type-alias comparator (top top -> number))
;; fixme - type aliases should work in require
(require/typed current-compare (-> (top top -> number)) srfi/67)
(require/typed =? ((top top -> number) top top -> boolean) srfi/67)
(require/typed <? ((top top -> number) top top -> boolean) srfi/67)
;;; DATA DEFINITION
; A HEAP is either
; (make-heap-empty cmp)
; or
@ -62,38 +62,38 @@
; cmp is a compare function,
; rank is an integer, and
; left and right are heaps.
(define-typed-struct heap ([compare : comparator]))
(define-typed-struct (heap-empty heap) ())
(define-typed-struct (a) (heap-node heap)
(define-typed-struct (a) (heap-node heap)
([rank : Real] [elm : a] [left : (Un (heap-node a) heap-empty)] [right : (Un (heap-node a) heap-empty)]))
(define-type-alias (Heap a) (Un (heap-node a) heap-empty))
;;; CORE HEAP OPERATIONS
;; FIXME
(: empty (All (a) (case-lambda (-> (Heap a)) (comparator -> (Heap a)))))
(define empty
(define empty
(case-lambda
[() (make-heap-empty (current-compare))]
[(#{cmp : comparator}) (make-heap-empty cmp)]))
(define: empty? : (pred heap-empty) heap-empty?)
(pdefine: (a) (rank [h : (Heap a)]) : Real
(if (empty? h)
0
(heap-node-rank h)))
(pdefine: (a) (make [x : a] [a : (Heap a)] [b : (Heap a)]) : (Heap a)
(let ([ra (rank a)]
(pdefine: (a) (make [x : a] [a : (Heap a)] [b : (Heap a)]) : (Heap a)
(let ([ra (rank a)]
[rb (rank b)]
[cmp (heap-compare a)])
(if (>= ra rb)
(make-heap-node cmp (add1 rb) x a b)
(make-heap-node cmp (add1 ra) x b a))))
(pdefine: (a) (union [h1 : (Heap a)] [h2 : (Heap a)]) : (Heap a)
(cond
[(empty? h1) h2]
@ -103,23 +103,23 @@
(if<=? ((heap-compare h1) x y)
(make x (heap-node-left h1) (union (heap-node-right h1) h2))
(make y (heap-node-left h2) (union h1 (heap-node-right h2)))))]))
(pdefine: (a) (insert [x : a] [h : (Heap a)]) : (Heap a)
(let: ([cmp : comparator (heap-compare h)])
(union (make-heap-node cmp 1 x (make-heap-empty cmp) (make-heap-empty cmp))
h)))
;; No changes other than variable annotations
(pdefine: (a) (delete [x : a] [h : (Heap a)]) : (Heap a)
(define: (delete/sf [x : a] [h : (Heap a)] [s : ((Heap a) -> (Heap a))] [f : (-> (Heap a))]) : (Heap a)
(cond
[(empty? h)
[(empty? h)
(s h)]
[(=? (heap-compare h) x (heap-node-elm h))
(s (union (heap-node-left h) (heap-node-right h)))]
[(<? (heap-compare h) x (heap-node-elm h))
(f)]
[else
[else
(let ([cmp (heap-compare h)])
(let ([y (heap-node-elm h)]
[l (heap-node-left h)]
@ -129,22 +129,22 @@
(lambda () (delete/sf x r
(lambda: ([h1 : (Heap a)]) (s (make y l h1)))
(lambda () (f)))))))]))
(delete/sf x h
(lambda: ([h1 : (Heap a)]) h1)
(delete/sf x h
(lambda: ([h1 : (Heap a)]) h1)
(lambda () h)))
;; annotated w/ no errors
(pdefine: (a) (delete-all [x : a] [h : (Heap a)]) : (Heap a)
(define: (delete-all/sf [x : a] [h : (Heap a)] [s : ((Heap a) -> (Heap a))] [f : (-> (Heap a))]) : (Heap a)
(cond
[(empty? h)
[(empty? h)
(s h)]
[(=? (heap-compare h) x (heap-node-elm h))
(s (union (delete-all x (heap-node-left h))
(s (union (delete-all x (heap-node-left h))
(delete-all x (heap-node-right h))))]
[(<? (heap-compare h) x (heap-node-elm h))
(f)]
[else
[else
(let ([cmp (heap-compare h)])
(let ([y (heap-node-elm h)]
[l (heap-node-left h)]
@ -156,13 +156,13 @@
(lambda () (delete-all/sf x r
(lambda: ([r1 : (Heap a)]) (s (make y l r1)))
(lambda () (f)))))))]))
(delete-all/sf x h
(lambda: ([h1 : (Heap a)]) h1)
(delete-all/sf x h
(lambda: ([h1 : (Heap a)]) h1)
(lambda () h)))
(pdefine: (a) (find-min [h : (heap-node a)]) : a
(heap-node-elm h))
(pdefine: (a) (delete-min [h : (heap-node a)]) : (Heap a)
(union (heap-node-left h) (heap-node-right h)))
@ -174,29 +174,29 @@
(if=? (cmp x (heap-node-elm h))
(s (heap-node-elm h))
(inner-get (heap-node-left h) s
(lambda () (inner-get (heap-node-right h) s
(lambda () (inner-get (heap-node-right h) s
f))))))
(inner-get h (lambda: ([x : a]) x) (lambda () #f))))
;;;
;;; EXTRA OPERATIONS
;;;
(pdefine: (a) (delete* [xs : (list-of a)] [h : (Heap a)]) : (Heap a)
(pdefine: (a) (delete* [xs : (list-of a)] [h : (Heap a)]) : (Heap a)
(foldl {ann delete : (a (Heap a) -> (Heap a))} h xs))
(pdefine: (a r) (fold [f : (a r -> r)] [b : r] [h : (Heap a)]) : r
(if (empty? h)
b
(fold f
(fold f
(fold f
(fold f
(f (heap-node-elm h) b)
(heap-node-left h))
(heap-node-right h))))
(pdefine: (a) (elements [h : (Heap a)]) : (list-of a)
(fold (lambda: ([x : a] [l : (list-of a)]) (cons x l)) '() h))
(pdefine: (a) (count [x : a] [h : (Heap a)]) : number
(let ([cmp (heap-compare h)])
(fold (lambda: ([y : a] [s : number])
@ -204,11 +204,11 @@
(add1 s)
s))
0 h)))
(pdefine: (a) (-heap . [xs : a *]) : (Heap a)
(list->heap xs))
(pdefine: (a) (-heap . [xs : a *]) : (Heap a)
(list->heap xs))
(define: list->heap : (All (a) (case-lambda (comparator (list-of a) -> (Heap a)) ((list-of a) -> (Heap a))))
; time: O(n)
(pcase-lambda: (a)
@ -222,7 +222,7 @@
(cond
[(or (null? hs)
(null? (cdr hs))) hs]
[else
[else
(cons (union (car hs) (cadr hs))
(merge-pairs (cddr hs)))]))
(if (null? hs)
@ -233,9 +233,9 @@
[(null? hs) (error 'never-happen)]
[(null? (cdr hs)) (car hs)]
[else (loop (merge-pairs hs))]))))]))
(pdefine: (a) (insert* [xs : (list-of a)] [h : (Heap a)]) : (Heap a)
(union (list->heap (heap-compare h) xs) h))
@ -249,7 +249,7 @@
(pcase-lambda: (a)
[([x : a]) (insert x (#{empty @ a}))]
[([cmp : comparator] [x : a]) (insert x (make-heap-empty cmp))]))
(pdefine: (a) (size [h : (Heap a)]) : Real
; NOTE: T(size)=O(n)
(cond
@ -257,17 +257,17 @@
[else (+ (size (heap-node-left h))
1
(size (heap-node-right h)))]))
#|
;;;
;;; support for srfi-42
;;;
(define-syntax heap-ec
(syntax-rules ()
[(heap-ec cmp etc1 etc ...)
(fold-ec (empty cmp) etc1 etc ... insert)]))
(define-syntax :heap
(syntax-rules (index)
((:heap cc var (index i) arg)
@ -280,7 +280,7 @@
(let ((var (find-min t))))
#t
((delete-min t)) ))))
(define (:heap-dispatch args)
(cond
[(null? args)
@ -289,9 +289,9 @@
(:generator-proc (:heap (car args)))]
[else
#f]))
(:-dispatch-set!
(:-dispatch-set!
(dispatch-union (:-dispatch-ref) :heap-dispatch))
|#

44
collects/tests/typed-scheme/succeed/little-schemer.rkt
View File

@ -1,4 +1,4 @@
#lang typed-scheme
#lang typed-scheme
#;(require mzlib/etc)
#;(require "prims.ss")
(require mzlib/match
@ -19,7 +19,7 @@
[(_ [pred expr id rhs] . rest)
(quasisyntax/loc stx
(let ([id expr])
(if (pred id)
(if (pred id)
rhs
#,(syntax/loc #'rest (cond . rest)))))]
[(_ [else . rest]) #'(begin . rest)]
@ -41,26 +41,26 @@
(member? a (cdr l)))]))
(define: (rember [a : symbol] [l : (list-of symbol)]) : (list-of symbol)
(cond
(cond
[(null? l) l]
[(eq? (car l) a) (cdr l)]
[else (cons (car l) (rember a (cdr l)))]))
(define: (multisubst [new : symbol] [old : symbol] [lat : (list-of symbol)]) : (list-of symbol)
(cond
(cond
[(null? lat) lat]
[(eq? (car lat) old) (cons new (multisubst new old (cdr lat)))]
[else (cons (car lat) (multisubst new old (cdr lat)))]))
(define: (tup+ [t1 : (list-of number)] [t2 : (list-of number)]) : (list-of number)
(cond
(cond
[(null? t1) t2]
[(null? t2) t1]
[else (cons (+ (car t1) (car t2))
(tup+ (cdr t1) (cdr t2)))]))
(define: (len [l : (list-of top)]) : number
(cond
(cond
[(null? l) 0]
[else (add1 (len (cdr l)))]))
@ -70,8 +70,8 @@
[else (pick (sub1 n) (cdr lat))]))
(define: (no-nums [lat : (list-of atom)]) : (list-of atom)
(cond
[(null? lat) lat]
(cond
[(null? lat) lat]
[(number? (car lat)) (no-nums (cdr lat))]
[else (cons (car lat) (no-nums (cdr lat)))]))
@ -92,7 +92,7 @@
(cond [(and (number? a1) (number? a2)) (= a1 a2)]
[else (eq? a1 a2)]))
(define: (occur [a : atom] [lat : (list-of atom)]) : number
(define: (occur [a : atom] [lat : (list-of atom)]) : number
(cond [(null? lat) 0]
[(eq? (car lat) a) (add1 (occur a (cdr lat)))]
[else (occur a (cdr lat))]))
@ -102,7 +102,7 @@
;; (atom? (car l)) doesn't do anything - bug in type system
#;(define: (rember* [a : atom] [l : (list-of SExp)]) : (list-of SExp)
(cond
(cond
[(null? l) l]
[(atom? (car l))
(cond [(eq? (car l) a) (rember* a (cdr l))]
@ -114,7 +114,7 @@
[(null? l) l]
[else
(let ([c (car l)])
(cond
(cond
[(atom? c)
(cond [(eq? c a) (rember* a (cdr l))]
[else (cons c (rember* a (cdr l)))])]
@ -135,7 +135,7 @@
(insertR* new old (cdr l)))])]
[else (cons (insertR* new old c)
(insertR* new old (cdr l)))]))]))
(define: (occur* [a : atom] [l : (list-of SExp)]) : number
(cond*
[(null? l) 0]
@ -167,7 +167,7 @@
(define-type-alias num-exp (Rec N (U Number (List N (U '+ '* '^) N))))
(define: (value [nexp : num-exp]) : number
(cond
(cond
[(atom? nexp) nexp]
[(eq? (car (cdr nexp)) '+)
(+ (value (car nexp))
@ -201,20 +201,20 @@
(makeset (multirember (car l) (cdr l))))]))
(define: (subset? [set1 : lat] [set2 : lat]) : boolean
(cond
(cond
[(null? set1) #t]
[(member? (car set1) set2)
(subset? (cdr set1) set2)]
[else #f]))
(define: (subset2? [set1 : (list-of atom)] [set2 : (list-of atom)]) : boolean
(cond
(cond
[(null? set1) #t]
[else (and (member? (car set1) set2)
(subset? (cdr set1) set2))]))
(define: (intersect? [set1 : (list-of atom)] [set2 : (list-of atom)]) : boolean
(cond
(cond
[(null? set1) #t]
[else (or (member? (car set1) set2)
(intersect? (cdr set1) set2))]))
@ -269,11 +269,11 @@
(define: (seqR [new : atom] [old : atom] [l : (list-of atom)]) : (list-of atom)
(cons old (cons new l)))
(cons old (cons new l)))
(define: (insertR-g [seq : (atom atom lat -> lat)]
[test? : (atom atom -> boolean)]
[new : atom] [old : atom] [l : (list-of atom)])
[test? : (atom atom -> boolean)]
[new : atom] [old : atom] [l : (list-of atom)])
: (list-of atom)
(cond
[(null? l) l]
@ -282,9 +282,9 @@
[else (cons (car l)
(insertR-g seq test? new old (cdr l)))]))
(define: (insertR-g-curry [seq : (atom atom (list-of atom) -> (list-of atom))])
(define: (insertR-g-curry [seq : (atom atom (list-of atom) -> (list-of atom))])
: ((atom atom -> boolean) atom atom (list-of atom) -> (list-of atom))
(lambda: ([test? : (atom atom -> boolean)]
(lambda: ([test? : (atom atom -> boolean)]
[new : atom] [old : atom] [l : (list-of atom)])
(cond
[(null? l) l]
@ -368,7 +368,7 @@
(define-type-alias table (list-of entry))
(define: (new-entry [keys : (list-of atom)]
(define: (new-entry [keys : (list-of atom)]
[vals : (list-of atom)]) : entry
(cons keys (cons vals empty-atom)))

2
collects/tests/typed-scheme/succeed/logic.rkt
View File

@ -1,4 +1,4 @@
#lang typed-scheme
(: f ((U Number #f) (cons Any Any) -> Number))

2
collects/tests/typed-scheme/succeed/mandelbrot.rkt
View File

@ -5,7 +5,7 @@
(define: N : Positive-Fixnum 512)
(: mandelbrot-point : Integer Integer -> Integer)
(define (mandelbrot-point x y)
(define c
(define c
(+ (- (/ (* 2.0 (->fl x)) N) 1.5)
(* 0.0+1.0i (- (/ (* 2.0 (->fl y)) N) 1.0))))
(let loop ((i 0) (z 0.0+0.0i))

22
collects/tests/typed-scheme/succeed/manual-examples.rkt
View File

@ -16,25 +16,25 @@
(display (my-even? 12)))
(module date typed-scheme
(define-typed-struct my-date ([day : Number] [month : String] [year : Number]))
(define: (format-date [d : my-date]) : String
(format "Today is day ~a of ~a in the year ~a" (my-date-day d) (my-date-month d) (my-date-year d)))
(display (format-date (make-my-date 28 "November" 2006)))
)
(module tree typed-scheme
(define-typed-struct leaf ([val : Number]))
(define-typed-struct node ([left : (Un node leaf)] [right : (Un node leaf)]))
(define: (tree-height [t : (Un node leaf)]) : Integer
(cond [(leaf? t) 1]
[else (max (tree-height (node-left t))
(tree-height (node-right t)))]))
(define: (tree-sum [t : (Un node leaf)]) : Number
(cond [(leaf? t) (leaf-val t)]
[else (+ (tree-sum (node-left t))
@ -43,14 +43,14 @@
(module tree typed-scheme
(define-typed-struct leaf ([val : Number]))
(define-typed-struct node ([left : (Un node leaf)] [right : (Un node leaf)]))
(define-type-alias tree (Un node leaf))
(define: (tree-height [t : tree]) : Integer
(cond [(leaf? t) 1]
[else (max (tree-height (node-left t))
(tree-height (node-right t)))]))
(define: (tree-sum [t : tree]) : Number
(cond [(leaf? t) (leaf-val t)]
[else (+ (tree-sum (node-left t))
@ -64,9 +64,9 @@
(module maybe typed-scheme
(define-typed-struct Nothing ())
(define-typed-struct (a) Just ([v : a]))
(define-type-alias (Maybe a) (Un Nothing (Just a)))
(define: (find [v : Number] [l : (Listof Number)]) : (Maybe Number)
(cond [(null? l) (make-Nothing)]
[(= v (car l)) (make-Just v)]

2
collects/tests/typed-scheme/succeed/map2.rkt
View File

@ -1,4 +1,4 @@
#lang typed-scheme
#lang typed-scheme
(map add1 #{(list 1 2 3) :: (Listof Integer)})
(map add1 #{(list 1 2 3) :: (Listof Number)})

4
collects/tests/typed-scheme/succeed/member-pred.rkt
View File

@ -7,13 +7,13 @@
x
'x)
(U 'x 'y))
(ann
(if (memv x '(x y))
x
'x)
(U 'x 'y))
(if (memq x '(x y))
x
'x))

126
collects/tests/typed-scheme/succeed/metrics.rkt
View File

@ -3,7 +3,7 @@
#;(require "../list.scm"
"../etc.ss")
(require/typed apply-to-scheme-files
(require/typed apply-to-scheme-files
((Path -> (Listof (Listof (U #f (Listof (U Real #f))))))
Path
-> (Listof (U #f (Listof (Listof ( U #f (Listof (U Real #f)))))))) "foldo.rkt")
@ -34,7 +34,7 @@
(define-type-alias NumB (U boolean number))
;;C is either Sexpr or Listof Sepr
;;X = (Listof (U number #f)) - not needed as a parameter
(define-type-alias (Unit X C) ((C -> X) -> (Path -> (Listof (U #f X)))))
(define-type-alias (Unit X C) ((C -> X) -> (Path -> (Listof (U #f X)))))
;; ============================================================
;; CONFIG
@ -57,7 +57,7 @@
;; in mean cannot be explained by chance.
(define: (t-test [seqA : (Listof Real)] [seqB : (Listof Real)]) : Real
(manual-t-test
(avg seqA) (avg seqB)
(avg seqA) (avg seqB)
(variance seqA) (variance seqB)
(length seqA) (length seqB)))
@ -73,7 +73,7 @@
;; be explained by chance. higher numbers means higher confidence
;; that they cannot.
(define: (chi-square [seqA : (Listof number)] [seqB : (Listof number)]) : number
(with-handlers ([exn:fail? (lambda: ([e : str]) +nan.0)])
(with-handlers ([exn:fail? (lambda: ([e : str]) +nan.0)])
(let* ([ct-a (length seqA)]
[ct-b (length seqB)]
[total-subjects (+ ct-a ct-b)]
@ -86,8 +86,8 @@
(,a-misses ,b-misses))]
[expected (lambda: ([i : Integer] [j : Integer])
(/ (* (row-total i table) (col-total j table)) total-subjects))])
(exact->inexact
(table-sum
(exact->inexact
(table-sum
(lambda: ([i : Integer] [j : Integer])
(/ (sqr (- (expected i j) (table-ref i j table))) (expected i j)))
table)))))
@ -96,7 +96,7 @@
;; UNITS OF MEASUREMENT IMPLEMENTATIONS
;; per-module : path ((listof expr) -> (number | #f)) -> (path -> (listof (number | #f))) === Unit P
(pdefine: (X) (per-module [f : ((Listof Sexpr) -> X )]) : (Path -> (cons (U #f X) '()))
(pdefine: (X) (per-module [f : ((Listof Sexpr) -> X )]) : (Path -> (cons (U #f X) '()))
(lambda: ([path : Path])
(with-handlers ([exn:fail:read? (lambda: ([e : Void]) (list #f))]) ;; with handler
(let ([initial-sexp (with-input-from-file path read)])
@ -108,10 +108,10 @@
;; per-module-top-level-expression : path (expr -> (number | #f)) -> (path -> (listof (number | #f)))
(define: (per-module-top-level-expression [f : (Sexpr -> (Listof NumF))] ) : ( Path -> (Listof (U #f (Listof NumF))))
(let ([calc (per-module (lambda: ([exprs : (Listof Sexpr)]) (map f exprs)))])
(let ([calc (per-module (lambda: ([exprs : (Listof Sexpr)]) (map f exprs)))])
(lambda: ([p : Path]) (let* ([r (calc p)]
[carr (car r)]) ;;carr added
(if carr carr
(if carr carr
(list carr)))))) ;; list carr instead of r
;; ============================================================
@ -138,7 +138,7 @@
;; ----------------------------------------
;; setbang counts
(define-type-alias (IList e) (mu x (Un e '() (cons e x))))
(define-type-alias (IList e) (mu x (Un e '() (cons e x))))
;; count-setbangs/ilist : ((ilistof expr) -> number)
(define: (count-setbangs/ilist [exprs : (Listof Any)]) : number
@ -148,12 +148,12 @@
(define: (count-setbangs/expr [expr : Any]) : number
(match expr
[`(,(? setbang?) . ,rest ) ;(,(? setbang?) ,rest ...)
(if (list? rest)
(if (list? rest)
(+ 1 (count-setbangs/ilist rest))
0)] ;; mostly occurs in syntax patterns
[('quote _) 0]
[('quasiquote _) 0] ; undercount potentially, but how many `,(set! ...)'s can there be?
[`(,e1 . ,e2)
[`(,e1 . ,e2)
(if (list? expr)
(count-setbangs/ilist expr)
(error " l" expr ))] ;;FIXME - do something intelligent here
@ -167,7 +167,7 @@
;; count-fns
(define: (count-fns-with-setbangs [exprs : (Listof Sexpr)]) : number
(apply + (map (lambda: ([e : Sexpr]) (if (= (count-setbangs/expr e) 0) 0 1)) exprs)))
(define: (module-has-setbangs? [exprs : (Listof Sexpr)]) : Boolean
(define: (module-has-setbangs? [exprs : (Listof Sexpr)]) : Boolean
(ormap expr-uses-setbangs? exprs))
(define: (expr-uses-setbangs? [expr : Sexpr]) : Boolean
(not (= (count-setbangs/expr expr) 0)))
@ -180,10 +180,10 @@
(* (/ set!s atoms) 1000.0))))
;; ----------------------------------------
;; contracts
;; contracts
(define: (uses-contracts [exprs : (Listof Sexpr)]) : Boolean
(define: (uses-contracts [exprs : (Listof Sexpr)]) : Boolean
(ormap (lambda: ([e : Sexpr])
(match e
[`(provide/contract . ,_) #t]
@ -195,9 +195,9 @@
(lambda: ([t : Sexpr] [r : number])
(match t
;; FIXME match ...
[`(provide/contract . ,p ) ;(provide/contract ,p ...)
[`(provide/contract . ,p ) ;(provide/contract ,p ...)
(if (list? p)
(+ (length p) r)
(+ (length p) r)
r)] ;; extra case added
[_ r]))
0
@ -208,10 +208,10 @@
(foldl
(lambda: ([t : Sexpr] [r : number])
(match t
[`(provide . ,p ) ;(provide ,p ...)
[`(provide . ,p ) ;(provide ,p ...)
(if (list? p)
(+ (length p) r)
r)]
r)]
[_ r]))
0
exprs))
@ -222,11 +222,11 @@
(define: (number-of-macro-definitions [expr : Sexpr]) : number
(match expr
[`(define-syntax ,_ ...) 1]
[`(define-syntaxes (,s . ,r ). ,_ ) ;`(define-syntaxes (,s ...) ,_ ...)
[`(define-syntaxes (,s . ,r ). ,_ ) ;`(define-syntaxes (,s ...) ,_ ...)
(if (and (list? expr)(list? r))
(length (cons s r));;s -> cadr expr
(error "corrupted file"))]
[`(define-syntax-set (,s . ,r) . ,_ ) ;(define-syntax-set (,s ...) ,_ ...)
[`(define-syntax-set (,s . ,r) . ,_ ) ;(define-syntax-set (,s ...) ,_ ...)
(if (and (list? expr) (list? r))
(length (cons s r))
(error "corrupted file"))]
@ -270,14 +270,14 @@
(define-type-alias Table (Listof (Listof Real)))
(define-type-alias Atom-display (cons Symbol (Listof Real)))
(define: (standard-display [name : Symbol]
[summarize : ((Listof number) -> number)]
[significance-test : ((Listof number)(Listof number) -> number)])
: ((Listof NumF) (Listof NumF) -> Atom-display)
(define: (standard-display [name : Symbol]
[summarize : ((Listof number) -> number)]
[significance-test : ((Listof number)(Listof number) -> number)])
: ((Listof NumF) (Listof NumF) -> Atom-display)
;; FIXME - use lambda instead of (define ((
(lambda: ([seqA : (Listof NumF)] [seqB : (Listof NumF)])
(let ([clean-seqA (nonfalses seqA)]
[clean-seqB (nonfalses seqB)])
(let ([clean-seqA (nonfalses seqA)]
[clean-seqB (nonfalses seqB)])
(list name (summarize clean-seqA) (summarize clean-seqB) (significance-test clean-seqA clean-seqB)))))
(pdefine: (c) (interval [u : (Unit (Listof NumF) c)]
@ -292,20 +292,20 @@
: (Metric Atom-display c NumF)
(make-metric u (lambda: ([es : c]) #{(if (compute es) 1 0) :: NumF}) (standard-display name avg chi-square)))
(pdefine: (c) (combine-metrics [ms : (Listof (Metric Atom-display c NumF))])
(pdefine: (c) (combine-metrics [ms : (Listof (Metric Atom-display c NumF))])
: (Metric (Listof Atom-display) c (Listof NumF))
(let ([u (metric-analysis-unit (car ms))])
(let ([u (metric-analysis-unit (car ms))])
;; This test now redundant b/c of typechecking
(unless (andmap (lambda: ([m : (Metric Atom-display c NumF) ]) (eq? u (metric-analysis-unit m))) ms)
(error 'combine-metrics "all combined metrics must operate on the same unit of analysis"))
(make-metric
u
(lambda: ([exprs : c] ) (map (lambda: ([m : (Metric Atom-display c NumF)]) ((metric-computation m) exprs)) ms))
(lambda: ([seqA : (Listof (Listof NumF))] [seqB : (Listof (Listof NumF))])
(map (lambda: ([m : (Metric Atom-display c NumF)]
[sA : (Listof NumF)]
[sB : (Listof NumF)])
(map (lambda: ([m : (Metric Atom-display c NumF)]
[sA : (Listof NumF)]
[sB : (Listof NumF)])
((metric->display m) sA sB)) ms (pivot seqA) (pivot seqB))))))
;; FIXME - should go in helper file
@ -315,13 +315,13 @@
(if (null? lst)
'()
(let ([x (car lst)])
(if x
(if x
(cons x (loop (cdr lst)))
(loop (cdr lst)))))))
(define: (avg [l : (Listof number)]) : number
(define: (avg [l : (Listof number)]) : number
(/ (exact->inexact (apply + l)) (length l)))
(define: (avg* [l : (Listof number)]) : number
(define: (avg* [l : (Listof number)]) : number
(avg (nonfalses l)))
(require (for-syntax scheme/base))
@ -333,7 +333,7 @@
[n (syntax->list #'(name ...))]
[f (syntax->list #'(fn ...))])
(quasisyntax/loc k (#,k u '#,n #,f)))])
(syntax/loc
(syntax/loc
stx
(begin
(define: u : ((type -> (Listof NumF)) -> (Path -> (Listof (U #f(Listof NumF))))) unit-of-analysis )
@ -348,14 +348,14 @@
(uses-setbang?/mod count module-has-setbangs?)
(uses-contracts? count uses-contracts)
(number-of-contracts interval contracted-provides)
(num-uncontracted-provides interval uncontracted-provides)
(num-uncontracted-provides interval uncontracted-provides)
(number-of-macro-defs interval num-of-define-syntax)
(maximum-num-atoms interval max-atoms)
(maximum-num-atoms interval max-atoms)
(average-num-atoms interval avg-atoms)
(total-num-atoms/mod interval total-atoms)
(set!s-per-1000-atoms interval setbangs-per-1000-atoms))
(define-metrics tl-expr-metrics per-module-top-level-expression Sexpr
(define-metrics tl-expr-metrics per-module-top-level-expression Sexpr
(uses-setbang?/fn count expr-uses-setbangs?)
(number-of-setbangs/fn interval count-setbangs/expr)
(total-num-atoms/fn interval atoms))
@ -367,16 +367,16 @@
;; ============================================================
;; EXPERIMENT RUNNING
;; FIXME - everything in untyped file (foldo.ss) b/c fold-files has terrible api
;; FIXME - everything in untyped file (foldo.ss) b/c fold-files has terrible api
#;(define-syntax (define-excluder stx)
(define (path->clause c)
(syntax-case c ()
[(item ...)
#`[`(#,@(reverse (syntax-e #'(item ...))) ,_ (... ...)) #t]]
[item
#`[`(item) #t]]))
(syntax-case stx ()
[(_ name path ...)
(with-syntax ([(match-clause ...) (map path->clause (syntax-e #'(path ...)))])
@ -386,7 +386,7 @@
match-clause ...
[_ #f]))))]))
#;(define-excluder default-excluder
#;(define-excluder default-excluder
"compiled" ".svn" #;("collects" "drscheme") #;("collects" "framework"))
#;(define: exclude-directory? : (Parameter (Path -> Any)) (make-parameter default-excluder))
@ -395,10 +395,10 @@
;; apply-to-scheme-files: (path[file] -> X) path[directory] -> (listof X)
;; applies the given function to each .ss or .scm file in the given directory
;; hierarchy; returns all results in a list
#;(define: (apply-to-scheme-files [f : (Path -> (Listof(Listof(Listof NumF))))]
#;(define: (apply-to-scheme-files [f : (Path -> (Listof(Listof(Listof NumF))))]
[root : Path])
: (Listof (Listof(Listof(Listof NumF)))) ;;FOLD-FILES
: (Listof (Listof(Listof(Listof NumF)))) ;;FOLD-FILES
(fold-files
(lambda: ([path : Path] [kind : Symbol]
[acc : (Listof (Listof(Listof(Listof NumF))))])
@ -413,10 +413,10 @@
#;(cons resl acc) (values (cons resl acc) #t) ;;values added
#;acc (values acc #t)))]
[else #;acc (values acc #t)]))]
[(dir)
[(dir)
(let* ([p (normalize-path path root)])
(if ((exclude-directory?) p)
#; acc (values acc #f)
#; acc (values acc #f)
#;acc (values acc #t)))] ;; values added
[(link) #;acc (values acc #t)]
[else (error "never happen")])) ;;error added
@ -430,23 +430,23 @@
;; get-sequences : (listof 'a metric) path -> (listof (listof 'a))
(pdefine: (b c) (get-sequences [metrics : (Listof (U (Metric b c (Listof NumF))))]
[path : Path])
[path : Path])
: (Listof (Listof (Listof NumF)))
(let* ([metric-fns ; : (Listof (Path -> (Listof (U #f(Listof NumF)))))
(map (lambda: ([m : (Metric b c (Listof NumF))])
((metric-analysis-unit m)
((metric-analysis-unit m)
(metric-computation m))) metrics)]
[#{result-seqs : (Listof (U #f (Listof (Listof ( U #f (Listof NumF))))))}
(apply-to-scheme-files
(lambda: ([file : Path])
(apply-to-scheme-files
(lambda: ([file : Path])
(map (lambda: ([fn : (Path -> (Listof (U #f (Listof NumF))))]) (fn file)) metric-fns)) path)])
(map (lambda: ([l : (Listof(Listof (Option (Listof NumF))))])
(map (lambda: ([l : (Listof(Listof (Option (Listof NumF))))])
;; FIXME - problem with inference and ordering
(nonfalses (apply append l)))
(pivot (nonfalses result-seqs)))))
;; compare* : (listof metric) -> (listof result)
(: compare* (All (b c)
(: compare* (All (b c)
((Listof (Metric b c (Listof NumF)))
->
(Listof (Result (Listof NumF) b c)))))
@ -480,7 +480,7 @@
;; ============================================================
;; UTILITY
(pdefine: (X Y) (imap [f : (X -> Y)] [il : (Listof X)]) : (Listof Y)
(pdefine: (X Y) (imap [f : (X -> Y)] [il : (Listof X)]) : (Listof Y)
(cond
[(null? il) '()]
[(not (pair? il)) (list (f il))]
@ -524,31 +524,31 @@
;; unused (and untypeable)
#;(define: (/* . [args : (Listof number)]) : number ;;((number)) against (number) and USELESS
(apply map (lambda: ([ns : number]) (apply / ns)) args))
(apply map (lambda: ([ns : number]) (apply / ns)) args))
;; ============================================================
;; MAIN ENTRY POINT
(define: results :
(define: results :
#;Any
;; FIXME bug in typed scheme when this type is used
(Listof (U (Result (Listof NumF) (Listof Atom-display) (Listof Sexpr))
(Listof (U (Result (Listof NumF) (Listof Atom-display) (Listof Sexpr))
(Result (Listof NumF) (Listof Atom-display) Sexpr)))
'())
; just in case i want to do some more analysis on the results afterwards,
; so i don't have to waste a minute if i forget to bind the return value to something
(define: (run-all-tests) : top
(let*: ([rs1 : (Listof (Result (Listof NumF) (Listof Atom-display) (Listof Any)))
(#{compare* @ (Listof Atom-display) (Listof Any)}
(#{compare* @ (Listof Atom-display) (Listof Any)}
(list module-metrics))]
[rs2 : (Listof (Result (Listof NumF) (Listof Atom-display) Any))
(#{compare* @ (Listof Atom-display) Any}
(#{compare* @ (Listof Atom-display) Any}
(list tl-expr-metrics))])
(let
([rs (append rs1 rs2)])
(set! results rs)
(set! results rs)
(for-each #{pretty-print-result @ (Listof Any)} rs1)
(for-each #{pretty-print-result @ Any} rs2)
rs)))

2
collects/tests/typed-scheme/succeed/nested-poly.rkt
View File

@ -6,7 +6,7 @@
(define (f . xs) 5)
(: map-with-funcs
(: map-with-funcs
(All (A ...)
(All (B ...)
((B ... B -> A) ... A ->

90
collects/tests/typed-scheme/succeed/new-metrics.rkt
View File

@ -1,7 +1,7 @@
#lang typed-scheme
(provide results run-all-tests)
(require (except-in scheme/list count) scheme/math scheme/path mzlib/match
(require (except-in scheme/list count) scheme/math scheme/path mzlib/match
(prefix-in srfi13: srfi/13) scheme/file
(for-syntax scheme/base))
@ -11,7 +11,7 @@
(define-type-alias NumF (U Number #f))
(define-type-alias (Unit C) ((C -> (Listof NumF)) -> (Path -> (Listof (U #f (Listof NumF))))))
(define-type-alias (Unit C) ((C -> (Listof NumF)) -> (Path -> (Listof (U #f (Listof NumF))))))
;; ============================================================
;; CONFIG
@ -34,7 +34,7 @@
;; in mean cannot be explained by chance.
(define (t-test seqA seqB)
(manual-t-test
(avg seqA) (avg seqB)
(avg seqA) (avg seqB)
(variance seqA) (variance seqB)
(length seqA) (length seqB)))
@ -63,8 +63,8 @@
(,a-misses ,b-misses))]
[expected (λ: ([i : Integer] [j : Integer])
(/ (* (row-total i table) (col-total j table)) total-subjects))])
(exact->inexact
(table-sum
(exact->inexact
(table-sum
(λ (i j) (/ (sqr (- (expected i j) (table-ref i j table))) (expected i j)))
table)))))
@ -72,7 +72,7 @@
;; UNITS OF MEASUREMENT IMPLEMENTATIONS
(: per-module (All (X) (((Listof Any) -> X) -> (Path -> (List (U #f X))))))
(define (per-module f)
(define (per-module f)
(λ (path)
(with-handlers ([exn:fail:read? (λ (e) (list #f))])
(let ([initial-sexp (with-input-from-file path read)])
@ -83,7 +83,7 @@
(: per-module-top-level-expression ((Any -> (Listof NumF)) -> MetricFn))
(define (per-module-top-level-expression f)
(let ([calc (per-module (λ: ([exprs : (Listof Any)]) (map f exprs)))])
(let ([calc (per-module (λ: ([exprs : (Listof Any)]) (map f exprs)))])
(λ (p) (let ([r (calc p)]) (if (car r) (car r) r)))))
;; ============================================================
@ -149,10 +149,10 @@
(* (/ set!s atoms) 1000.0))))
;; ----------------------------------------
;; contracts
;; contracts
(: uses-contracts ((Listof Any) -> Boolean))
(define (uses-contracts exprs)
(define (uses-contracts exprs)
(ormap (λ (e)
(ann
(match e
@ -173,12 +173,12 @@
exprs))
(: uncontracted-provides ((Listof Any) -> Number))
(define (uncontracted-provides exprs)
(define (uncontracted-provides exprs)
(foldl
(λ: ([t : Any] [r : Number])
(ann
(ann
(match t
[`(provide ,p ...) (+ (length p) r)]
[`(provide ,p ...) (+ (length p) r)]
[_ r]) : Number))
0
exprs))
@ -237,7 +237,7 @@
(define-type-alias Table (Listof (Listof Number)))
(define-type-alias Atom-display (cons Symbol (Listof Number)))
(: standard-display (Symbol ((Listof Number) -> Number) ((Listof Number) (Listof Number) -> Number)
(: standard-display (Symbol ((Listof Number) -> Number) ((Listof Number) (Listof Number) -> Number)
-> ((Listof NumF) (Listof NumF) -> Atom-display)))
(define ((standard-display name summarize significance-test) seqA seqB)
(let ([clean-seqA (nonfalses seqA)]
@ -252,28 +252,28 @@
(: combine-metrics (All (c) ((Listof (metric Atom-display c NumF)) -> (metric (Listof Atom-display) c (Listof NumF)))))
(define (combine-metrics ms)
(let ([u (metric-analysis-unit (car ms))])
(let ([u (metric-analysis-unit (car ms))])
;; This test now redundant b/c of typechecking
(unless (andmap (λ: ([m : (metric Atom-display c NumF) ]) (eq? u (metric-analysis-unit m))) ms)
(error 'combine-metrics "all combined metrics must operate on the same unit of analysis"))
(make-metric
u
(λ: ([exprs : c]) (map (λ: ([m : (metric Atom-display c NumF)]) ((metric-computation m) exprs)) ms))
(λ: ([seqA : (Listof (Listof NumF))] [seqB : (Listof (Listof NumF))])
(map (λ: ([m : (metric Atom-display c NumF)]
[sA : (Listof NumF)]
[sB : (Listof NumF)])
(map (λ: ([m : (metric Atom-display c NumF)]
[sA : (Listof NumF)]
[sB : (Listof NumF)])
((metric->display m) sA sB)) ms (pivot seqA) (pivot seqB))))))
;; FIXME - (filter (lambda (x) x) l)
(: nonfalses (All (X) ((Listof (U #f X)) -> (Listof X))))
(define (nonfalses l)
(define (nonfalses l)
(let loop ([lst l])
(if (null? lst)
'()
(let ([x (car lst)])
(if x
(if x
(cons x (loop (cdr lst)))
(loop (cdr lst)))))))
@ -290,22 +290,22 @@
(define name (kind u 'name fn )) ...
(define all-metrics-id (combine-metrics (list name ...))))]))
(define-metrics module-metrics #{per-module @ (Listof NumF)}
(define-metrics module-metrics #{per-module @ (Listof NumF)}
(maximum-sexp-depth interval max-sexp-depth)
(average-sexp-depth interval avg-sexp-depth)
(number-of-setbangs/mod interval count-setbangs/ilist)
(number-of-exprs interval #{length @ Any})
(number-of-exprs interval #{length @ Any})
(uses-setbang?/mod count module-has-setbangs?)
(uses-contracts? count uses-contracts)
(number-of-contracts interval contracted-provides)
(num-uncontracted-provides interval uncontracted-provides)
(num-uncontracted-provides interval uncontracted-provides)
(number-of-macro-defs interval num-of-define-syntax)
(maximum-num-atoms interval max-atoms)
(maximum-num-atoms interval max-atoms)
(average-num-atoms interval avg-atoms)
(total-num-atoms/mod interval total-atoms)
(set!s-per-1000-atoms interval setbangs-per-1000-atoms))
(define-metrics tl-expr-metrics per-module-top-level-expression
(define-metrics tl-expr-metrics per-module-top-level-expression
(uses-setbang?/fn count expr-uses-setbangs?)
(number-of-setbangs/fn interval count-setbangs/expr)
(total-num-atoms/fn interval atoms))
@ -318,25 +318,25 @@
;; EXPERIMENT RUNNING
(define-syntax (define-excluder stx)
(define (path->clause c)
(syntax-case c ()
[(item ...)
#`[`(#,@(reverse (syntax-e #'(item ...))) ,_ (... ...)) #t]]
[item
#`[`(item) #t]]))
(syntax-case stx ()
[(_ name path ...)
(with-syntax ([(match-clause ...) (map path->clause (syntax-e #'(path ...)))])
#`(define (name p )
#`(define (name p )
(let* ([dirnames (map path->string (filter path? (explode-path p)))])
(match (reverse dirnames) ; goofy backwards matching because ... matches greedily
match-clause ...
[_ #f]))))]))
(: default-excluder (Path -> Boolean))
(define-excluder default-excluder
(define-excluder default-excluder
"compiled" ".svn" #;("collects" "drscheme") #;("collects" "framework"))
(define exclude-directory? (make-parameter default-excluder))
@ -357,17 +357,17 @@
[(regexp-match #rx"(ss|scm)$" extension)
(let ([resl (f path)])
(if resl
(values (cons resl acc) #t)
(values (cons resl acc) #t)
(values acc #t)))]
[else (values acc #t)]))]
[(dir)
[(dir)
(let* ([p (normalize-path path root)])
(if ((exclude-directory?) p)
(values acc #f)
(values acc #t)))]
[(link) (values acc #t)]))
(values acc #t)))]
[(link) (values acc #t)]))
'()
root))
root))
(define-typed-struct (a b c) result ([metric : (metric b c a)] [seqA : (Listof a)] [seqB : (Listof a)]))
(define-type-alias MetricFn (Path -> (Listof (U #f (Listof NumF)))))
@ -380,16 +380,16 @@
(: selector (case-lambda [(M b c) -> MetricFn] [(M b C) -> MetricFn]))
(define (selector m) ((metric-analysis-unit m) (metric-computation m)))
(let* ([metric-fns (map #{selector :: ((M2 b c C) -> MetricFn)} metrics)]
[result-seqs (apply-to-scheme-files
(λ: ([file : Path])
[result-seqs (apply-to-scheme-files
(λ: ([file : Path])
(map (λ: ([fn : MetricFn]) (fn file)) metric-fns)) path)])
(map
(λ: ([l : (Listof (Listof (U #f (Listof NumF))))])
(map
(λ: ([l : (Listof (Listof (U #f (Listof NumF))))])
(nonfalses (apply append l)))
(pivot (nonfalses result-seqs)))))
(: compare*
(: compare*
(All (b c c*)
((List (M b c) (M b c*))
->
@ -408,7 +408,7 @@
(result-seqA result)
(result-seqB result)))
(: pretty-print-result
(: pretty-print-result
(case-lambda
((result (Listof NumF) (Listof Atom-display) (Listof Any)) -> Void)
((result (Listof NumF) (Listof Atom-display) Any) -> Void)))
@ -435,7 +435,7 @@
;; UTILITY
(: imap (All (Y) ((Any -> Y) Any -> (Listof Y))))
(define (imap f il)
(define (imap f il)
(cond
[(null? il) '()]
[(not (pair? il)) (list (f il))]
@ -491,16 +491,16 @@
;; ============================================================
;; MAIN ENTRY POINT
(: results (U #f (Listof (U (result (Listof NumF) (Listof Atom-display) (Listof Any))
(: results (U #f (Listof (U (result (Listof NumF) (Listof Atom-display) (Listof Any))
(result (Listof NumF) (Listof Atom-display) Any)))))
(define results #f) ; just in case i want to do some more analysis on the results afterwards,
; so i don't have to waste a minute if i forget to bind the return value to something
(define (run-all-tests)
(define (run-all-tests)
(let ([rs (compare* all-metrics)])
(set! results rs)
(for-each
(ann pretty-print-result ((U (result (Listof NumF) (Listof Atom-display) (Listof Any))
(ann pretty-print-result ((U (result (Listof NumF) (Listof Atom-display) (Listof Any))
(result (Listof NumF) (Listof Atom-display) Any))
-> Any))
rs)

4
collects/tests/typed-scheme/succeed/or-sym.rkt
View File

@ -2,7 +2,7 @@
#;#;
(: g (Any -> Boolean : (U 'r 's)))
(define (g x)
(define (g x)
(let ([q x])
(let ([op2 (eq? 'r x)])
(if op2 op2 (eq? 's x)))))
@ -13,7 +13,7 @@
(let ([op1 (eq? 'q x)])
(if op1 op1
(let ([op2 (eq? 'r x)])
(if op2
(if op2
;; !#f_op2
op2
(eq? 's x)))))))

6
collects/tests/typed-scheme/succeed/paths.rkt
View File

@ -19,9 +19,9 @@
(: other-foo-path Path-For-Some-System)
(define other-foo-path
(build-path/convention-type other-system
(string->some-system-path "foo" other-system)
(string->some-system-path "bar" other-system)
'same
(string->some-system-path "foo" other-system)
(string->some-system-path "bar" other-system)
'same
'up))

4
collects/tests/typed-scheme/succeed/pathstrings.rkt
View File

@ -2,7 +2,7 @@
(: no-exec (-> Void))
(define (no-exec)
(call-with-output-file "file.tmp"
(lambda: ((port : Output-Port))
@ -15,7 +15,7 @@
(make-directory "tmp-dir")
(path-only "file.tmp")
(system #"echo foo")
(system* "/bin/echo" "zzz" #"foo" (string->path "/"))
(system/exit-code #"echo foo")

4
collects/tests/typed-scheme/succeed/poly-tests.rkt
View File

@ -16,10 +16,10 @@
[else (cons (f (car l))
(mymap2 f (cdr l)))]))
(define: x : (list-of number)
(define: x : (list-of number)
(mymap (lambda: ([x : number]) (+ 3 x)) (cons 1 (cons 4 #{'() : (list-of number)}))))
(define: x2 : (list-of number)
(define: x2 : (list-of number)
(mymap2 (lambda: ([x : number]) (+ 3 x)) (cons 1 (cons 4 #{'() : (list-of number)}))))
(provide x2)

2
collects/tests/typed-scheme/succeed/pr10319.rkt
View File

@ -10,5 +10,5 @@
[(null? lsn) 0]
[(number? (car lsn)) (+ (car lsn) (sum (cdr lsn)))]
[else (sum (cdr lsn))]))
(sum '(a b 2 3))

8
collects/tests/typed-scheme/succeed/pr11686.rkt
View File

@ -1,15 +1,15 @@
#lang racket/load
(module T typed/racket
(struct: [X] doll ([contents : X]))
(define-type RussianDoll
(Rec RD (U 'center (doll RD))))
(: f (RussianDoll -> RussianDoll))
(define (f rd) rd)
(provide (all-defined-out)))
(require 'T)

2
collects/tests/typed-scheme/succeed/pr9048.rkt
View File

@ -10,5 +10,5 @@
)
(module client typed-scheme
(require-typed-struct ast ([loc : Any]) 'source))

4
collects/tests/typed-scheme/succeed/pr9054.rkt
View File

@ -10,7 +10,7 @@
(provide (all-defined)))
(module alias typed-scheme
(define-type-alias Srcloc Any)
(require-typed-struct term ([posn : Srcloc]) 'source))

2
collects/tests/typed-scheme/succeed/priority-queue.scm
View File

@ -63,7 +63,7 @@
;; "bug" found - handling of empty heaps
(pdefine: (a) (find-min [pq : (priority-queue a)]) : a
(pdefine: (a) (find-min [pq : (priority-queue a)]) : a
(let ([h (heap pq)])
(if (heap:empty? h)
(error "priority queue empty")

2
collects/tests/typed-scheme/succeed/provide-struct-untyped.rkt
View File

@ -7,7 +7,7 @@
(provide (all-defined-out)))
(module n2 scheme/base
(require 'm scheme/match)
(match my-x
[(struct x (f)) (f 7)]))

2
collects/tests/typed-scheme/succeed/provide-struct.rkt
View File

@ -1,4 +1,4 @@
#lang scheme/load
#lang scheme/load
(module m typed-scheme

100
collects/tests/typed-scheme/succeed/random-bits.rkt
View File

@ -1,10 +1,10 @@
; MODULE DEFINITION FOR SRFI-27
; =============================
;
;
; Sebastian.Egner@philips.com, Mar-2002, in PLT 204
;
; This file contains the top-level definition for the 54-bit integer-only
; implementation of SRFI 27 for the PLT 204 DrScheme system.
; implementation of SRFI 27 for the PLT 204 DrScheme system.
;
; 1. The core generator is implemented in 'mrg32k3a-a.scm'.
; 2. The generic parts of the interface are in 'mrg32k3a.scm'.
@ -20,7 +20,7 @@
#;(require srfi/9)
#;(require srfi/23)
(provide
(provide
random-integer random-real default-random-source
make-random-source random-source? random-source-state-ref
random-source-state-set! random-source-randomize!
@ -37,19 +37,19 @@
[state-set! : ((Listof Nb)-> Void)]
[randomize! : ( -> Void)]
[pseudo-randomize! : (Integer Integer -> Void)]
[make-integers : (-> (Integer -> Integer)) ]
[make-reals : ( Nb * -> ( -> Number))]))
[make-integers : (-> (Integer -> Integer)) ]
[make-reals : ( Nb * -> ( -> Number))]))
(define-type-alias Random :random-source)
(define: (:random-source-make
(define: (:random-source-make
[state-ref : ( -> SpList)]
[state-set! : ((Listof Nb)-> Void)]
[randomize! : ( -> Void)]
[pseudo-randomize! : (Integer Integer -> Void)]
[make-integers : (-> (Integer -> Integer)) ]
[make-integers : (-> (Integer -> Integer)) ]
[make-reals : (Nb * -> (-> Number))])
: Random
(make-:random-source state-ref state-set! randomize! pseudo-randomize! make-integers make-reals ))
#;(define-record-type :random-source
(:random-source-make
state-ref
@ -65,7 +65,7 @@
(pseudo-randomize! :random-source-pseudo-randomize!)
(make-integers :random-source-make-integers)
(make-reals :random-source-make-reals))
(define: :random-source-current-time : ( -> Nb )
current-milliseconds) ;;on verra apres
@ -90,7 +90,7 @@
; the actual generator
(define: (mrg32k3a-random-m1 [state : State]) : Nb
(let ((x11 (vector-ref state 0))
(x12 (vector-ref state 1))
@ -153,8 +153,8 @@
; Generator
; =========
;
; Pierre L'Ecuyer's MRG32k3a generator is a Combined Multiple Recursive
; Generator. It produces the sequence {(x[1,n] - x[2,n]) mod m1 : n}
; Pierre L'Ecuyer's MRG32k3a generator is a Combined Multiple Recursive
; Generator. It produces the sequence {(x[1,n] - x[2,n]) mod m1 : n}
; defined by the two recursive generators
;
; x[1,n] = ( a12 x[1,n-2] + a13 x[1,n-3]) mod m1,
@ -182,15 +182,15 @@
; publication provides detailed information on how to do that:
;
; [1] P. L'Ecuyer, R. Simard, E. J. Chen, W. D. Kelton:
; An Object-Oriented Random-Number Package With Many Long
; An Object-Oriented Random-Number Package With Many Long
; Streams and Substreams. 2001.
; To appear in Operations Research.
;
; Arithmetics
; ===========
;
; The MRG32k3a generator produces values in {0..2^32-209-1}. All
; subexpressions of the actual generator fit into {-2^53..2^53-1}.
; The MRG32k3a generator produces values in {0..2^32-209-1}. All
; subexpressions of the actual generator fit into {-2^53..2^53-1}.
; The code below assumes that Scheme's "integer" covers this range.
; In addition, it is assumed that floating point literals can be
; read and there is some arithmetics with inexact numbers.
@ -210,16 +210,16 @@
; pack/unpack a state of the generator. The core generator works
; on packed states, passed as an explicit argument, only. This
; allows native code implementations to store their state in a
; suitable form. Unpacked states are #(x10 x11 x12 x20 x21 x22)
; suitable form. Unpacked states are #(x10 x11 x12 x20 x21 x22)
; with integer x_ij. Pack/unpack need not allocate new objects
; in case packed and unpacked states are identical.
;
; (mrg32k3a-random-range) -> m-max
; (mrg32k3a-random-integer packed-state range) -> x in {0..range-1}
; advance the state of the generator and return the next random
; range-limited integer.
; Note that the state is not necessarily advanced by just one
; step because we use the rejection method to avoid any problems
; range-limited integer.
; Note that the state is not necessarily advanced by just one
; step because we use the rejection method to avoid any problems
; with distribution anomalies.
; The range argument must be an exact integer in {1..m-max}.
; It can be assumed that range is a fixnum if the Scheme system
@ -237,7 +237,7 @@
; to be defined to create and access a new record data type:
;
; (:random-source-make a0 a1 a2 a3 a4 a5) -> s
; constructs a new random source object s consisting of the
; constructs a new random source object s consisting of the
; objects a0 .. a5 in this order.
;
; (:random-source? obj) -> bool
@ -267,7 +267,7 @@
; ===================
(define: (mrg32k3a-state-ref [packed-state : State ]) : (cons 'lecuyer-mrg32k3a (Listof Nb))
(cons 'lecuyer-mrg32k3a
(cons 'lecuyer-mrg32k3a
(vector->list (mrg32k3a-unpack-state packed-state))))
(define: (mrg32k3a-state-set [external-state : (Listof Nb)]) : State
@ -299,7 +299,7 @@
; Pseudo-Randomization
; ====================
;
; Reference [1] above shows how to obtain many long streams and
; Reference [1] above shows how to obtain many long streams and
; substream from the backbone generator.
;
; The idea is that the generator is a linear operation on the state.
@ -312,7 +312,7 @@
; For the implementation it is necessary to compute with matrices in
; the ring (Z/(m1*m1)*Z)^(3x3). By the Chinese-Remainder Theorem, this
; is isomorphic to ((Z/m1*Z) x (Z/m2*Z))^(3x3). We represent such a pair
; of matrices
; of matrices
; [ [[x00 x01 x02],
; [x10 x11 x12],
; [x20 x21 x22]], mod m1
@ -324,9 +324,9 @@
; y00 y01 y02 y10 y11 y12 y20 y21 y22)
;
; As the implementation should only use the range {-2^53..2^53-1}, the
; fundamental operation (x*y) mod m, where x, y, m are nearly 2^32,
; is computed by breaking up x and y as x = x1*w + x0 and y = y1*w + y0
; where w = 2^16. In this case, all operations fit the range because
; fundamental operation (x*y) mod m, where x, y, m are nearly 2^32,
; is computed by breaking up x and y as x = x1*w + x0 and y = y1*w + y0
; where w = 2^16. In this case, all operations fit the range because
; w^2 mod m is a small number. If proper multiprecision integers are
; available this is not necessary, but pseudo-randomize! is an expected
; to be called only occasionally so we do not provide this implementation.
@ -336,10 +336,10 @@
(define: mrg32k3a-initial-state : (Vectorof Nb); 0 3 6 9 12 15 of A^16, see below
'#( 1062452522
2961816100
342112271
2854655037
3321940838
2961816100
342112271
2854655037
3321940838
3542344109))
(define: mrg32k3a-generators : (Listof State) '(#(0 0 0 0 0)) ) ; computed when needed -> Changer #f by a State to hava right type.
@ -365,22 +365,22 @@
(b2h (quotient (vector-ref B j2) w))
(b2l (modulo (vector-ref B j2) w)))
(modulo
(+ (* (+ (* a0h b0h)
(* a1h b1h)
(* a2h b2h))
(+ (* (+ (* a0h b0h)
(* a1h b1h)
(* a2h b2h))
w-sqr)
(* (+ (* a0h b0l)
(* (+ (* a0h b0l)
(* a0l b0h)
(* a1h b1l)
(* a1h b1l)
(* a1l b1h)
(* a2h b2l)
(* a2h b2l)
(* a2l b2h))
w)
(* a0l b0l)
(* a1l b1l)
(* a2l b2l))
m)))
(vector
(lc 0 1 2 0 3 6 mrg32k3a-m1 w-sqr1) ; (A*B)_00 mod m1
(lc 0 1 2 1 4 7 mrg32k3a-m1 w-sqr1) ; (A*B)_01
@ -426,7 +426,7 @@
0 1 0))
; check arguments
(when (not (and (integer? i)
(when (not (and (integer? i)
(exact? i)
(integer? j)
(exact? j)))
@ -441,12 +441,12 @@
(power A 16))))
; compute M = A^(16 + i*2^127 + j*2^76)
(let ((M (product
(let ((M (product
(list-ref mrg32k3a-generators 2)
(product
(power (list-ref mrg32k3a-generators 0)
(modulo i (expt 2 28)))
(power (list-ref mrg32k3a-generators 1)
(power (list-ref mrg32k3a-generators 1)
(modulo j (expt 2 28)))))))
(mrg32k3a-pack-state
(vector
@ -494,8 +494,8 @@
; Large Integers
; ==============
;
; To produce large integer random deviates, for n > m-max, we first
; construct large random numbers in the range {0..m-max^k-1} for some
; To produce large integer random deviates, for n > m-max, we first
; construct large random numbers in the range {0..m-max^k-1} for some
; k such that m-max^k >= n and then use the rejection method to choose
; uniformly from the range {0..n-1}.
@ -509,7 +509,7 @@
(mrg32k3a-random-integer state mrg32k3a-m-max))))
(define: (mrg32k3a-random-large [state : State] [n : Nb]) : Nb ; n > m-max
(do: : Integer ((k : Integer 2 (+ k 1))
(do: : Integer ((k : Integer 2 (+ k 1))
(mk : Integer (* mrg32k3a-m-max mrg32k3a-m-max) (* mk mrg32k3a-m-max)))
((>= mk n)
(let* ((mk-by-n (quotient mk n))
@ -559,31 +559,31 @@
(lambda: ([n : Nb])
(cond
((not (and (integer? n) (exact? n) (positive? n)))
(error "range must be exact positive integer" n))
(error "range must be exact positive integer" n))
((<= n mrg32k3a-m-max)
(mrg32k3a-random-integer state n))
(else
(mrg32k3a-random-large state n)))))
(lambda: [args : Nb *]
(lambda: [args : Nb *]
(cond
((null? args)
(lambda ()
(lambda ()
(mrg32k3a-random-real state)))
((null? (cdr args))
(let: ((unit : Flt (car args)))
(cond
((not (and (real? unit) (< 0 unit 1)))
((not (and (real? unit) (< 0 unit 1)))
(error "unit must be real in (0,1)" unit))
((<= (- (/ 1 unit) 1) mrg32k3a-m1)
(lambda: ()
(lambda: ()
(mrg32k3a-random-real state)))
(else
(lambda: ()
(lambda: ()
(mrg32k3a-random-real-mp state unit))))))
(else
(error "illegal arguments" args)))))))
(define: random-source? : (Any -> Boolean : Random)
(define: random-source? : (Any -> Boolean : Random)
:random-source?)
(define: (random-source-state-ref [s : Random]) : SpList

6
collects/tests/typed-scheme/succeed/rec-types.rkt
View File

@ -10,7 +10,7 @@
(define-typed-struct (a) heap ([compare : comparator]))
(define-typed-struct (a) (heap-empty heap) ())
(define-typed-struct (a) (heap-node heap)
(define-typed-struct (a) (heap-node heap)
([rank : number] [elm : a] [left : (Un (heap-node a) (heap-empty a))] [right : (Un (heap-node a) (heap-empty a))]))
(define-type-alias (Heap a) (Un (heap-empty a) (heap-node a)))
@ -18,7 +18,7 @@
(pdefine: (b) (heap-size [h : (Heap b)]) : number
(cond [(heap-empty? h) 0]
[(heap-node? h)
[(heap-node? h)
(+ 1 (+ (heap-size (heap-node-left h))
(heap-size (heap-node-right h))))]
;; FIXME - shouldn't need else clause
@ -27,7 +27,7 @@
(define-typed-struct npheap ([compare : comparator]))
(define-typed-struct (npheap-empty npheap) ())
(define-typed-struct (npheap-node npheap)
(define-typed-struct (npheap-node npheap)
([rank : number] [elm : symbol] [left : (Un npheap-node npheap-empty)] [right : (Un npheap-node npheap-empty)]))
(define-type-alias npHeap (Un npheap-empty npheap-node))

6
collects/tests/typed-scheme/succeed/seasoned-schemer.rkt
View File

@ -1,4 +1,4 @@
#lang typed-scheme
#lang typed-scheme
#;(require mzlib/etc)
#;(require "prims.ss")
(require mzlib/match)
@ -70,7 +70,7 @@
(pick 2 (cons 'a (cons 'd (cons 'c #{'() : (list-of symbol)}))))
(define: (multirember [a : atom] [l : lat]) : lat
(letrec ([#{mr : (lat -> lat)}
(letrec ([#{mr : (lat -> lat)}
(lambda: ([l : lat])
(cond [(null? l) l]
[(eq? a (car l)) (mr (cdr l))]
@ -82,7 +82,7 @@
(cond [(null? l) l]
[(f a (car l)) (mr (cdr l))]
[else (cons (car l) (mr (cdr l)))]))
#;(letrec ([#{mr : ((list-of e) -> (list-of e))}
#;(letrec ([#{mr : ((list-of e) -> (list-of e))}
(lambda: ([l : (list-of e)])
(cond [(null? l) l]
[(f a (car l)) (mr (cdr l))]

2
collects/tests/typed-scheme/succeed/simple-or.rkt
View File

@ -4,7 +4,7 @@
(let ([tmp (number? x)]) (if tmp tmp (string? x)))
(if (let ([tmp (number? x)])
(if (let ([tmp (number? x)])
(if tmp tmp (string? x)))
(f x)
0)

4
collects/tests/typed-scheme/succeed/somesystempath.rkt
View File

@ -11,11 +11,11 @@
(unless (path-for-some-system? p)
(error "Predicate failed"))
(explode-path long-path)
(filename-extension p)
(path-only long-path)
(some-system-path->string long-path)
))

4
collects/tests/typed-scheme/succeed/stream.rkt
View File

@ -54,13 +54,13 @@
(: rotate : (All (A) ((Stream A) (Listof A) (Stream A) -> (Stream A))))
(define (rotate frnt rer accum)
(let ([carrer (car rer)])
(let ([carrer (car rer)])
;; Manually expanded `stream-cons', and added type annotations
(if (empty-stream? frnt)
(stream-cons carrer accum)
(stream-cons
(stream-car frnt)
((inst rotate A)
(stream-cdr frnt)
(stream-cdr frnt)
(cdr rer)
(box (lambda () (cons carrer accum))))))))

6
collects/tests/typed-scheme/succeed/struct-cert.rkt
View File

@ -1,13 +1,13 @@
#lang scheme/load
(module for-broken typed-scheme
(define-typed-struct type ())
(provide (all-defined-out)))
(module broken typed-scheme
(require (prefix-in t: 'for-broken))
(define-typed-struct binding ([type : t:type]))
;; Comment out the below and it works fine.

2
collects/tests/typed-scheme/succeed/test.rkt
View File

@ -97,5 +97,5 @@ xxx6-y
(list* 1 2 3)
(ann (list* 1 2 3 (list)) (Pair Number (Listof Integer)))
((lambda (x) 1) 1)
((lambda (x) 1) 1)
((lambda (x y) 1) 1 2)

2
collects/tests/typed-scheme/succeed/time.rkt
View File

@ -15,4 +15,4 @@
(loop 10000000 0))
(parameterize ([current-output-port (open-output-nowhere)])
(time (bar 0)))

2
collects/tests/typed-scheme/succeed/values-dots.rkt
View File

@ -20,7 +20,7 @@
(inst map-with-funcs Integer Integer)
(map-with-funcs
(map-with-funcs
(lambda: ([x : Integer] [y : Integer]) (+ x y))
(lambda: ([x : Integer] [y : Integer]) (- x y)) )

2
collects/tests/typed-scheme/succeed/vec-tests.rkt
View File

@ -1,4 +1,4 @@
#lang typed-scheme
#lang typed-scheme
(define: x : (Vectorof Number) (build-vector 5 (lambda: ([x : Number]) 0)))
(define: y : Number (vector-ref x 1))

10
collects/tests/typed-scheme/unit-tests/all-tests.rkt
View File

@ -1,9 +1,9 @@
#lang scheme/base
(require
(require
"test-utils.ss"
"typecheck-tests.ss" ;;fail
"subtype-tests.ss" ;; pass
"type-equal-tests.ss" ;; pass
"remove-intersect-tests.ss" ;; pass
@ -11,7 +11,7 @@
"subst-tests.ss" ;; pass
"infer-tests.ss" ;; pass
"type-annotation-test.ss" ;; pass
"module-tests.ss" ;; pass
"contract-tests.ss"
@ -23,10 +23,10 @@
(infer-param infer)
(define unit-tests
(make-test-suite
(make-test-suite
"Unit Tests"
(for/list ([f (list
typecheck-tests
typecheck-tests
subtype-tests
type-equal-tests
restrict-tests

4
collects/tests/typed-scheme/unit-tests/contract-tests.rkt
View File

@ -1,9 +1,9 @@
#lang scheme/base
(require "test-utils.ss"
(require "test-utils.ss"
(for-syntax scheme/base)
(for-template scheme/base)
(private type-contract)
(private type-contract)
(rep type-rep filter-rep object-rep)
(types utils union convenience)
(utils tc-utils)

6
collects/tests/typed-scheme/unit-tests/infer-tests.rkt
View File

@ -26,7 +26,7 @@
[fv-t (-poly (b c d e) (-v a)) a]
[fv-t (-mu a (-lst a))]
[fv-t (-mu a (-lst (-pair a (-v b)))) b]
[fv-t (->* null (-v a) -Number) a] ;; check that a is CONTRAVARIANT
))
@ -45,7 +45,7 @@
(define (f t1 t2) (infer t1 t2 (fv t1) (fv t1)))
(define-syntax-rule (i2-f t1 t2)
(test-false (format "~a ~a" t1 t2)
(test-false (format "~a ~a" t1 t2)
(f t1 t2)))
#|
(define (i2-tests)
@ -55,7 +55,7 @@
[i2-t (-lst (-v a)) (-pair N (-pair N (-val null))) ('a N)]
[i2-t (-lst (-v a)) (-pair N (-pair B (-val null))) ('a (Un N B))]
[i2-t Univ (Un N B)]
[i2-t ((-v a) . -> . (-v b)) (-> N N) ('b N) ('a N)]
[i2-l (list (-v a) (-v a) (-v b)) (list (Un (-val 1) (-val 2)) N N) '(a b) ('b N) ('a N)]
[i2-l (list (-> (-v a) Univ) (-lst (-v a))) (list (-> N (Un N B)) (-lst N)) '(a) ('a N)]

14
collects/tests/typed-scheme/unit-tests/parse-type-tests.rkt
View File

@ -23,7 +23,7 @@
;; The solution is to add the identifiers to the table at phase 0.
;; We do this by going through the table, constructing new identifiers based on the symbol
;; of the old identifier.
;; This relies on the identifiers being bound at phase 0 in this module (which they are,
;; This relies on the identifiers being bound at phase 0 in this module (which they are,
;; because we have a phase 0 require of "base-env.ss").
(for ([pr (type-alias-env-map cons)])
(let ([nm (car pr)]
@ -61,9 +61,9 @@
(define B -Boolean)
(define Sym -Symbol)
(define (parse-type-tests)
(define (parse-type-tests)
(pt-tests
"parse-type tests"
"parse-type tests"
[Number N]
[Any Univ]
[(List Number String) (-Tuple (list N -String))]
@ -105,13 +105,13 @@
[#f (-val #f)]
["foo" (-val "foo")]
['(1 2 3) (-Tuple (map -val '(1 2 3)))]
[(Listof Number) (make-Listof N)]
[a (-v a) (set-add initial-tvar-env 'a)]
[(All (a ...) (a ... -> Number))
(-polydots (a) ((list) [a a] . ->... . N))]
[(Any -> Boolean : Number) (make-pred-ty -Number)]
[(Any -> Boolean : #:+ (Number @ 0) #:- (! Number @ 0))
(make-pred-ty -Number)]
@ -121,7 +121,7 @@
(t:-> -Number (t:-> -Number -Number))]
[(Integer -> (All (X) (X -> X)))
(t:-> -Integer (-poly (x) (t:-> x x)))]
))
;; FIXME - add tests for parse-values-type, parse-tc-results

4
collects/tests/typed-scheme/unit-tests/planet-requires.rkt
View File

@ -3,13 +3,13 @@
(require (for-syntax scheme/base scheme/require-transform)
scheme/require-syntax)
(define-for-syntax (splice-requires specs)
(define-for-syntax (splice-requires specs)
(define subs (map (compose cons expand-import) specs))
(values (apply append (map car subs)) (apply append (map cdr subs))))
(define-syntax define-module
(syntax-rules ()
[(_ nm spec ...)
[(_ nm spec ...)
(define-syntax nm
(make-require-transformer
(lambda (stx)

26
collects/tests/typed-scheme/unit-tests/remove-intersect-tests.rkt
View File

@ -5,7 +5,7 @@
(types convenience subtype union remove-intersect)
rackunit)
(define-syntax (over-tests stx)
(define-syntax (over-tests stx)
(syntax-case stx ()
[(_ [t1 t2 res] ...)
#'(test-suite "Tests for intersect"
@ -15,7 +15,7 @@
(over-tests
[-Number -Integer #t]))
(define-syntax (restr-tests stx)
(define-syntax (restr-tests stx)
(syntax-case stx ()
[(_ [t1 t2 res] ...)
#'(test-suite "Tests for intersect"
@ -23,7 +23,7 @@
(infer-param infer)
(define (restrict-tests)
(define (restrict-tests)
(restr-tests
[-Number (Un -Number -Symbol) -Number]
[-Number -Number -Number]
@ -32,7 +32,7 @@
[(Un -Number -Boolean) (-mu a (Un -Number -Symbol (make-Listof a))) -Number]
[(-mu x (Un -Number (make-Listof x))) (Un -Symbol -Number -Boolean) -Number]
[(Un -Number -String -Symbol -Boolean) -Number -Number]
[(-lst -Number) (-pair Univ Univ) (-pair -Number (-lst -Number))]
;; FIXME
#;
@ -41,7 +41,7 @@
[-Sexp -Listof (-lst -Sexp)]
))
(define-syntax (remo-tests stx)
(define-syntax (remo-tests stx)
(syntax-case stx ()
[(_ [t1 t2 res] ...)
(syntax/loc stx
@ -55,7 +55,7 @@
[(-mu x (Un -Number -Symbol (make-Listof x))) -Number (Un -Symbol (make-Listof (-mu x (Un -Number -Symbol (make-Listof x)))))]
[(-mu x (Un -Number -Symbol -Boolean (make-Listof x))) -Number (Un -Symbol -Boolean (make-Listof (-mu x (Un -Number -Symbol -Boolean (make-Listof x)))))]
[(Un (-val #f) (-mu x (Un -Number -Symbol (make-Listof (-v x)))))
(Un -Boolean -Number)
(Un -Boolean -Number)
(Un -Symbol (make-Listof (-mu x (Un -Number -Symbol (make-Listof x)))))]
[(Un (-val 'foo) (-val 6)) (Un -Number -Symbol) (Un)]
[(-> (Un -Symbol -Number) -Number) (-> -Number -Number) (Un)]
@ -64,19 +64,19 @@
[(-pair -Number (-v a)) (-pair Univ Univ) (Un)]
))
(define-go
(define-go
restrict-tests
remove-tests
overlap-tests)
(define x1
(-mu list-rec
(Un
(-val '())
(define x1
(-mu list-rec
(Un
(-val '())
(-pair (-mu x (Un -Boolean -Number -String -Symbol (-val '()) (-pair x x)))
list-rec))))
(define x2
(Un (-val '())
(define x2
(Un (-val '())
(-pair (-mu x (Un -Boolean -Number -String -Symbol (-val '()) (-pair x x)))
(-mu x (Un -Boolean -Number -String -Symbol (-val '()) (-pair x x))))))
(provide remove-tests restrict-tests overlap-tests)

2
collects/tests/typed-scheme/unit-tests/subst-tests.rkt
View File

@ -17,7 +17,7 @@
(s... (-Number -Boolean) a (make-Function (list (make-arr-dots null -Number (-v a) 'a))) (-Number -Boolean . -> . -Number))
(s... (-Number -Boolean) a (make-Function (list (make-arr-dots (list -String) -Number (-v a) 'a))) (-String -Number -Boolean . -> . -Number))
(s... (-Number -Boolean) a (make-Function (list (make-arr-dots (list -String) -Number (-v b) 'a))) (-String (-v b) (-v b) . -> . -Number))
(s... (-Number -Boolean) a (make-Function (list (make-arr-dots (list -String) -Number (-v b) 'b)))
(s... (-Number -Boolean) a (make-Function (list (make-arr-dots (list -String) -Number (-v b) 'b)))
(make-Function (list (make-arr-dots (list -String) -Number (-v b) 'b))))))
(define-go subst-tests)

16
collects/tests/typed-scheme/unit-tests/subtype-tests.rkt
View File

@ -45,7 +45,7 @@
[(Un (-val 6) (-val 7)) -Number]
[(Un (-val #f) (Un (-val 6) (-val 7))) (Un -Number (Un -Boolean -Symbol))]
[(Un (-val #f) (Un (-val 6) (-val 7))) (-mu x (Un -Number (Un -Boolean -Symbol)))]
[(Un -Number (-val #f) (-mu x (Un -Number -Symbol (make-Listof x))))
[(Un -Number (-val #f) (-mu x (Un -Number -Symbol (make-Listof x))))
(-mu x (Un -Number -Symbol -Boolean (make-Listof x)))]
;; sexps vs list*s of nums
[(-mu x (Un -Number -Symbol (make-Listof x))) (-mu x (Un -Number -Symbol -Boolean (make-Listof x)))]
@ -69,7 +69,7 @@
;; polymorphic types
[(-poly (t) (-> t t)) (-poly (s) (-> s s))]
[FAIL (make-Listof -Number) (-poly (t) (make-Listof t))]
[(-poly (a) (make-Listof (-v a))) (make-Listof -Number)] ;;
[(-poly (a) (make-Listof (-v a))) (make-Listof -Number)] ;;
[(-poly (a) -Number) -Number]
[(-val 6) -Number]
@ -109,11 +109,11 @@
[(-Number) a]))
(cl-> [() (-pair -Number (-v b))]
[(-Number) (-pair -Number (-v b))])]
[(-values (list -Number)) (-values (list Univ))]
[(-poly (b) ((Un (make-Base 'foo #'dummy values #'values)
(-struct 'bar #f
(-struct 'bar #f
(list (make-fld -Number #'values #f) (make-fld b #'values #f))
#'values))
. -> . (-lst b)))
@ -121,12 +121,12 @@
. -> . (-lst (-pair -Number (-v a))))]
[(-poly (b) ((-struct 'bar #f (list (make-fld -Number #'values #f) (make-fld b #'values #f)) #'values) . -> . (-lst b)))
((-struct 'bar #f (list (make-fld -Number #'values #f) (make-fld (-pair -Number (-v a)) #'values #f)) #'values) . -> . (-lst (-pair -Number (-v a))))]
[(-poly (a) (a . -> . (make-Listof a))) ((-v b) . -> . (make-Listof (-v b)))]
[(-poly (a) (a . -> . (make-Listof a))) ((-pair -Number (-v b)) . -> . (make-Listof (-pair -Number (-v b))))]
(FAIL (-poly (a b) (-> a a)) (-poly (a b) (-> a b)))
;; polymorphic function types should be subtypes of the function top
[(-poly (a) (a . -> . a)) top-func]
(FAIL (-> Univ) (null Univ . ->* . Univ))
@ -137,5 +137,5 @@
[(-struct 'a #f (list (make-fld -String #'values #f)) #'values) (-struct 'a #f (list (make-fld Univ #'values #f)) #'values)]
))
(define-go
(define-go
subtype-tests)

4
collects/tests/typed-scheme/unit-tests/test-utils.rkt
View File

@ -19,7 +19,7 @@
(define (run . ts)
(run-tests (mk-suite ts)))
(define (test/gui suite)
(define (test/gui suite)
(((dynamic-require 'rackunit/private/gui/gui 'make-gui-runner))
suite))
@ -30,7 +30,7 @@
(define-syntax (define-go stx)
(syntax-case stx ()
[(_ args ...)
(with-syntax
(with-syntax
([go (datum->syntax stx 'go)]
[go/gui (datum->syntax stx 'go/gui)]
[(tmps ...) (generate-temporaries #'(args ...))])

4
collects/tests/typed-scheme/unit-tests/type-annotation-test.rkt
View File

@ -12,7 +12,7 @@
(provide type-annotation-tests)
(define-syntax-rule (tat ann-stx ty)
(check-tc-result-equal? (format "~a" (quote ann-stx))
(check-tc-result-equal? (format "~a" (quote ann-stx))
(type-ascription (let ([ons (current-namespace)]
[ns (make-base-namespace)])
(parameterize ([current-namespace ns])
@ -23,7 +23,7 @@
ty))
(define (type-annotation-tests)
(test-suite
(test-suite
"Type Annotation tests"
;; FIXME - ask Ryan
(tat (ann foo : Number) (ret -Number (make-NoFilter) (make-NoObject)))

8
collects/tests/typed-scheme/unit-tests/type-equal-tests.rkt
View File

@ -36,14 +36,14 @@
[(Un -Number -Symbol -Boolean) (Un -Boolean (Un -Symbol -Number))]
[(Un -Number -Symbol) (Un -Symbol -Number)]
[(-poly (x) (-> (Un -Symbol -Number) x)) (-poly (xyz) (-> (Un -Number -Symbol) xyz))]
[(-mu x (Un -Number -Symbol x)) (-mu y (Un -Number -Symbol y))]
[(-mu x (Un -Number -Symbol x)) (-mu y (Un -Number -Symbol y))]
;; found bug
[FAIL (Un (-mu heap-node
[FAIL (Un (-mu heap-node
(-struct 'heap-node #f
(map fld* (list (-base 'comparator) -Number (-v a) (Un heap-node (-base 'heap-empty))))
#'values))
#'values))
(-base 'heap-empty))
(Un (-mu heap-node
(Un (-mu heap-node
(-struct 'heap-node #f
(map fld* (list (-base 'comparator) -Number (-pair -Number -Number) (Un heap-node (-base 'heap-empty)))) #'values))
(-base 'heap-empty))]))

250
collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt
View File

@ -27,9 +27,9 @@
base-env-indexing base-special-env))
racket/file
(for-template
(base-env #;base-env base-types base-types-extra
#;base-env-numeric
#;base-env-numeric
base-special-env
base-env-indexing))
(for-syntax syntax/kerncase syntax/parse))
@ -38,7 +38,7 @@
(prefix-in n: (base-env base-env-numeric)))
(provide typecheck-tests g tc-expr/expand)
(b:init) (n:init) (initialize-structs) (initialize-indexing) (initialize-special)
(define N -Number)
@ -93,12 +93,12 @@
(define-syntax (tc-e stx)
(syntax-case stx ()
[(_ expr ty) (syntax/loc stx (tc-e expr #:ret (ret ty)))]
[(_ expr #:proc p)
(quasisyntax/loc stx
[(_ expr #:proc p)
(quasisyntax/loc stx
(let-values ([(t e) (tc-expr/expand/values expr)])
#,(quasisyntax/loc stx (check-tc-result-equal? (format "~a ~s" #,(syntax-line stx) 'expr) (t) (p e)))))]
[(_ expr #:ret r)
(quasisyntax/loc stx
[(_ expr #:ret r)
(quasisyntax/loc stx
(check-tc-result-equal? (format "~a ~a" #,(syntax-line stx) 'expr) (tc-expr/expand expr) r))]
[(_ expr ty f o) (syntax/loc stx (tc-e expr #:ret (ret ty f o)))]))
@ -121,7 +121,7 @@
(syntax-rules ()
[(_ expr)
(test-exn (format "~a" 'expr)
exn:fail:syntax?
exn:fail:syntax?
(lambda () (tc-expr/expand expr)))]))
(define-syntax-class (let-name n)
@ -136,12 +136,12 @@
e]))
(define (typecheck-tests)
(test-suite
(test-suite
"Typechecker tests"
#reader typed-scheme/typed-reader
(test-suite
"tc-expr tests"
[tc-e
(let: ([x : (U Number (cons Number Number)) (cons 3 4)])
(if (pair? x)
@ -200,7 +200,7 @@
[tc-e/t (case-lambda: [([a : Number] [b : Number]) (+ a b)]) (t:-> N N N)]
[tc-e (let: ([x : Number 5]) x) N]
[tc-e (let-values ([(x) 4]) (+ x 1)) -PosIndex]
[tc-e (let-values ([(#{x : Number} #{y : Boolean}) (values 3 #t)]) (and (= x 1) (not y)))
[tc-e (let-values ([(#{x : Number} #{y : Boolean}) (values 3 #t)]) (and (= x 1) (not y)))
#:proc (syntax-parser [(_ ([(_ y) . _]) . _) (ret -Boolean (-FS -top -top))])]
[tc-e/t (values 3) -PosByte]
[tc-e (values) #:ret (ret null)]
@ -247,7 +247,7 @@
[tc-e/t (if #f #f #t) (t:Un (-val #t))]
[tc-e (when #f 3) -Void]
[tc-e/t '() (-val '())]
[tc-e/t (let: ([x : (Listof Number) '(1)])
[tc-e/t (let: ([x : (Listof Number) '(1)])
(cond [(pair? x) 1]
[(null? x) 1]))
-One]
@ -258,74 +258,74 @@
[tc-e (apply (lambda: ([x : Number] . [y : Number *]) (car y)) 3 '(4)) N]
[tc-e (apply (lambda: ([x : Number] . [y : Number *]) (car y)) 3 '(4 6 7)) N]
[tc-e (apply (lambda: ([x : Number] . [y : Number *]) (car y)) 3 '()) N]
[tc-e/t (lambda: ([x : Number] . [y : Boolean *]) (car y)) (->* (list N) B B)]
[tc-e ((lambda: ([x : Number] . [y : Boolean *]) (car y)) 3) B]
[tc-e (apply (lambda: ([x : Number] . [y : Boolean *]) (car y)) 3 '(#f)) B]
[tc-e/t (let: ([x : Number 3])
(when (number? x) #t))
(-val #t)]
[tc-e (let: ([x : Number 3])
(when (boolean? x) #t))
-Void]
[tc-e/t (let: ([x : Any 3])
(if (list? x)
(begin (car x) 1)
2))
-PosByte]
[tc-e (let: ([x : (U Number Boolean) 3])
(if (not (boolean? x))
(add1 x)
3))
N]
[tc-e (let ([x 1]) x) -One]
[tc-e (let ([x 1]) (boolean? x)) #:ret (ret -Boolean (-FS -bot -top))]
[tc-e (boolean? number?) #:ret (ret -Boolean (-FS -bot -top))]
[tc-e (let: ([x : (Option Number) #f]) x) (t:Un N (-val #f))]
[tc-e (let: ([x : Any 12]) (not (not x))) -Boolean]
[tc-e (let: ([x : (Option Number) #f])
(if (let ([z 1]) x)
(add1 x)
12))
12))
N]
[tc-err (5 4)]
[tc-err (apply 5 '(2))]
[tc-err (map (lambda: ([x : Any] [y : Any]) 1) '(1))]
[tc-e (map add1 '(1)) (-pair -PosByte (-lst -PosByte))]
[tc-e/t (let ([x 5])
(if (eq? x 1)
12
14))
-PosByte]
[tc-e (car (append (list 1 2) (list 3 4))) -PosByte]
[tc-e
(let-syntax ([a
[tc-e
(let-syntax ([a
(syntax-rules ()
[(_ e) (let ([v 1]) e)])])
(let: ([v : String "a"])
(string-append "foo" (a v))))
-String]
[tc-e (apply (plambda: (a) [x : a *] x) '(5)) (-lst -PosByte)]
[tc-e (apply append (list '(1 2 3) '(4 5 6))) (-lst -PosByte)]
[tc-err ((case-lambda: [([x : Number]) x]
[([y : Number] [x : Number]) x])
1 2 3)]
[tc-err ((case-lambda: [([x : Number]) x]
[([y : Number] [x : Number]) x])
1 'foo)]
[tc-err (apply
(case-lambda: [([x : Number]) x]
[([y : Number] [x : Number]) x])
@ -334,38 +334,38 @@
(case-lambda: [([x : Number]) x]
[([y : Number] [x : Number]) x])
'(1 foo))]
[tc-e (let: ([x : Any #f])
(if (number? (let ([z 1]) x))
(add1 x)
12))
N]
[tc-e (let: ([x : (Option Number) #f])
(if x
(add1 x)
12))
12))
N]
[tc-e null #:ret (-path (-val null) #'null)]
[tc-e (let* ([sym 'squarf]
[x (if (= 1 2) 3 sym)])
x)
(t:Un (-val 'squarf) -PosByte)]
[tc-e/t (if #t 1 2) -One]
;; eq? as predicate
[tc-e (let: ([x : (Un 'foo Number) 'foo])
(if (eq? x 'foo) 3 x))
(if (eq? x 'foo) 3 x))
#:proc (get-let-name x 0 (ret N (-FS -top -top)))]
[tc-e (let: ([x : (Un 'foo Number) 'foo])
(if (eq? 'foo x) 3 x))
#:proc (get-let-name x 0 (ret N (-FS -top -top)))]
[tc-err (let: ([x : (U String 'foo) 'foo])
(if (string=? x 'foo)
"foo"
@ -375,7 +375,7 @@
"foo"
x))
(t:Un -String (-val 5))]
[tc-e (let* ([sym 'squarf]
[x (if (= 1 2) 3 sym)])
(if (eq? x sym) 3 x))
@ -393,7 +393,7 @@
[tc-e (let: ([x : (Un 'foo Number) 'foo])
(if (equal? 'foo x) 3 x))
#:proc (get-let-name x 0 (ret N (-FS -top -top)))]
[tc-e (let* ([sym 'squarf]
[x (if (= 1 2) 3 sym)])
(if (equal? x sym) 3 x))
@ -404,66 +404,66 @@
(if (equal? sym x) 3 x))
#:proc (syntax-parser [(_ _ (_ ([(x) _]) _))
(ret -PosByte (-FS -top -top))])]
[tc-e (let: ([x : (Listof Symbol)'(a b c)])
(cond [(memq 'a x) => car]
[else 'foo]))
Sym]
[tc-e (list 2 3 4) (-lst* -PosByte -PosByte -PosByte)]
[tc-e (list 2 3 4 'a) (-lst* -PosByte -PosByte -PosByte (-val 'a))]
[tc-e `(1 2 ,(+ 3 4)) (-lst* -One -PosByte -PosIndex)]
[tc-e (let: ([x : Any 1])
(when (and (list? x) (not (null? x)))
(car x)))
Univ]
[tc-err (let: ([x : Any 3])
(car x))]
[tc-err (car #{3 : Any})]
[tc-err (map #{3 : Any} #{12 : Any})]
[tc-err (car 3)]
[tc-e/t (let: ([x : Any 1])
(if (and (list? x) (not (null? x)))
x
'foo))
(t:Un (-val 'foo) (-pair Univ (-lst Univ)))]
[tc-e (cadr (cadr (list 1 (list 1 2 3) 3))) -PosByte]
;;; tests for and
[tc-e (let: ([x : Any 1]) (and (number? x) (boolean? x)))
[tc-e (let: ([x : Any 1]) (and (number? x) (boolean? x)))
#:ret (ret B (-FS -bot -top))]
[tc-e (let: ([x : Any 1]) (and (number? x) x))
#:proc (get-let-name x 0 (ret (t:Un N (-val #f)) (-FS -top -top)))]
[tc-e (let: ([x : Any 1]) (and x (boolean? x)))
#:proc (get-let-name x 0 (ret -Boolean (-FS -top -top)))]
[tc-e/t (let: ([x : Any 3])
(if (and (list? x) (not (null? x)))
(begin (car x) 1) 2))
-PosByte]
;; set! tests
[tc-e (let: ([x : Any 3])
(set! x '(1 2 3))
(if (number? x) x 2))
Univ]
;; or tests - doesn't do anything good yet
#;
[tc-e (let: ([x : Any 3])
(if (or (boolean? x) (number? x))
(if (boolean? x) 12 x)
47))
Univ]
;; test for fake or
[tc-e (let: ([x : Any 1])
(if (if (number? x)
@ -487,13 +487,13 @@
(boolean? x))
(if (boolean? x) 1 x)
4))
#:proc (get-let-name
x 0
#:proc (get-let-name
x 0
(ret Univ
(-FS
(-FS
-top
(-and (make-NotTypeFilter -Boolean null #'x) (make-TypeFilter (-val #f) null #'x)))))]
;; T-AbsPred
[tc-e/t (let ([p? (lambda: ([x : Any]) (number? x))])
(lambda: ([x : Any]) (if (p? x) (add1 x) (add1 12))))
@ -522,9 +522,9 @@
[p? (lambda: ([x : Any]) z)])
(lambda: ([x : Any]) (if (p? x) x 12)))
(t:-> Univ Univ)]
[tc-e (not 1) #:ret (ret B (-FS -bot -top))]
[tc-err ((lambda () 1) 2)]
[tc-err (apply (lambda () 1) '(2))]
[tc-err ((lambda: ([x : Any] [y : Any]) 1) 2)]
@ -532,33 +532,33 @@
[tc-err ((plambda: (a) ([x : (a -> a)] [y : a]) (x y)) 5)]
[tc-err ((plambda: (a) ([x : a] [y : a]) x) 5)]
[tc-err (ann 5 : String)]
;; these don't work because the type annotation gets lost in marshalling
#|
[tc-e (letrec-syntaxes+values () ([(#{x : Number}) (values 1)]) (add1 x)) N]
[tc-e (letrec-values ([(#{x : Number}) (values 1)]) (add1 x)) N]
[tc-e (letrec ([#{x : Number} (values 1)]) (add1 x)) N]
|#
[tc-e (letrec: ([x : Number (values 1)]) (add1 x)) N]
[tc-err (let ([x (add1 5)])
(set! x "foo")
x)]
x)]
;; w-c-m
[tc-e/t (with-continuation-mark 'key 'mark
[tc-e/t (with-continuation-mark 'key 'mark
3)
-PosByte]
[tc-err (with-continuation-mark (5 4) 1
3)]
[tc-err (with-continuation-mark 1 (5 4)
[tc-err (with-continuation-mark 1 (5 4)
3)]
[tc-err (with-continuation-mark 1 2 (5 4))]
;; call-with-values
[tc-e (call-with-values (lambda () (values 1 2))
(lambda: ([x : Number] [y : Number]) (+ x y)))
N]
@ -567,7 +567,7 @@
N]
[tc-err (call-with-values (lambda () 1)
(lambda: () 2))]
[tc-err (call-with-values (lambda () (values 2))
(lambda: ([x : Number] [y : Number]) (+ x y)))]
[tc-err (call-with-values 5
@ -579,7 +579,7 @@
;; quote-syntax
[tc-e/t #'3 (-Syntax -PosByte)]
[tc-e/t #'(2 3 4) (-Syntax (-lst* -PosByte -PosByte -PosByte))]
;; testing some primitives
[tc-e (let ([app apply]
[f (lambda: [x : Number *] 3)])
@ -587,26 +587,26 @@
-PosByte]
[tc-e ((lambda () (call/cc (lambda: ([k : (Number -> (U))]) (if (read) 5 (k 10))))))
N]
[tc-e (number->string 5) -String]
[tc-e (let-values ([(a b) (quotient/remainder 5 12)]
[(a*) (quotient 5 12)]
[(b*) (remainder 5 12)])
(+ a b a* b*))
-Nat]
[tc-e (raise-type-error 'foo "bar" 5) (t:Un)]
[tc-e (raise-type-error 'foo "bar" 7 (list 5)) (t:Un)]
#;[tc-e
(let ((x '(1 3 5 7 9)))
(do: : Number ((x : (list-of Number) x (cdr x))
(sum : Number 0 (+ sum (car x))))
((null? x) sum)))
N]
;; inference with internal define
[tc-e (let ()
(define x 1)
@ -614,7 +614,7 @@
(define z (+ x y))
(* x z))
-PosIndex]
[tc-e/t (let ()
(define: (f [x : Number]) : Number
(define: (g [y : Number]) : Number
@ -623,7 +623,7 @@
(g 4))
5)
-PosByte]
[tc-err (let ()
(define x x)
1)]
@ -631,45 +631,45 @@
(define (x) (y))
(define (y) (x))
1)]
[tc-err (let ()
(define (x) (y))
(define (y) 3)
1)]
[tc-e ((case-lambda:
[[x : Number *] (+ 1 (car x))])
5)
N]
#;
[tc-e `(4 ,@'(3)) (-pair N (-lst N))]
[tc-e
(let ((x '(1 3 5 7 9)))
(do: : Number ((x : (Listof Number) x (cdr x))
(sum : Number 0 (+ sum (car x))))
((null? x) sum)))
#:ret (ret N (-FS -top -top) (make-NoObject))]
[tc-e/t (if #f 1 'foo) (-val 'foo)]
[tc-e (list* 1 2 3) (-pair -One (-pair -PosByte -PosByte))]
[tc-err (apply append (list 1) (list 2) (list 3) (list (list 1) "foo"))]
[tc-e (apply append (list 1) (list 2) (list 3) (list (list 1) (list 1))) (-lst -PosByte)]
[tc-e (apply append (list 1) (list 2) (list 3) (list (list 1) (list "foo"))) (-lst (t:Un -String -PosByte))]
[tc-err (plambda: (b ...) [y : b ... b] (apply append (map list y)))]
[tc-e/t (plambda: (b ...) [y : (Listof Integer) ... b] (apply append y))
(-polydots (b) (->... (list) ((-lst -Integer) b) (-lst -Integer)))]
[tc-err (plambda: (a ...) ([z : String] . [w : Number ... a])
(apply (plambda: (b) ([x : Number] . [y : Number ... a]) x)
1 1 1 1 w))]
[tc-err (plambda: (a ...) ([z : String] . [w : Number])
(apply (plambda: (b) ([x : Number] . [y : Number ... a]) x)
1 w))]
[tc-e/t (plambda: (a ...) ([z : String] . [w : Number ... a])
(apply (plambda: (b ...) ([x : Number] . [y : Number ... b]) x)
1 w))
@ -685,7 +685,7 @@
#:object (make-Path null 0))))]
[tc-e/t (inst (plambda: (a) [x : a *] (apply list x)) Integer)
((list) -Integer . ->* . (-lst -Integer))]
;; instantiating dotted terms
[tc-e/t (inst (plambda: (a ...) [xs : a ... a] 3) Integer Boolean Integer)
(-Integer B -Integer . t:-> . -PosByte : -true-lfilter)]
@ -694,26 +694,26 @@
(-Integer B -Integer . t:-> . -Integer)
(-Integer B -Integer . t:-> . -Integer)
. t:-> . -PosByte : -true-filter)]
[tc-e/t (plambda: (z x y ...) () (inst map z x y ... y))
(-polydots (z x y) (t:-> (cl->*
((t:-> x z) (-pair x (-lst x)) . t:-> . (-pair z (-lst z)))
((list ((list x) (y y) . ->... . z) (-lst x)) ((-lst y) y) . ->... . (-lst z)))
: (-FS (-not-filter (-val #f) #'map) (-filter (-val #f) #'map))))]
;; error tests
[tc-err (#%variable-reference number?)]
[tc-err (+ 3 #f)]
[tc-err (let: ([x : Number #f]) x)]
[tc-err (let: ([x : Number #f]) (+ 1 x))]
[tc-err
(let: ([x : Any '(foo)])
(if (null? x) 1
(if (list? x)
(add1 x)
(if (list? x)
(add1 x)
12)))]
[tc-err (let*: ([x : Any 1]
[f : (-> Void) (lambda () (set! x 'foo))])
(if (number? x)
@ -724,13 +724,13 @@
(if (number? (not (not x)))
(add1 x)
12))]
[tc-e (filter exact-integer? (list 1 2 3 'foo))
(-lst -Integer)]
[tc-e (filter even? (filter exact-integer? (list 1 2 3 'foo)))
(-lst -Integer)]
#|
[tc-err (plambda: (a ...) [as : a ... a]
(apply fold-left (lambda: ([c : Integer] [a : Char] . [xs : a ... a]) c)
@ -741,12 +741,12 @@
[tc-err (plambda: (a ...) [as : a ... a]
(apply fold-left (lambda: ([c : Integer] [a : Char] . [xs : a ... a]) c)
3 (list #\c) (map list (map list as))))]
[tc-e/t (plambda: (a ...) [as : a ... a]
(apply fold-left (lambda: ([c : Integer] [a : Char] . [xs : a ... a]) c)
3 (list #\c) (map list as)))
(-polydots (a) ((list) (a a) . ->... . -Integer))]|#
;; First is same as second, but with map explicitly instantiated.
[tc-e/t (plambda: (a ...) [ys : (a ... a -> Number) *]
(lambda: [zs : a ... a]
@ -761,45 +761,45 @@
(apply y zs))
ys)))
(-polydots (a) ((list) ((list) (a a) . ->... . N) . ->* . ((list) (a a) . ->... . (-lst N)) : -true-lfilter))]
[tc-e/t (lambda: ((x : (All (t) t)))
((inst (inst x (All (t) (t -> t)))
((inst (inst x (All (t) (t -> t)))
(All (t) t))
x))
((-poly (a) a) . t:-> . (-poly (a) a))]
;; We need to make sure that even if a isn't free in the dotted type, that it gets replicated
;; appropriately.
[tc-e/t (inst (plambda: (a ...) [ys : Number ... a]
(apply + ys))
Boolean String Number)
(N N N . t:-> . N)]
[tc-e (assq 'foo #{'((a b) (foo bar)) :: (Listof (List Symbol Symbol))})
(t:Un (-val #f) (-pair Sym (-pair Sym (-val null))))]
[tc-e/t (ann (lambda (x) x) (All (a) (a -> a)))
(-poly (a) (a . t:-> . a))]
[tc-e (apply values (list 1 2 3)) #:ret (ret (list -One -PosByte -PosByte))]
[tc-e/t (ann (if #t 3 "foo") Integer) -Integer]
[tc-e/t (plambda: (a ...) ([x : Number] . [y : a ... a])
(andmap null? (map list y)))
(-polydots (a) ((list -Number) (a a) . ->... . -Boolean))]
[tc-e (ann (error 'foo) (values Number Number)) #:ret (ret (list -Number -Number))]
[tc-e (string->number "123")
(t:Un (-val #f) -Number)]
[tc-e #{(make-hash) :: (HashTable Number Number)}
(make-Hashtable -Number -Number)]
#;[tc-err (let: ([fact : (Number -> Number) (lambda: ([n : Number]) (if (zero? n) 1 (* n (fact (- n 1)))))])
(fact 20))]
[tc-err (ann (lambda: ([x : Any]) #f) (Any -> Boolean : String))]
[tc-e (time (+ 3 4)) -PosIndex]
@ -809,7 +809,7 @@
(lambda: ([v : (Listof Number)]
[cpu : Number]
[user : Number]
[gc : Number])
[gc : Number])
'whatever))
#:ret (ret (-val 'whatever) -true-filter)]
[tc-e (let: ([l : (Listof Any) (list 1 2 3)])
@ -817,9 +817,9 @@
(+ 1 (car l))
7))
-Number]
(tc-e (or (string->number "7") 7)
(tc-e (or (string->number "7") 7)
#:ret (ret -Number -true-filter))
[tc-e (let ([x 1]) (if x x (add1 x)))
[tc-e (let ([x 1]) (if x x (add1 x)))
#:ret (ret -One (-FS -top -top))]
[tc-e (let: ([x : (U (Vectorof Number) String) (vector 1 2 3)])
(if (vector? x) (vector-ref x 0) (string-length x)))
@ -831,7 +831,7 @@
[tc-e (let ()
(define: x : Any 7)
(if (box? x) (unbox x) (+ 1)))
Univ]
Univ]
[tc-e (floor 1/2) -Nat]
[tc-e (ceiling 1/2) -PosInt]
[tc-e (truncate 0.5) -NonNegFlonum]
@ -864,7 +864,7 @@
[tc-e ((inst map Number (Pairof Number Number)) car (ann (list (cons 1 2) (cons 2 3) (cons 4 5)) (Listof (Pairof Number Number))))
(-lst -Number)]
[tc-err (list (values 1 2))]
#| ;; should work but don't (test harness problems)
[tc-e (for/list ([(k v) (in-hash #hash((1 . 2)))]) 0) (-lst -Zero)]
[tc-e (in-list (list 1 2 3)) (-seq -Integer)]
@ -968,7 +968,7 @@
(tc-e (not #f) #:ret (ret B (-FS -top -bot)))
(tc-e (false? #f) #:ret (ret B (-FS -top -bot)))
(tc-e (not #t) #:ret (ret B (-FS -bot -top)))
;; It's not clear why the following test doesn't work,
;; It's not clear why the following test doesn't work,
;; but it works fine in the real typechecker
;(tc-e (false? #t) #:ret (ret B (-FS -bot -top)))
@ -1051,7 +1051,7 @@
(tc-e (find-system-path 'home-dir) -Path)
(tc-e (path-list-string->path-list "/bin:/sbin:/usr/bin" null) (-lst -Path))
(tc-e (find-executable-path "racket" "collects" #t) (-opt -Path))
(tc-e (file-exists? "/usr") B)
(tc-e (link-exists? "/usr") B)
(tc-e (delete-file "does-not-exist") -Void)
@ -1158,7 +1158,7 @@
(tc-e (make-handle-get-preference-locked .3 'sym (lambda () 'eseh) 'timestamp #f #:lock-there #f #:max-delay .45)
(t:-> -Pathlike ManyUniv))
(tc-e (call-with-file-lock/timeout #f 'exclusive (lambda () 'res) (lambda () 'err)
(tc-e (call-with-file-lock/timeout #f 'exclusive (lambda () 'res) (lambda () 'err)
#:get-lock-file (lambda () "lock")
#:delay .01
#:max-delay .2) (one-of/c 'res 'err))

2
collects/tests/typed-scheme/xfail/priority-queue.scm
View File

@ -63,7 +63,7 @@
;; "bug" found - handling of empty heaps
(pdefine: (a) (find-min [pq : (priority-queue a)]) : a
(pdefine: (a) (find-min [pq : (priority-queue a)]) : a
(let ([h (heap pq)])
(if (heap:heap-node? h)
(elm (heap:find-min h))

4
collects/typed-scheme/base-env/base-env-indexing-abs.rkt
View File

@ -102,7 +102,7 @@
[-StrRx (Un -String -Regexp)]
[-BtsRx (Un -Bytes -Byte-Regexp)])
((Un -BtsRx -StrRx) -Input-Port [N ?N ?outp -Bytes] . ->opt . (optlist -Bytes)))]
[regexp-match-positions
(let* ([?outp (-opt -Output-Port)]
@ -119,7 +119,7 @@
[N index-type]
[?N (-opt index-type)]
[ind-pair (-pair -Index -Index)]
[output (-lst ind-pair)]
[output (-lst ind-pair)]
[-Input (Un -String -Input-Port -Bytes -Path)])
(->opt -Pattern -Input [N ?N ?outp -Bytes] output))]

4
collects/typed-scheme/base-env/base-env-numeric.rkt
View File

@ -1838,8 +1838,8 @@
[unsafe-flmin flmin-type]
[unsafe-flmax flmax-type]
;These are currently the same binding as the safe versions
;and so are not needed. If this changes they should be
;These are currently the same binding as the safe versions
;and so are not needed. If this changes they should be
;uncommented. There is a check in the definitions part of
;the file that makes sure that they are the same binding.
;

18
collects/typed-scheme/base-env/base-env.rkt
View File

@ -446,7 +446,7 @@
;thread-suspend-evt
;Section 10.1.4
[thread-send (-poly (a)
[thread-send (-poly (a)
(cl->*
(-> -Thread Univ -Void)
(-> -Thread Univ (-val #f) (-opt -Void))
@ -575,7 +575,7 @@
;; Section 3.7
;; Regular Expressions
;; Regular Expressions
[regexp? (make-pred-ty -Regexp)]
[pregexp? (make-pred-ty -PRegexp)]
@ -2128,7 +2128,7 @@
[open-input-string (-> -String -Input-Port)]
[open-input-bytes (-> -Bytes -Input-Port)]
[open-output-string
[open-output-string
([Univ] . ->opt . -Output-Port)]
[open-output-bytes
([Univ] . ->opt . -Output-Port)]
@ -2215,9 +2215,9 @@
[open-output-nowhere (-> -Output-Port)]
[peeking-input-port (->opt -Input-Port [Univ -Nat] -Input-Port)]
[reencode-input-port
[reencode-input-port
(->opt -Input-Port -String (-opt -Bytes) [Univ Univ Univ (-> -String -Input-Port ManyUniv)] -Input-Port)]
[reencode-output-port
[reencode-output-port
(->opt -Output-Port -String (-opt -Bytes) [Univ Univ (-opt -Bytes) (-> -String -Output-Port ManyUniv)] -Output-Port)]
[dup-input-port (-Input-Port (B) . ->opt . -Input-Port)]
@ -2449,7 +2449,7 @@
;12.9.1
[readtable? (make-pred-ty -Read-Table)]
[make-readtable
[make-readtable
(cl->*
(-> -Read-Table -Read-Table)
(-> -Read-Table
@ -2469,14 +2469,14 @@
(Un -Char (one-of/c 'terminating-macro 'non-terminating-macro))
(-opt (Un (-> -Char -Input-Port (-opt -PosInt) (-opt -Nat)
(-opt -PosInt) (-opt -Nat) Univ)
(cl->*
(cl->*
(-> -Char -Input-Port (-opt -PosInt) (-opt -Nat)
(-opt -PosInt) (-opt -Nat) Univ)
(-> -Char -Input-Port Univ))))
(-> -Char -Input-Port Univ))))
(-opt (Un (-> -Char -Input-Port (-opt -PosInt) (-opt -Nat)
(-opt -PosInt) (-opt -Nat) Univ)
(cl->*
(cl->*
(-> -Char -Input-Port (-opt -PosInt) (-opt -Nat)
(-opt -PosInt) (-opt -Nat) Univ)

8
collects/typed-scheme/scribblings/guide/begin.scrbl
View File

@ -8,7 +8,7 @@
@title[#:tag "beginning"]{Beginning Typed Racket}
Recall the typed module from @secref["quick"]:
Recall the typed module from @secref["quick"]:
@|typed-mod|
@ -21,7 +21,7 @@ This specifies that the module is written in the
@racketmodname[racket] language. Typed versions of other languages
are provided as well; for example, the
@racketmodname[typed/racket/base] language corresponds to
@racketmodname[racket/base].
@racketmodname[racket/base].
@racketblock[(struct: pt ([x : Real] [y : Real]))]
@ -98,7 +98,7 @@ In order to calculate interesting facts about trees, we have to take
them apart and get at their contents. But since accessors such as
@racket[node-left] require a @racket[node] as input, not a
@racket[Tree], we have to determine which kind of input we
were passed.
were passed.
For this purpose, we use the predicates that come with each defined
structure. For example, the @racket[leaf?] predicate distinguishes
@ -117,7 +117,7 @@ process of elimination we can determine that @racket[t] must be a
@section{Type Errors}
When Typed Racket detects a type error in the module, it raises an
error before running the program.
error before running the program.
@examples[#:eval the-eval
(add1 "not a number")

18
collects/typed-scheme/scribblings/guide/more.scrbl
View File

@ -49,7 +49,7 @@ in both top-level and internal contexts.
Here, @racket[x] has the type @racket[Number], and @racket[id] has the
type @racket[(Number -> Number)]. In the body of @racket[id],
@racket[z] has the type @racket[Number].
@racket[z] has the type @racket[Number].
@subsection{Annotating Local Binding}
@ -75,7 +75,7 @@ The @racket[let*-values:] and @racket[letrec-values:] forms are similar.
Function expressions also bind variables, which can be annotated with
types. This function expects two arguments, a @racket[Number] and a
@racket[String]:
@racket[String]:
@racketblock[(lambda: ([x : Number] [y : String]) (+ x 5))]
@ -91,8 +91,8 @@ Functions defined by cases may also be annotated:
@racketblock[(case-lambda: [() 0]
[([x : Number]) x])]
This function has the type
@racket[(case-lambda (-> Number) (Number -> Number))].
This function has the type
@racket[(case-lambda (-> Number) (Number -> Number))].
@subsection{Annotating Single Variables}
@ -107,13 +107,13 @@ especially useful for binding forms which do not have counterparts
provided by Typed Racket, such as @racket[let+]:
@racketblock[
(let+ ([val #,(annvar x Number) (+ 6 1)])
(let+ ([val #,(annvar x Number) (+ 6 1)])
(* x x))]
@subsection{Annotating Expressions}
It is also possible to provide an expected type for a particular
expression.
expression.
@racketblock[(ann (+ 7 1) Number)]
@ -133,7 +133,7 @@ infer them. For example, the types of all local bindings using
@racketblock[(let ([x 7]) (add1 x))]
In this example, @racket[x] has the type
@racket[Exact-Positive-Integer].
@racket[Exact-Positive-Integer].
Similarly, top-level constant definitions do not require annotation:
@ -142,7 +142,7 @@ Similarly, top-level constant definitions do not require annotation:
In this examples, @racket[y] has the type @racket[String].
Finally, the parameter types for loops are inferred from their initial
values.
values.
@racketblock[
(let loop ([x 0] [y (list 1 2 3)])
@ -154,7 +154,7 @@ variable has type @racket[(Integer (Listof Integer) -> Integer)].
@section{New Type Names}
Any type can be given a name with @racket[define-type].
Any type can be given a name with @racket[define-type].
@racketblock[(define-type NN (Number -> Number))]

4
collects/typed-scheme/scribblings/guide/quick.scrbl
View File

@ -8,11 +8,11 @@
Given a module written in the @racketmodname[racket] language, using
Typed Racket requires the following steps:
@itemize[#:style
@itemize[#:style
'ordered
@item{Change the language to @racketmodname[typed/racket].}
@item{Change the uses of @racket[(require mod)] to
@racket[(require typed/mod)].}
@racket[(require typed/mod)].}
@item{Annotate structure definitions and top-level
definitions with their types.} ]

16
collects/typed-scheme/scribblings/guide/types.scrbl
View File

@ -10,7 +10,7 @@
@title[#:tag "types"]{Types in Typed Racket}
Typed Racket provides a rich variety of types to describe data. This
section introduces them.
section introduces them.
@section{Basic Types}
@ -74,7 +74,7 @@ each of these types.
@section{Union Types}
Sometimes a value can be one of several types. To specify this, we
can use a union type, written with the type constructor @racket[U].
can use a union type, written with the type constructor @racket[U].
@interaction[#:eval the-eval
(let ([a-number 37])
@ -83,7 +83,7 @@ can use a union type, written with the type constructor @racket[U].
'no))]
Any number of types can be combined together in a union, and nested
unions are flattened.
unions are flattened.
@racketblock[(U Number String Boolean Char)]
@ -91,7 +91,7 @@ unions are flattened.
@deftech{Recursive types} can refer to themselves. This allows a type
to describe an infinite family of data. For example, this is the type
of binary trees of numbers.
of binary trees of numbers.
@racketblock[
(define-type BinaryTree (Rec BT (U Number (Pair BT BT))))]
@ -103,7 +103,7 @@ refers to the whole binary tree type within the body of the
@section{Structure Types}
Using @racket[struct:] introduces new types, distinct from any
previous type.
previous type.
@racketblock[(struct: point ([x : Real] [y : Real]))]
@ -165,7 +165,7 @@ of @racket[l], which looks like a function application. In fact, it's
a use of the @italic{type constructor} @racket[Listof], which takes
another type as its input, here @racket[Number]. We can use
@racket[Listof] to construct the type of any kind of list we might
want.
want.
We can define our own type constructors as well. For example, here is
an analog of the @tt{Maybe} type constructor from Haskell:
@ -185,7 +185,7 @@ typed/racket
]
The first @racket[struct:] defines @racket[None] to be
a structure with no contents.
a structure with no contents.
The second definition
@ -209,7 +209,7 @@ container for whatever type is supplied.
The @racket[find] function takes a number @racket[v] and list, and
produces @racket[(Some v)] when the number is found in the list,
and @racket[(None)] otherwise. Therefore, it produces a
@racket[(Opt Number)], just as the annotation specified.
@racket[(Opt Number)], just as the annotation specified.
@subsection{Polymorphic Functions}

4
collects/typed-scheme/scribblings/guide/varargs.scrbl
View File

@ -64,7 +64,7 @@ corresponds to the type of the corresponding argument of @racket[f].
We also know that, in order to avoid arity errors, the length of
@racket[bss] must be one less than the arity of @racket[f] (as
@racket[as] corresponds to the first argument of @racket[f]).
The example uses of @racket[map] evaluate to @racketresult[(list 2 3 4 5)],
@racketresult[(list (list 1 4) (list 2 5) (list 3 6))], and
@racketresult[(list 10 14 18)].
@ -73,7 +73,7 @@ In Typed Racket, we can define @racket[map] as follows:
@racketmod[
typed/racket
(: map
(: map
(All (C A B ...)
((A B ... B -> C) (Listof A) (Listof B) ... B
->

2
collects/typed-scheme/scribblings/reference/compatibility-languages.scrbl
View File

@ -11,7 +11,7 @@ languages. The @racketmod[typed-scheme] language is equivalent to the
@racketmod[typed/scheme/base] language.
@(declare-exporting typed/scheme/base typed/scheme typed-scheme
#:use-sources
#:use-sources
(typed-scheme/typed-scheme
typed-scheme/base-env/prims
typed-scheme/base-env/extra-procs

2
collects/typed-scheme/scribblings/reference/legacy.scrbl
View File

@ -6,7 +6,7 @@
@title{Legacy Forms}
The following forms are provided by Typed Racket for backwards
compatibility.
compatibility.
@defidform[define-type-alias]{Equivalent to @racket[define-type].}
@defidform[define-typed-struct]{Equivalent to @racket[define-struct:]}

6
collects/typed-scheme/scribblings/reference/libraries.scrbl
View File

@ -12,7 +12,7 @@
The @racketmodname[typed/racket] language corresponds to the
@racketmodname[racket] language---that is, any identifier provided
by @racketmodname[racket], such as @racket[modulo] is available by default in
@racketmodname[typed/racket].
@racketmodname[typed/racket].
@racketmod[typed/racket
(modulo 12 2)
@ -24,7 +24,7 @@ The @racketmodname[typed/racket/base] language corresponds to the
Some libraries have counterparts in the @racketidfont{typed}
collection, which provide the same exports as the untyped versions.
Such libraries include @racketmodname[srfi/14],
@racketmodname[net/url], and many others.
@racketmodname[net/url], and many others.
@racketmod[typed/racket
(require typed/srfi/14)
@ -32,7 +32,7 @@ Such libraries include @racketmodname[srfi/14],
(string->char-set "olleh"))
]
To participate in making more libraries available, please visit
To participate in making more libraries available, please visit
@link["http://www.ccs.neu.edu/home/samth/adapt/"]{here}.

60
collects/typed-scheme/scribblings/reference/special-forms.scrbl
View File

@ -56,10 +56,10 @@ result of @racket[_loop] (and thus the result of the entire
@ex[(: filter-even-loop : (Listof Natural) -> (Listof Natural))
(define (filter-even-loop lst)
(let: loop : (Listof Natural)
(let: loop : (Listof Natural)
([accum : (Listof Natural) null]
[lst : (Listof Natural) lst])
(cond
(cond
[(null? lst) accum]
[(even? (car lst)) (loop (cons (car lst) accum) (cdr lst))]
[else (loop accum (cdr lst))])))
@ -84,7 +84,7 @@ Type-annotated versions of
@section{Anonymous Functions}
@defform/subs[(lambda: formals . body)
([formals ([v : t] ...)
([formals ([v : t] ...)
([v : t] ... . [v : t *])
([v : t] ... . [v : t ...])])]{
A function of the formal arguments @racket[v], where each formal
@ -99,13 +99,13 @@ of the formal, and in any type expressions in the @racket[body].}
@defform[(case-lambda: [formals body] ...)]{
A function of multiple arities. Note that each @racket[formals] must have a
different arity.
@ex[(define add-map
@ex[(define add-map
(case-lambda:
[([lst : (Listof Integer)])
(map add1 lst)]
[([lst1 : (Listof Integer)]
[lst2 : (Listof Integer)])
(map + lst1 lst2)]))]
(map + lst1 lst2)]))]
For the type declaration of @racket[add-map] look at @racket[case-lambda].}
@defform[(pcase-lambda: (a ...) [formals body] ...)]{
@ -199,7 +199,7 @@ These are identical to @|for-id| and @|for*-id|, but provide additional annotati
expr ...+)
([step-expr-maybe code:blank
step-expr])]{
Like @racket[do], but each @racket[id] having the associated type @racket[t], and
Like @racket[do], but each @racket[id] having the associated type @racket[t], and
the final body @racket[expr] having the type @racket[u]. Type
annotations are optional.
}
@ -208,7 +208,7 @@ annotations are optional.
@section{Definitions}
@defform*[[(define: v : t e)
(define: (f . formals) : t . body)
(define: (f . formals) : t . body)
(define: (a ...) (f . formals) : t . body)]]{
These forms define variables, with annotated types. The first form
defines @racket[v] with type @racket[t] and value @racket[e]. The
@ -218,12 +218,12 @@ types. In most cases, use of @racket[:] is preferred to use of @racket[define:]
@ex[(define: foo : Integer 10)
(define: (add [first : Integer]
[rest : Integer]) : Integer
[rest : Integer]) : Integer
(+ first rest))
(define: (A) (poly-app [func : (A A -> A)]
(define: (A) (poly-app [func : (A A -> A)]
[first : A]
[rest : A]) : A
[rest : A]) : A
(func first rest))]}
@ -248,13 +248,13 @@ Options provided have the same meaning as for the @racket[struct] form.}
(define-struct: maybe-type-vars name-spec ([f : t] ...) options ...)
([maybe-type-vars code:blank (v ...)]
[name-spec name (name parent)]
[options #:transparent #:mutable])]{Legacy version of @racket[struct:],
[options #:transparent #:mutable])]{Legacy version of @racket[struct:],
corresponding to @racket[define-struct].}
@defform/subs[
(define-struct/exec: name-spec ([f : t] ...) [e : proc-t])
([name-spec name (name parent)])]{
Like @racket[define-struct:], but defines a procedural structure.
Like @racket[define-struct:], but defines a procedural structure.
The procdure @racket[e] is used as the value for @racket[prop:procedure], and must have type @racket[proc-t].}
@section{Names for Types}
@ -272,7 +272,7 @@ cycles among them are prohibited.
@section{Generating Predicates Automatically}
@defform[(define-predicate name t)]{
Defines @racket[name] as a predicate for the type @racket[t].
@racket[name] has the type @racket[(Any -> Boolean : t)].
@racket[name] has the type @racket[(Any -> Boolean : t)].
@racket[t] may not contain function types.}
@ -300,11 +300,11 @@ also be used.}
appropriate number of type variables. This is legal only in expression
contexts.
@ex[(foldl (inst cons Integer Integer) null (list 1 2 3 4))]
@ex[(: fold-list : (All (A) (Listof A) -> (Listof A)))
(define (fold-list lst)
(foldl (inst cons A A) null lst))
(fold-list (list "1" "2" "3" "4"))]
The syntax @litchar|{#{e @ t ...}}| may also be used.
@ -327,7 +327,7 @@ naming a predicate, and @racket[_r] is an optionally-renamed identifier.
(code:line #:constructor-name constructor-id)
(code:line #:extra-constructor-name constructor-id)])]
{This form requires identifiers from the module @racket[m], giving
them the specified types.
them the specified types.
The first form requires @racket[r], giving it type @racket[t].
@ -343,12 +343,12 @@ Racket.
@ex[(module UNTYPED racket/base
(define n 100)
(struct IntTree
(elem left right))
(provide n (struct-out IntTree)))
(module TYPED typed/racket
(require/typed 'UNTYPED
[n Natural]
@ -360,31 +360,31 @@ Racket.
@index["opaque"]{The fourth case} defines a new type @racket[t]. @racket[pred], imported from
module @racket[m], is a predicate for this type. The type is defined
as precisely those values to which @racket[pred] produces
@racket[#t]. @racket[pred] must have type @racket[(Any -> Boolean)].
@racket[#t]. @racket[pred] must have type @racket[(Any -> Boolean)].
Opaque types must be required lexically before they are used.
In all cases, the identifiers are protected with @rtech{contracts} which
enforce the specified types. If this contract fails, the module
@racket[m] is blamed.
@racket[m] is blamed.
Some types, notably polymorphic types constructed with @racket[All],
cannot be converted to contracts and raise a static error when used in
a @racket[require/typed] form. Here is an example of using
a @racket[require/typed] form. Here is an example of using
@racket[case->] in @racket[require/typed].
@(racketblock
(require/typed racket/base
[file-or-directory-modify-seconds
[file-or-directory-modify-seconds
(case->
[String -> Exact-Nonnegative-Integer]
[String (Option Exact-Nonnegative-Integer)
->
[String (Option Exact-Nonnegative-Integer)
->
(U Exact-Nonnegative-Integer Void)]
[String (Option Exact-Nonnegative-Integer) (-> Any)
[String (Option Exact-Nonnegative-Integer) (-> Any)
->
Any])]))
@racket[file-or-directory-modify-seconds] has some arguments which are optional,
@racket[file-or-directory-modify-seconds] has some arguments which are optional,
so we need to use @racket[case->].}
@section{Other Forms}
@ -395,7 +395,7 @@ Identical to @|with-handlers-id|, but provides additional annotations to help th
@defform[(#%module-begin form ...)]{
Legal only in a @rtech{module begin context}.
Legal only in a @rtech{module begin context}.
The @racket[#%module-begin] form of @racketmodname[typed/racket] checks all the
forms in the module, using the Typed Racket type checking rules. All
@racket[provide] forms are rewritten to insert contracts where appropriate.

6
collects/typed-scheme/scribblings/reference/typed-regions.scrbl
View File

@ -22,13 +22,13 @@ The @racket[with-type] for allows for localized Typed Racket regions in otherwis
The first form, an expression, checks that @racket[body ...+] has the type @racket[type].
If the last expression in @racket[body ...+] returns multiple values, @racket[type] must
be a type of the form @racket[(values t ...)].
Uses of the result values are appropriately checked by contracts generated from
Uses of the result values are appropriately checked by contracts generated from
@racket[type].
The second form, which can be used as a definition, checks that each of the @racket[export-id]s
The second form, which can be used as a definition, checks that each of the @racket[export-id]s
has the specified type. These types are also enforced in the surrounding code with contracts.
The @racket[id]s are assumed to
The @racket[id]s are assumed to
have the types ascribed to them; these types are converted to contracts and checked dynamically.
@examples[#:eval the-eval

20
collects/typed-scheme/scribblings/reference/types.scrbl
View File

@ -21,7 +21,7 @@ any expression of this type will not evaluate to a value.}
@section{Base Types}
@(define-syntax-rule
@(define-syntax-rule
(defnums (ids ...) . rest)
(deftogether ((defidform ids) ...) . rest))
@ -217,7 +217,7 @@ The following base types are parameteric in their type arguments.
@defform[(Listof t)]{Homogenous @rtech{lists} of @racket[t]}
@defform[(List t ...)]{is the type of the list with one element, in order,
@defform[(List t ...)]{is the type of the list with one element, in order,
for each type provided to the @racket[List] type constructor.}
@defform/none[(#,(racket List) t ... trest #,(racket ...) bound)]{is the type of a list with
one element for each of the @racket[t]s, plus a sequence of elements
@ -238,7 +238,7 @@ corresponding to @racket[trest], where @racket[bound]
@ex[(box "hello world")]
@defform[(Vectorof t)]{Homogenous @rtech{vectors} of @racket[t]}
@defform[(Vector t ...)]{is the type of the list with one element, in order,
@defform[(Vector t ...)]{is the type of the list with one element, in order,
for each type provided to the @racket[Vector] type constructor.}
@defidform[FlVector]{An @rtech{flvector}.}
@ -262,12 +262,12 @@ corresponding to @racket[trest], where @racket[bound]
}
@defform*[[(Parameterof t)
(Parameterof s t)]]{A @rtech{parameter} of @racket[t]. If two type arguments are supplied,
(Parameterof s t)]]{A @rtech{parameter} of @racket[t]. If two type arguments are supplied,
the first is the type the parameter accepts, and the second is the type returned.
@ex[current-input-port
current-directory]
}
@defform[(Promise t)]{A @rtech{promise} of @racket[t].
@ex[(delay 3)]}
@ -316,7 +316,7 @@ of type @racket[Syntax-E].}
@defform[(Ephemeronof t)]{An @rtech{ephemeron} whose value is of type @racket[t].}
@section{Other Type Constructors}
@section{Other Type Constructors}
@defform*[#:id -> #:literals (* ...)
[(dom ... -> rng)
@ -328,10 +328,10 @@ of type @racket[Syntax-E].}
third form specifies a non-uniform rest argument of type
@racket[rest] with bound @racket[bound]. In the third form, the
second occurrence of @racket[...] is literal, and @racket[bound]
must be an identifier denoting a type variable. In the fourth form,
there must be only one @racket[dom] and @racket[pred] is the type
must be an identifier denoting a type variable. In the fourth form,
there must be only one @racket[dom] and @racket[pred] is the type
checked by the predicate.
@ex[(λ: ([x : Number]) x)
(λ: ([x : Number] . [y : String *]) (length y))
ormap
@ -373,7 +373,7 @@ name or a type variable}
@defform[(Rec n t)]{is a recursive type where @racket[n] is bound to the
recursive type in the body @racket[t]
@ex[(define-type IntList (Rec List (Pair Integer (U List Null))))
(define-type (List A) (Rec List (Pair A (U List Null))))]}
@defalias[→ ->]

2
collects/typed-scheme/scribblings/reference/utilities.scrbl
View File

@ -17,7 +17,7 @@ Typed Racket provides some additional utility functions to facilitate typed prog
[(assert [v A] [p? (A -> Any : B)]) B])]{
Verifies that the argument satisfies the constraint. If no predicate
is provided, simply checks that the value is not
@racket[#f].
@racket[#f].
}
@examples[#:eval the-top-eval

2
collects/typed-scheme/scribblings/ts-guide.scrbl
View File

@ -11,7 +11,7 @@
Typed Racket is a family of languages, each of which enforce
that programs written in the language obey a type system that ensures
the absence of many common errors. This guide is intended for programmers familiar
the absence of many common errors. This guide is intended for programmers familiar
with Racket. For an introduction to Racket, see the @(other-manual '(lib "scribblings/guide/guide.scrbl")).
@local-table-of-contents[]

4
collects/typed-scheme/scribblings/ts-reference.scrbl
View File

@ -1,12 +1,12 @@
#lang scribble/manual
@title[#:tag "top"]{The Typed Racket Reference}
@title[#:tag "top"]{The Typed Racket Reference}
@author[@author+email["Sam Tobin-Hochstadt" "samth@racket-lang.org"]
@author+email["Vincent St-Amour" "stamourv@racket-lang.org"]]
@(defmodulelang* (typed/racket/base typed/racket)
#:use-sources
#:use-sources
(typed-scheme/typed-scheme
typed-scheme/base-env/prims
typed-scheme/base-env/extra-procs

2
collects/typed-scheme/typecheck/tc-expr-unit.rkt
View File

@ -409,7 +409,7 @@
(begin (tc-exprs (syntax->list #'es))
(tc-expr #'e))]
;; other
[_
[_
(printf "~s\n" (continuation-mark-set->context (current-continuation-marks)))
(tc-error/expr #:return (ret (Un)) "cannot typecheck unknown form : ~a\n" (syntax->datum form))]))

2
collects/typed-scheme/typecheck/tc-toplevel.rkt
View File

@ -157,7 +157,7 @@
;; define-syntaxes just get noted
[(define-syntaxes (var:id ...) . rest)
(map make-def-stx-binding (syntax->list #'(var ...)))]
;; otherwise, do nothing in this pass
;; handles expressions, provides, requires, etc and whatnot
[_ (list)])))

14
collects/typed-scheme/types/abbrev.rkt
View File

@ -131,18 +131,18 @@
(define -Base-Regexp (make-Base 'Base-Regexp
#'(and/c regexp? (not/c pregexp?))
(conjoin regexp? (negate pregexp?))
#'-Regexp))
#'-Regexp))
(define -PRegexp (make-Base 'PRegexp
#'pregexp?
pregexp?
#'-PRegexp))
#'pregexp?
pregexp?
#'-PRegexp))
(define -Regexp (*Un -PRegexp -Base-Regexp))
(define -Byte-Base-Regexp (make-Base 'Byte-Regexp
#'(and/c byte-regexp? (not/c byte-pregexp?))
(conjoin byte-regexp? (negate byte-pregexp?))
#'-Byte-Regexp))
(define -Byte-PRegexp (make-Base 'Byte-PRegexp #'byte-pregexp? byte-pregexp? #'-Byte-PRegexp))
#'-Byte-Regexp))
(define -Byte-PRegexp (make-Base 'Byte-PRegexp #'byte-pregexp? byte-pregexp? #'-Byte-PRegexp))
(define -Byte-Regexp (*Un -Byte-Base-Regexp -Byte-PRegexp))
(define -Pattern (*Un -Bytes -Regexp -Byte-Regexp -String))
@ -194,7 +194,7 @@
;return type of functions
;FIXME
;This is not correct as Univ is only a single value.
(define ManyUniv Univ)
(define ManyUniv Univ)
(define -Port (*Un -Output-Port -Input-Port))

2
collects/typed-scheme/types/numeric-tower.rkt
View File

@ -233,7 +233,7 @@
(lambda (x)
(and (flonum? (imag-part x))
(flonum? (real-part x)))))
(lambda (x)
(lambda (x)
(and (number? x)
(flonum? (imag-part x))
(flonum? (real-part x))))

4
collects/typed-scheme/utils/arm.rkt
View File

@ -6,7 +6,7 @@
;; For simplicity, protect everything produced by Typed Racket.
(define (arm stx)
(syntax-case stx (module #%plain-module-begin
#%require #%provide begin
#%require #%provide begin
define-values define-syntaxes
define-values-for-syntax)
[(module name initial-import mb)
@ -20,6 +20,6 @@
(quasisyntax/loc stx (define-values ids #,(arm #'expr)))]
[(define-syntaxes ids expr)
(quasisyntax/loc stx (define-syntaxes ids #,(arm #'expr)))]
[(define-values-for-syntax ids expr)
[(define-values-for-syntax ids expr)
(quasisyntax/loc stx (define-values-for-syntax ids #,(arm #'expr)))]
[_ (syntax-arm stx)]))

2
collects/typed/file/gif.rkt
View File

@ -12,5 +12,5 @@
[gif-add-comment ( GIF-Stream String -> Void )]
[gif-end ( GIF-Stream -> Void )]
[quantize ( String -> (values String (Listof (Vectorof Number)) (U #f (Vectorof Number))))])
(provide gif-stream? GIF-Stream)

14
collects/typed/framework/framework.rkt
View File

@ -1,12 +1,12 @@
#lang typed-scheme
(require typed/private/utils typed/mred/mred)
(dt Style-List% (Class ()
(dt Style-List% (Class ()
()
([find-named-style
([find-named-style
(String -> (Instance (Class ()
()
()
([get-font (-> (Instance Font%))]))))])))
(dt Scheme:Text% (Class ()
@ -24,14 +24,14 @@
[get-end-position (-> Number)]
[insert (String Number Number -> Void)])))
(require/typed/provide
(require/typed/provide
framework/framework
[preferences:set-default (Symbol Sexp (Any -> Boolean) -> Void)]
[preferences:set (Symbol Sexp -> Void)]
[editor:get-standard-style-list
[editor:get-standard-style-list
(-> (Instance Style-List%))]
[scheme:text% Scheme:Text%]
[gui-utils:ok/cancel-buttons
[gui-utils:ok/cancel-buttons
((Instance Horizontal-Panel%) ((Instance Button%) (Instance Event%) -> Void) ((Instance Button%) (Instance Event%) -> Void) -> (values Any Any))])
(require/typed/provide "prefs-contract.rkt"

20
collects/typed/mred/mred.rkt
View File

@ -3,24 +3,24 @@
(require typed/private/utils)
(dt Bitmap% (Class (Real Real Boolean)
()
()
([get-width (-> Integer)]
[get-height (-> Integer)])))
(dt Font-List% (Class () () ([find-or-create-font
(dt Font-List% (Class () () ([find-or-create-font
(case-lambda
(Integer Symbol Symbol Symbol -> (Instance Font%))
(Integer String Symbol Symbol Symbol -> (Instance Font%)))])))
(dt Font% (Class () () ([get-face (-> (Option String))]
[get-point-size (-> Integer)])))
(dt Dialog% (Class ()
([parent Any] [width Integer] [label String])
(dt Dialog% (Class ()
([parent Any] [width Integer] [label String])
([show (Any -> Void)])))
(dt Text-Field% (Class ()
(dt Text-Field% (Class ()
([parent Any] [callback Any] [label String])
([get-value (-> String)]
[focus (-> Void)])))
(dt Horizontal-Panel% (Class ()
([parent Any]
([parent Any]
[stretchable-height Any #t]
[alignment (List Symbol Symbol) #t])
()))
@ -71,12 +71,12 @@
(dt Button% (Class () () ()))
(dt Event% (Class () () ()))
(require/typed/provide
(require/typed/provide
scheme/gui
[button% Button%]
[event% Event%]
[the-font-list (Instance Font-List%)]
[dialog% Dialog%]
[the-font-list (Instance Font-List%)]
[dialog% Dialog%]
[text-field% Text-Field%]
[horizontal-panel% Horizontal-Panel%]
[choice% Choice%]
@ -88,6 +88,6 @@
[bitmap% Bitmap%]
[color% Color%]
[snip% Snip%]
[open-input-text-editor
[open-input-text-editor
((Instance Text%) Integer (U 'end Integer) ((Instance Snip%) -> (Instance Snip%)) (Instance Text%) Boolean -> Input-Port)])

Some files were not shown because too many files have changed in this diff Show More