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

Changed optimization order for reals in complex operations.

Browse Source 
Made generated names more informative and updated tests accordingly.

original commit: c653a8e655712d1108bedfff505cb51d9b804005
This commit is contained in:
Vincent St-Amour 2010-08-05 16:42:22 -04:00
commit 918d50b25d
19 changed files with 281 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/tests/typed-scheme/optimizer/generic/float-promotion.rkt
View File

@ -1,4 +1,4 @@
(module float-promotion typed/scheme #:optimize
(require racket/unsafe/ops racket/flonum)
(+ 1 2.0)
(+ (quotient 1 1) 2.0)
(+ (expt 100 100) 2.0))

2
collects/tests/typed-scheme/optimizer/generic/inexact-complex-fixnum.rkt
View File

@ -1,3 +1,3 @@
#lang typed/scheme #:optimize
(require racket/unsafe/ops)
(+ 2 1.0+2.0i 3.0+6.0i)
(+ (quotient 2 1) 1.0+2.0i 3.0+6.0i)

3
collects/tests/typed-scheme/optimizer/generic/invalid-make-polar.rkt Normal file
View File

@ -0,0 +1,3 @@
#lang typed/scheme #:optimize
(make-polar 0 0)

6
collects/tests/typed-scheme/optimizer/generic/literal-int.rkt Normal file
View File

@ -0,0 +1,6 @@
#lang typed/scheme #:optimize
(require racket/unsafe/ops)
(+ 1 2.0)
1

9
collects/tests/typed-scheme/optimizer/generic/make-polar.rkt Normal file
View File

@ -0,0 +1,9 @@
#lang typed/scheme #:optimize
(require racket/unsafe/ops)
;; top level
(make-polar 1.0 1.0)
;; nested
(+ 1.0+2.0i (make-polar 2.0 4.0))

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

@ -84,11 +84,11 @@
[table
`((,a-hits ,b-hits)
(,a-misses ,b-misses))]
[expected (lambda: ([i : Natural] [j : Natural])
[expected (lambda: ([i : Integer] [j : Integer])
(/ (* (row-total i table) (col-total j table)) total-subjects))])
(exact->inexact
(table-sum
(lambda: ([i : Natural] [j : Natural])
(lambda: ([i : Integer] [j : Integer])
(/ (sqr (- (expected i j) (table-ref i j table))) (expected i j)))
table)))))
@ -473,7 +473,7 @@
(show result ))))
;; applies only to the combined metric [or more generally to listof-answer results]
(pdefine: (a b c) (total [experiment-number : Natural] [result : (Result (Listof number) b c)]) : (Listof number)
(pdefine: (a b c) (total [experiment-number : Integer] [result : (Result (Listof number) b c)]) : (Listof number)
(define: (total/s [s : Table]) : number (apply + (list-ref (pivot s) experiment-number)))
(list (total/s (result-seqA result)) (total/s (result-seqB result))))
@ -491,7 +491,7 @@
[(null? l) '()]
[else
(let ([n (length (car l))])
(build-list n (lambda: ([i : Natural]) (map (lambda: ([j : (Listof X)]) (list-ref j i)) l))))]))
(build-list n (lambda: ([i : Integer]) (map (lambda: ([j : (Listof X)]) (list-ref j i)) l))))]))
(define: (sqr [x : Real]) : Real (* x x))
(define: (variance [xs : (Listof Real)]): Real
@ -499,13 +499,13 @@
(/ (apply + (map (lambda: ([x : number]) (sqr (- x avg))) xs))
(sub1 (length xs)))))
(define: (table-ref [i : Natural] [j : Natural] [table : Table]): number
(define: (table-ref [i : Integer] [j : Integer] [table : Table]): number
(list-ref (list-ref table i) j))
(define: (row-total [i : Natural] [table : Table]) : number
(define: (row-total [i : Integer] [table : Table]) : number
(apply + (list-ref table i)))
(define: (col-total [j : Natural] [table : Table]) : number
(define: (col-total [j : Integer] [table : Table]) : number
(apply + (map (lambda: ([x : (Listof number)]) (list-ref x j)) table)))
(define: (table-sum [f : (Natural Natural -> Real)] [table : Table]) : number
(define: (table-sum [f : (Integer Integer -> Real)] [table : Table]) : number
(let ([rows (length table)]
[cols (length (car table))])
(let loop ([i 0] [j 0] [#{sum : Real} 0])

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

@ -61,7 +61,7 @@
[table
`((,a-hits ,b-hits)
(,a-misses ,b-misses))]
[expected (λ: ([i : Natural] [j : Natural])
[expected (λ: ([i : Integer] [j : Integer])
(/ (* (row-total i table) (col-total j table)) total-subjects))])
(exact->inexact
(table-sum
@ -425,7 +425,7 @@
(show result))))
;; applies only to the combined metric [or more generally to listof-answer results]
(: total (All (b c) (Natural (result (Listof Number) b c) -> (Listof Number))))
(: total (All (b c) (Integer (result (Listof Number) b c) -> (Listof Number))))
(define (total experiment-number result)
(: total/s (Table -> Number))
(define (total/s s) (apply + (list-ref (pivot s) experiment-number)))
@ -447,7 +447,7 @@
[(null? l) '()]
[else
(let ([n (length (car l))])
(build-list n (λ: ([i : Natural]) (map (λ: ([j : (Listof X)]) (list-ref j i)) l))))]))
(build-list n (λ: ([i : Integer]) (map (λ: ([j : (Listof X)]) (list-ref j i)) l))))]))
(: variance ((Listof Number) -> Number))
(define (variance xs)
@ -455,16 +455,16 @@
(/ (apply + (map (λ: ([x : Number]) (sqr (- x avg))) xs))
(sub1 (length xs)))))
(: table-ref (Natural Natural Table -> Number))
(: table-ref (Integer Integer Table -> Number))
(define (table-ref i j table)
(list-ref (list-ref table i) j))
(: row-total (Natural Table -> Number))
(: row-total (Integer Table -> Number))
(define (row-total i table)
(apply + (list-ref table i)))
(: col-total (Natural Table -> Number))
(: col-total (Integer Table -> Number))
(define (col-total j table)
(apply + (map (λ: ([x : (Listof Number)]) (list-ref x j)) table)))
(: table-sum ((Natural Natural -> Number) Table -> Number))
(: table-sum ((Integer Integer -> Number) Table -> Number))
(define (table-sum f table)
(let ([rows (length table)]
[cols (length (car table))])

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

@ -154,10 +154,10 @@
[tc-e (void) -Void]
[tc-e (void 3 4) -Void]
[tc-e (void #t #f '(1 2 3)) -Void]
[tc-e/t #(3 4 5) (make-HeterogenousVector (list -Nat -Nat -Nat))]
[tc-e/t #(3 4 5) (make-HeterogenousVector (list -Integer -Integer -Integer))]
[tc-e/t '(2 3 4) (-lst* -PositiveFixnum -PositiveFixnum -PositiveFixnum)]
[tc-e/t '(2 3 #t) (-lst* -PositiveFixnum -PositiveFixnum (-val #t))]
[tc-e/t #(2 3 #t) (make-HeterogenousVector (list -Nat -Nat (-val #t)))]
[tc-e/t #(2 3 #t) (make-HeterogenousVector (list -Integer -Integer (-val #t)))]
[tc-e/t '(#t #f) (-lst* (-val #t) (-val #f))]
[tc-e/t (plambda: (a) ([l : (Listof a)]) (car l))
(make-Poly '(a) (t:-> (make-Listof (-v a)) (-v a)))]

101
collects/tests/typed-scheme/xfail/priority-queue.scm Normal file
View File

@ -0,0 +1,101 @@
#lang typed-scheme
;;; priority-queue.scm -- Jens Axel Søgaard
;;; PURPOSE
; This file implements priority queues on top of
; a heap library.
(define-type-alias number Number)
(define-type-alias boolean Boolean)
(define-type-alias symbol Symbol)
(define-type-alias top Any)
(define-type-alias list-of Listof)
(require (prefix-in heap: "leftist-heap.ss")
(except-in (lib "67.ss" "srfi") number-compare current-compare =? <?)
(only-in "leftist-heap.ss" comparator))
(require/typed number-compare (number number -> number) (lib "67.ss" "srfi"))
(require/typed current-compare (-> (top top -> number)) (lib "67.ss" "srfi"))
(require/typed =? ((top top -> number) top top -> boolean) (lib "67.ss" "srfi"))
(require/typed <? ((top top -> number) top top -> boolean) (lib "67.ss" "srfi"))
; a priority-queue is a heap of (cons <priority> <element>)
(define-type-alias (elem a) (cons number a))
(define-typed-struct (a) priority-queue ([heap : (heap:Heap (elem a))]))
(define-type-alias (pqh a) (heap:Heap (elem a)))
; conveniences
(pdefine: (a) (heap [pq : (priority-queue a)]) : (pqh a) (priority-queue-heap pq))
(pdefine: (a) (pri [p : (elem a)]) : number (car p))
(pdefine: (a) (elm [p : (elem a)]) : a (cdr p))
(pdefine: (a) (make [h : (pqh a)]) : (priority-queue a) (make-priority-queue h))
; sort after priority
; TODO: and then element?
(pdefine: (a) (compare [p1 : (elem a)] [p2 : (elem a)]) : number
(number-compare (pri p1) (pri p2)))
;;; OPERATIONS
(define: (num-elems [h : (heap:Heap (cons number number))]) : (list-of (cons number number))
(heap:elements h))
(pdefine: (a) (elements [pq : (priority-queue a)]) : (list-of a)
(map #{elm :: ((elem a) -> a)} (heap:elements (heap pq))))
(pdefine: (a) (elements+priorities [pq : (priority-queue a)]) : (values (list-of a) (list-of number))
(let: ([eps : (list-of (elem a)) (heap:elements (heap pq))])
(values (map #{elm :: ((elem a) -> a)} eps)
(map #{pri :: ((elem a) -> number)} eps))))
(pdefine: (a) (empty? [pq : (priority-queue a)]) : boolean
(heap:empty? (heap pq)))
(define: empty : (All (a) (case-lambda (-> (priority-queue a)) (comparator -> (priority-queue a))))
(pcase-lambda: (a)
[() (#{empty @ a} (current-compare))]
[([cmp : comparator]) (make (#{heap:empty :: (case-lambda (-> (pqh a))
(comparator -> (pqh a)))} cmp))]))
(pdefine: (e r) (fold [f : ((cons number e) r -> r)] [b : r] [a : (priority-queue e)]) : r
(heap:fold f b (#{heap :: ((priority-queue e) -> (pqh e))} a)))
;; "bug" found - handling of empty heaps
(pdefine: (a) (find-min [pq : (priority-queue a)]) : a
(let ([h (heap pq)])
(if (heap:heap-node? h)
(elm (heap:find-min h))
(error "priority queue empty"))))
(pdefine: (a) (find-min-priority [pq : (priority-queue a)]) : number
(let ([h (heap pq)])
(if (heap:heap-node? h)
(pri (heap:find-min h))
(error "priority queue empty"))))
(pdefine: (a) (insert [x : a] [p : number] [pq : (priority-queue a)]) : (priority-queue a)
(make (heap:insert (cons p x) (heap pq))))
;; FIXME -- too many annotations needed on cons
(pdefine: (a) (insert* [xs : (list-of a)] [ps : (list-of number)] [pq : (priority-queue a)]) : (priority-queue a)
(make (heap:insert* (map #{cons @ number a} ps xs) (heap pq))))
(pdefine: (a) (delete-min [pq : (priority-queue a)]) : (priority-queue a)
(let ([h (heap pq)])
(if (heap:heap-node? h)
(make (heap:delete-min h))
(error "priority queue empty"))))
(pdefine: (a) (size [pq : (priority-queue a)]) : number
(heap:size (heap pq)))
(pdefine: (a) (union [pq1 : (priority-queue a)] [pq2 : (priority-queue a)]) : (priority-queue a)
(make (heap:union (heap pq1) (heap pq2))))
#;(require "signatures/priority-queue-signature.scm")
#;(provide-priority-queue)

7
collects/typed-scheme/optimizer/float.rkt
View File

@ -1,7 +1,7 @@
#lang scheme/base
(require syntax/parse
syntax/id-table racket/dict
syntax/id-table racket/dict scheme/flonum
(for-template scheme/base scheme/flonum scheme/unsafe/ops)
"../utils/utils.rkt"
(types abbrev type-table utils subtype)
@ -59,6 +59,11 @@
;; note: none of the unary operations have types where non-float arguments
;; can result in float (as opposed to real) results
(define-syntax-class float-arg-expr
;; we can convert literals right away
(pattern (quote n)
#:when (exact-integer? (syntax->datum #'n))
#:with opt
(datum->syntax #'here (->fl (syntax->datum #'n))))
(pattern e:fixnum-expr
#:with opt #'(unsafe-fx->fl e.opt))
(pattern e:int-expr

102
collects/typed-scheme/optimizer/inexact-complex.rkt
View File

@ -31,13 +31,20 @@
;; we keep the real and imaginary parts unboxed as long as we stay within
;; complex operations
(define-syntax-class unboxed-inexact-complex-opt-expr
;; special handling of reals inside complex operations
(pattern e:float-coerce-expr
#:with real-binding (unboxed-gensym 'unboxed-float-)
#:with imag-binding #f
#:with (bindings ...)
#`(((real-binding) e.opt)))
(pattern (#%plain-app (~and op (~literal +))
c1:unboxed-inexact-complex-opt-expr
c2:unboxed-inexact-complex-opt-expr
cs:unboxed-inexact-complex-opt-expr ...)
#:with real-binding (unboxed-gensym)
#:with imag-binding (unboxed-gensym)
#:with real-binding (unboxed-gensym "unboxed-real-")
#:with imag-binding (unboxed-gensym "unboxed-imag-")
#:with (bindings ...)
(begin (log-optimization "unboxed binary inexact complex" #'op)
#`(#,@(append (syntax->list #'(c1.bindings ... c2.bindings ... cs.bindings ... ...))
@ -60,8 +67,8 @@
c1:unboxed-inexact-complex-opt-expr
c2:unboxed-inexact-complex-opt-expr
cs:unboxed-inexact-complex-opt-expr ...)
#:with real-binding (unboxed-gensym)
#:with imag-binding (unboxed-gensym)
#:with real-binding (unboxed-gensym "unboxed-real-")
#:with imag-binding (unboxed-gensym "unboxed-imag-")
#:with (bindings ...)
(begin (log-optimization "unboxed binary inexact complex" #'op)
#`(#,@(append (syntax->list #'(c1.bindings ... c2.bindings ... cs.bindings ... ...))
@ -87,8 +94,8 @@
c1:unboxed-inexact-complex-opt-expr
c2:unboxed-inexact-complex-opt-expr
cs:unboxed-inexact-complex-opt-expr ...)
#:with real-binding (unboxed-gensym)
#:with imag-binding (unboxed-gensym)
#:with real-binding (unboxed-gensym "unboxed-real-")
#:with imag-binding (unboxed-gensym "unboxed-imag-")
#:with (bindings ...)
(begin (log-optimization "unboxed binary inexact complex" #'op)
#`(c1.bindings ... c2.bindings ... cs.bindings ... ...
@ -102,10 +109,10 @@
[o2 (car li)]
[e1 (cdr lr)]
[e2 (cdr li)]
[rs (append (map (lambda (x) (unboxed-gensym))
[rs (append (map (lambda (x) (unboxed-gensym "unboxed-real-"))
(syntax->list #'(cs.real-binding ...)))
(list #'real-binding))]
[is (append (map (lambda (x) (unboxed-gensym))
[is (append (map (lambda (x) (unboxed-gensym "unboxed-imag-"))
(syntax->list #'(cs.imag-binding ...)))
(list #'imag-binding))]
[res '()])
@ -135,8 +142,8 @@
c1:unboxed-inexact-complex-opt-expr
c2:unboxed-inexact-complex-opt-expr
cs:unboxed-inexact-complex-opt-expr ...)
#:with real-binding (unboxed-gensym)
#:with imag-binding (unboxed-gensym)
#:with real-binding (unboxed-gensym "unboxed-real-")
#:with imag-binding (unboxed-gensym "unboxed-imag-")
#:with reals (map (lambda (x) (if (syntax->datum x) x #'0.0))
(syntax->list #'(c1.real-binding c2.real-binding cs.real-binding ...)))
#:with imags (map (lambda (x) (if (syntax->datum x) x #'0.0))
@ -150,10 +157,10 @@
[o2 (car (syntax->list #'imags))]
[e1 (cdr (syntax->list #'reals))]
[e2 (cdr (syntax->list #'imags))]
[rs (append (map (lambda (x) (unboxed-gensym))
[rs (append (map (lambda (x) (unboxed-gensym "unboxed-real-"))
(syntax->list #'(cs.real-binding ...)))
(list #'real-binding))]
[is (append (map (lambda (x) (unboxed-gensym))
[is (append (map (lambda (x) (unboxed-gensym "unboxed-imag-"))
(syntax->list #'(cs.imag-binding ...)))
(list #'imag-binding))]
[ds (map (lambda (x) (unboxed-gensym))
@ -203,7 +210,7 @@
(pattern (#%plain-app (~and op (~literal conjugate)) c:unboxed-inexact-complex-opt-expr)
#:with real-binding #'c.real-binding
#:with imag-binding (unboxed-gensym)
#:with imag-binding (unboxed-gensym "unboxed-imag-")
#:with (bindings ...)
(begin (log-optimization "unboxed unary inexact complex" #'op)
#`(#,@(append (syntax->list #'(c.bindings ...))
@ -228,12 +235,24 @@
(pattern (#%plain-app (~and op (~or (~literal make-rectangular)
(~literal unsafe-make-flrectangular)))
real:float-coerce-expr imag:float-coerce-expr)
#:with real-binding (unboxed-gensym)
#:with imag-binding (unboxed-gensym)
#:with real-binding (unboxed-gensym "unboxed-real-")
#:with imag-binding (unboxed-gensym "unboxed-imag-")
#:with (bindings ...)
(begin (log-optimization "make-rectangular elimination" #'op)
#`(((real-binding) real.opt)
#'(((real-binding) real.opt)
((imag-binding) imag.opt))))
(pattern (#%plain-app (~and op (~literal make-polar))
r:float-coerce-expr theta:float-coerce-expr)
#:with magnitude (unboxed-gensym)
#:with angle (unboxed-gensym)
#:with real-binding (unboxed-gensym "unboxed-real-")
#:with imag-binding (unboxed-gensym "unboxed-imag-")
#:with (bindings ...)
(begin (log-optimization "make-rectangular elimination" #'op)
#'(((magnitude) r.opt)
((angle) theta.opt)
((real-binding) (unsafe-fl* magnitude (unsafe-flcos angle)))
((imag-binding) (unsafe-fl* magnitude (unsafe-flsin angle))))))
;; if we see a variable that's already unboxed, use the unboxed bindings
(pattern v:id
@ -243,27 +262,46 @@
#:with imag-binding (cadr (syntax->list #'unboxed-info))
#:with (bindings ...) #'())
;; else, do the unboxing here
;; else, do the unboxing here
;; we can unbox literals right away
(pattern (quote n)
#:when (let ((x (syntax->datum #'n)))
(and (number? x)
(not (eq? (imag-part x) 0))))
#:with real-binding (unboxed-gensym "unboxed-real-")
#:with imag-binding (unboxed-gensym "unboxed-imag-")
#:with (bindings ...)
(let ((n (syntax->datum #'n)))
#`(((real-binding) #,(datum->syntax
#'here
(exact->inexact (real-part n))))
((imag-binding) #,(datum->syntax
#'here
(exact->inexact (imag-part n)))))))
(pattern (quote n)
#:when (real? (syntax->datum #'n))
#:with real-binding (unboxed-gensym "unboxed-real-")
#:with imag-binding #f
#:with (bindings ...)
#`(((real-binding) #,(datum->syntax
#'here
(exact->inexact (syntax->datum #'n))))))
(pattern e:expr
#:when (isoftype? #'e -InexactComplex)
#:with e* (unboxed-gensym)
#:with real-binding (unboxed-gensym)
#:with imag-binding (unboxed-gensym)
#:with real-binding (unboxed-gensym "unboxed-real-")
#:with imag-binding (unboxed-gensym "unboxed-imag-")
#:with (bindings ...)
#`(((e*) #,((optimize) #'e))
((real-binding) (unsafe-flreal-part e*))
((imag-binding) (unsafe-flimag-part e*))))
;; special handling of reals
(pattern e:float-coerce-expr
#:with real-binding (unboxed-gensym)
#:with imag-binding #f
#:with (bindings ...)
#`(((real-binding) e.opt)))
(pattern e:expr
#:when (isoftype? #'e -Number) ; complex, maybe exact, maybe not
#:with e* (unboxed-gensym)
#:with real-binding (unboxed-gensym)
#:with imag-binding (unboxed-gensym)
#:with real-binding (unboxed-gensym "unboxed-real-")
#:with imag-binding (unboxed-gensym "unboxed-imag-")
#:with (bindings ...)
#`(((e*) #,((optimize) #'e))
((real-binding) (exact->inexact (real-part e*)))
@ -308,6 +346,16 @@
(begin (log-optimization "unary inexact complex" #'op)
#'(op.unsafe n.opt)))
(pattern (~and exp (#%plain-app (~and op (~literal make-polar)) r theta))
#:when (isoftype? #'exp -InexactComplex)
#:with exp*:unboxed-inexact-complex-opt-expr #'exp
#:with opt
(begin (log-optimization "make-polar" #'op)
(reset-unboxed-gensym)
#'(let*-values (exp*.bindings ...)
(unsafe-make-flrectangular exp*.real-binding
exp*.imag-binding))))
(pattern (~and e (#%plain-app op:id args:expr ...))
#:with unboxed-info (dict-ref unboxed-funs-table #'op #f)
#:when (syntax->datum #'unboxed-info)

4
collects/typed-scheme/optimizer/unboxed-let.rkt
View File

@ -271,9 +271,9 @@
#:when (syntax->datum #'unboxed-info)
;; partition of the arguments
#:with ((to-unbox ...) (boxed ...)) #'unboxed-info
#:with (real-params ...) (map (lambda (x) (unboxed-gensym 'unboxed-real-))
#:with (real-params ...) (map (lambda (x) (unboxed-gensym "unboxed-real-"))
(syntax->list #'(to-unbox ...)))
#:with (imag-params ...) (map (lambda (x) (unboxed-gensym 'unboxed-imag-))
#:with (imag-params ...) (map (lambda (x) (unboxed-gensym "unboxed-imag-"))
(syntax->list #'(to-unbox ...)))
#:with res
(begin

22
collects/typed-scheme/private/annotate-classes.rkt
View File

@ -63,3 +63,25 @@
(~or rest:annotated-star-rest rest:annotated-dots-rest)))
#:with ann-formals #'(n.ann-name ... . rest.ann-name)
#:with (arg-ty ...) #'(n.ty ... . rest.formal-ty)))
(define-syntax-class opt-lambda-annotated-formal
#:description "annotated variable, potentially with a default value"
#:opaque
#:attributes (name ty ann-name)
(pattern [:annotated-name])
(pattern [n:annotated-name val]
#:with name #'n.name
#:with ty #'n.name
#:with ann-name #'(n.ann-name val)))
(define-syntax-class opt-lambda-annotated-formals
#:attributes (ann-formals (arg-ty 1))
#:literals (:)
(pattern (n:opt-lambda-annotated-formal ...)
#:with ann-formals #'(n.ann-name ...)
#:with (arg-ty ...) #'(n.ty ...))
(pattern (n:opt-lambda-annotated-formal ...
(~describe "dotted or starred type"
(~or rest:annotated-star-rest rest:annotated-dots-rest)))
#:with ann-formals #'(n.ann-name ... . rest.ann-name)
#:with (arg-ty ...) #'(n.ty ... . rest.formal-ty)))

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

@ -137,7 +137,7 @@
[unsafe-vector-set! (-poly (a) (-> (-vec a) index-type a -Void))]
[unsafe-vector*-set! (-poly (a) (-> (-vec a) index-type a -Void))]
[vector-copy! (-poly (a) ((-vec a) index-type (-vec a) [index-type index-type] . ->opt . -Void))]
[make-vector (-poly (a) (cl-> [(index-type) (-vec (Un -Nat a))]
[make-vector (-poly (a) (cl-> [(index-type) (-vec (Un -Integer a))]
[(index-type a) (-vec a)]))]
[bytes-ref (-> -Bytes index-type -NonnegativeFixnum)]

15
collects/typed-scheme/private/parse-type.rkt
View File

@ -88,6 +88,13 @@
(pattern (~seq [k:keyword t:expr])
#:attr Keyword (make-Keyword (syntax-e #'k) (parse-type #'t) #f)))
(define-syntax-class non-keyword-ty
(pattern (k e:expr ...)
#:when (not (keyword? (syntax->datum #'k))))
(pattern t:expr
#:when (and (not (keyword? (syntax->datum #'t)))
(not (syntax->list #'t)))))
(define-syntax-class path-elem
#:description "path element"
#:literals (car cdr)
@ -214,7 +221,7 @@
(add-type-name-reference #'kw)
;; use parse-type instead of parse-values-type because we need to add the filters from the pred-ty
(make-pred-ty (list (parse-type #'dom)) (parse-type #'rng) (attribute latent.type) 0 (attribute latent.path))]
[(dom:expr ... rest:expr ddd:star kws:keyword-tys ... (~and kw t:->) rng)
[(dom:non-keyword-ty ... rest:non-keyword-ty ddd:star kws:keyword-tys ... (~and kw t:->) rng)
(add-type-name-reference #'kw)
(make-Function
(list (make-arr
@ -222,7 +229,7 @@
(parse-values-type #'rng)
#:rest (parse-type #'rest)
#:kws (attribute kws.Keyword))))]
[(dom:expr ... rest:expr :ddd/bound (~and kw t:->) rng)
[(dom:non-keyword-ty ... rest:non-keyword-ty :ddd/bound (~and kw t:->) rng)
(add-type-name-reference #'kw)
(let* ([bnd (syntax-e #'bound)])
(unless (bound-index? bnd)
@ -236,7 +243,7 @@
(extend-tvars (list bnd)
(parse-type #'rest))
bnd))))]
[(dom:expr ... rest:expr _:ddd (~and kw t:->) rng)
[(dom:non-keyword-ty ... rest:non-keyword-ty _:ddd (~and kw t:->) rng)
(add-type-name-reference #'kw)
(let ([var (infer-index stx)])
(make-Function
@ -251,7 +258,7 @@
(->* (map parse-type (syntax->list #'(dom ...)))
(parse-values-type #'rng))] |#
;; use expr to rule out keywords
[(dom:expr ... kws:keyword-tys ... (~and kw t:->) rng)
[(dom:non-keyword-ty ... kws:keyword-tys ... (~and kw t:->) rng)
(add-type-name-reference #'kw)
(let ([doms (for/list ([d (syntax->list #'(dom ...))])
(parse-type d))])

23
collects/typed-scheme/private/prims.rkt
View File

@ -27,6 +27,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
(require "../utils/utils.rkt"
racket/base
mzlib/etc
(for-syntax
syntax/parse
syntax/private/util
@ -173,6 +174,15 @@ This file defines two sorts of primitives. All of them are provided into any mod
'typechecker:plambda
#'(tvars ...))))]))
(define-syntax (popt-lambda: stx)
(syntax-parse stx
[(popt-lambda: (tvars:id ...) formals . body)
(quasisyntax/loc stx
(#%expression
#,(syntax-property (syntax/loc stx (opt-lambda: formals . body))
'typechecker:plambda
#'(tvars ...))))]))
(define-syntax (pdefine: stx)
(syntax-parse stx #:literals (:)
[(pdefine: (tvars:id ...) (nm:id . formals:annotated-formals) : ret-ty . body)
@ -223,6 +233,11 @@ This file defines two sorts of primitives. All of them are provided into any mod
[(case-lambda: [formals:annotated-formals . body] ...)
(syntax/loc stx (case-lambda [formals.ann-formals . body] ...))]))
(define-syntax (opt-lambda: stx)
(syntax-parse stx
[(opt-lambda: formals:opt-lambda-annotated-formals . body)
(syntax/loc stx (opt-lambda formals.ann-formals . body))]))
(define-syntaxes (let-internal: let*: letrec:)
(let ([mk (lambda (form)
(lambda (stx)
@ -436,7 +451,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
(syntax-parse clauses
[(head:for-clause next:for-clause ... #:when rest ...)
(syntax-property
(quasisyntax/loc clauses
(quasisyntax/loc stx
(for
(head.expand next.expand ...)
#,(loop #'(#:when rest ...))))
@ -444,18 +459,18 @@ This file defines two sorts of primitives. All of them are provided into any mod
#'Void)]
[(head:for-clause ...) ; we reached the end
(syntax-property
(quasisyntax/loc clauses
(quasisyntax/loc stx
(for
(head.expand ...)
#,@body))
'type-ascription
#'Void)]
[(#:when guard) ; we end on a #:when clause
(quasisyntax/loc clauses
(quasisyntax/loc stx
(when guard
#,@body))]
[(#:when guard rest ...)
(quasisyntax/loc clauses
(quasisyntax/loc stx
(when guard
#,(loop #'(rest ...))))])))]))

3
collects/typed-scheme/tc-setup.rkt
View File

@ -3,6 +3,7 @@
(require (rename-in "utils/utils.rkt" [infer r:infer])
(except-in syntax/parse id)
unstable/mutated-vars
racket/pretty
scheme/base
(private type-contract)
(types utils convenience)
@ -51,6 +52,8 @@
[type-name-references null])
(do-time "Initialized Envs")
(let ([fully-expanded-stx (local-expand stx expand-ctxt null)])
(when (show-input?)
(pretty-print (syntax->datum fully-expanded-stx)))
(do-time "Local Expand Done")
(parameterize ([mutated-vars (find-mutated-vars fully-expanded-stx)]
[orig-module-stx (or (orig-module-stx) orig-stx)]

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

@ -49,7 +49,8 @@
[(~var i (3d inexact-real?)) -Flonum]
[(~var i (3d real?)) -Real]
;; a complex number can't have an inexact imaginary part and an exact real part
[(~var i (3d (conjoin number? (lambda (x) (inexact-real? (imag-part x))))))
[(~var i (3d (conjoin number? (lambda (x) (and (inexact-real? (imag-part x))
(inexact-real? (real-part x)))))))
-InexactComplex]
[(~var i (3d number?)) -Number]
[i:str -String]

3
collects/typed-scheme/utils/utils.rkt
View File

@ -19,7 +19,7 @@ at least theoretically.
;; timing
start-timing do-time
;; logging
printf/log
printf/log show-input?
;; struct printing
custom-printer define-struct/printer
;; provide macros
@ -27,6 +27,7 @@ at least theoretically.
(define optimize? (make-parameter #f))
(define-for-syntax enable-contracts? #f)
(define show-input? (make-parameter #f))
;; fancy require syntax
(define-syntax (define-requirer stx)