diff --git a/collects/typed-scheme/infer/infer-unit.ss b/collects/typed-scheme/infer/infer-unit.ss index e0fdae3a08..3b240d2370 100644 --- a/collects/typed-scheme/infer/infer-unit.ss +++ b/collects/typed-scheme/infer/infer-unit.ss @@ -452,6 +452,7 @@ (define (infer X S T R must-vars [expected #f]) (with-handlers ([exn:infer? (lambda _ #f)]) (let ([cs (cgen/list null X S T)]) + (printf "finished step 1~n") (if (not expected) (subst-gen cs R must-vars) (subst-gen (cset-meet cs (cgen null X R expected)) R must-vars))))) @@ -459,7 +460,10 @@ ;; like infer, but T-var is the vararg type: (define (infer/vararg X S T T-var R must-vars [expected #f]) (define new-T (if T-var (extend S T T-var) T)) + (printf "infer/vararg: ~a~n" (list X S T)) + (printf "new-T: ~a~n" new-T) (and ((length S) . >= . (length T)) + (printf "finished step 0~n") (infer X S new-T R must-vars expected))) ;; like infer, but dotted-var is the bound on the ... @@ -486,4 +490,4 @@ (define (i s t r) (infer/simple (list s) (list t) r)) -;(trace cgen) +(trace cgen subst-gen) diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index 754884c03f..0d470720b8 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -341,6 +341,17 @@ #:LatentFilter (sub-lf st)) e)) +(define ((sub-lo st) e) + (latentobject-case (#:Type st + #:LatentObject (sub-lo st) + #:PathElem (sub-pe st)) + e)) + +(define ((sub-pe st) e) + (pathelem-case (#:Type st + #:PathElem (sub-pe st)) + e)) + ;; abstract-many : Names Type -> Scope^n ;; where n is the length of names (define (abstract-many names ty) @@ -349,7 +360,7 @@ (define (sb t) (loop outer t)) (define slf (sub-lf sb)) (type-case - (#:Type sb #:LatentFilter (sub-lf sb)) + (#:Type sb #:LatentFilter (sub-lf sb) #:LatentObject (sub-lo sb)) ty [#:F name* (if (eq? name name*) (*B (+ count outer)) ty)] ;; necessary to avoid infinite loops @@ -392,7 +403,7 @@ (define (sb t) (loop outer t)) (define slf (sub-lf sb)) (type-case - (#:Type sb #:LatentFilter slf) + (#:Type sb #:LatentFilter slf #:LatentObject (sub-lo sb)) ty [#:B idx (if (= (+ count outer) idx) image @@ -580,7 +591,7 @@ free-vars* type-equal? type-compare type Number)} -;; BUG - this should work + {ann (values (lambda (x) x) (lambda (x) x)) (values (Number -> Number) (String -> String))} (list 1 2 3) diff --git a/collects/typed-scheme/test2.ss b/collects/typed-scheme/test2.ss index 779f389a5e..e5b55e11ba 100644 --- a/collects/typed-scheme/test2.ss +++ b/collects/typed-scheme/test2.ss @@ -1,5 +1,5 @@ #lang typed-scheme - +#| (: f (Number String -> Number)) (define (f x z) #;(f x z) 7) (lambda: ([x : Any] [y : Any]) (values (number? y) (number? x))) @@ -19,14 +19,16 @@ (+) (+ 1 2 3) (+ 1 2 3.5) - +|# (define-struct: (Z) X ([y : Z])) (define: my-x : (X Number) (make-X 1)) +(X-y my-x) + #| ; FIXME - doesn't work yet (number? (X-y my-x)) (if (number? (X-y my-x)) (+ 1 (X-y my-x)) 7) |# - +#| (define: (f2) : (U) (error 'foo)) (lambda: ([x : Number]) #{((f2)) :: (U)}) @@ -46,4 +48,5 @@ ;; error ;(map + (list 1 2 3) (list 1 2 "foo")) -((lambda (a b . c) (+ a b (car c))) 1 2 3 4) \ No newline at end of file +((lambda (a b . c) (+ a b (car c))) 1 2 3 4) +|# diff --git a/collects/typed-scheme/typecheck/find-annotation.ss b/collects/typed-scheme/typecheck/find-annotation.ss new file mode 100644 index 0000000000..8ac74b4d78 --- /dev/null +++ b/collects/typed-scheme/typecheck/find-annotation.ss @@ -0,0 +1,65 @@ +#lang scheme/base + +(require "../utils/utils.ss" stxclass + scheme/contract + (rep type-rep) + (private type-annotation)) + +(p/c [find-annotation (syntax? identifier? . -> . (or/c #f Type/c))]) + +(define-syntax-class lv-clause + #:transparent + (pattern [(v:id ...) e:expr])) + +(define-syntax-class lv-clauses + #:transparent + (pattern (cl:lv-clause ...) + #:with (e ...) #'(cl.e ...) + #:with (vs ...) #'((cl.v ...) ...))) + +(define-syntax-class core-expr + #:literals (reverse letrec-syntaxes+values let-values #%plain-app + if letrec-values begin #%plain-lambda set! case-lambda + begin0 with-continuation-mark) + #:transparent + (pattern (let-values cls:lv-clauses body) + #:with (expr ...) #'(cls.e ... body)) + (pattern (letrec-values cls:lv-clauses body) + #:with (expr ...) #'(cls.e ... body)) + (pattern (letrec-syntaxes+values _ cls:lv-clauses body) + #:with (expr ...) #'(cls.e ... body)) + (pattern (#%plain-app expr ...)) + (pattern (if expr ...)) + (pattern (with-continuation-mark expr ...)) + (pattern (begin expr ...)) + (pattern (begin0 expr ...)) + (pattern (#%plain-lambda _ e) + #:with (expr ...) #'(e)) + (pattern (case-lambda [_ expr] ...)) + (pattern (set! _ e) + #:with (expr ...) #'(e)) + (pattern _ + #:with (expr ...) #'())) + +;; expr id -> type or #f +;; if there is a binding in stx of the form: +;; (let ([x (reverse name)]) e) +;; where x has a type annotation, return that annotation, otherwise #f +(define (find-annotation stx name) + (define (find s) (find-annotation s name)) + (define (match? b) + (syntax-parse b + #:literals (#%plain-app reverse) + [c:lv-clause + #:with (#%plain-app reverse n:id) #'c.e + #:with (v) #'(c.v ...) + #:when (free-identifier=? name #'n) + (type-annotation #'v)] + [_ #f])) + (syntax-parse stx + #:literals (let-values) + [(let-values cls:lv-clauses body) + (or (ormap match? (syntax->list #'cls)) + (find #'body))] + [e:core-expr + (ormap find (syntax->list #'(e.expr ...)))])) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/tc-structs.ss b/collects/typed-scheme/typecheck/tc-structs.ss index c388b8b735..4f1b3c00ce 100644 --- a/collects/typed-scheme/typecheck/tc-structs.ss +++ b/collects/typed-scheme/typecheck/tc-structs.ss @@ -126,14 +126,14 @@ (define bindings (append (list (cons (or maker* maker) - (wrapper (->* external-fld-types (if cret cret name)))) + (debug (wrapper (->* external-fld-types (if cret cret name))))) (cons pred (make-pred-ty (pred-wrapper name)))) (for/list ([g (in-list getters)] [t (in-list external-fld-types/no-parent)] [i (in-naturals)]) (let ([func (if setters? (->* (list name) t) (make-Function - (list (make-arr* (list sty) t + (list (make-arr* (list name) t #:object (make-LPath (list (make-StructPE name i)) 0)))))]) (cons g (wrapper func)))) (if setters? diff --git a/collects/typed-scheme/typed-scheme.ss b/collects/typed-scheme/typed-scheme.ss index 36770a4321..5646b76a53 100644 --- a/collects/typed-scheme/typed-scheme.ss +++ b/collects/typed-scheme/typed-scheme.ss @@ -48,7 +48,9 @@ [with-handlers ([(lambda (e) (and catch-errors? (exn:fail? e) (not (exn:fail:syntax? e)))) (lambda (e) (tc-error "Internal error: ~a" e))])] - [parameterize (;; a cheat to avoid units + [parameterize (;; disable fancy printing + [custom-printer #t] + ;; a cheat to avoid units [infer-param infer] ;; do we report multiple errors [delay-errors? #t] diff --git a/collects/typed-scheme/types/printer.ss b/collects/typed-scheme/types/printer.ss index 6667f41fc7..9eeca9b249 100644 --- a/collects/typed-scheme/types/printer.ss +++ b/collects/typed-scheme/types/printer.ss @@ -116,7 +116,7 @@ ;; names are just the printed as the original syntax [(Name: stx) (fp "~a" (syntax-e stx))] [(App: rator rands stx) - (fp "~a" (cons rator rands))] + (fp "~a" (list* '@ rator rands))] ;; special cases for lists [(Mu: var (Union: (list (Value: '()) (Pair: elem-ty (F: var))))) (fp "(Listof ~a)" elem-ty)] diff --git a/collects/typed-scheme/types/utils.ss b/collects/typed-scheme/types/utils.ss index ecb4f49106..2a768e0fb0 100644 --- a/collects/typed-scheme/types/utils.ss +++ b/collects/typed-scheme/types/utils.ss @@ -38,7 +38,7 @@ (define (substitute image name target #:Un [Un (get-union-maker)]) (define (sb t) (substitute image name t)) (if (hash-ref (free-vars* target) name #f) - (type-case (#:Type sb #:LatentFilter (sub-lf sb)) + (type-case (#:Type sb #:LatentFilter (sub-lf sb) #:LatentObject (sub-lo sb)) target [#:Union tys (Un (map sb tys))] [#:F name* (if (eq? name* name) image target)] diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index f322ad0307..69041a536c 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -22,6 +22,7 @@ at least theoretically. debug in-syntax symbol-append + custom-printer rep utils typecheck infer env private) (define-syntax (define-requirer stx) @@ -200,6 +201,18 @@ at least theoretically. (defprinter print-type* print-filter* print-latentfilter* print-object* print-latentobject* print-pathelem*) + +(define pseudo-printer + (lambda (s port mode) + (parameterize ([current-output-port port] + [show-sharing #f] + [booleans-as-true/false #f] + [constructor-style-printing #t]) + (newline) + (pretty-print (print-convert s)) + (newline)))) + +(define custom-printer (make-parameter #t)) (require scheme/pretty mzlib/pconvert) @@ -208,15 +221,8 @@ at least theoretically. [(form name (flds ...) printer) #`(define-struct/properties name (flds ...) #,(if printing? - #'([prop:custom-write printer]) - #'([prop:custom-write (lambda (s port mode) - (parameterize ([current-output-port port] - [show-sharing #f] - [booleans-as-true/false #f] - [constructor-style-printing #t]) - (newline) - (pretty-print (print-convert s)) - (newline)))])) + #'([prop:custom-write (lambda (a b c) (if (custom-printer) (printer a b c) (pseudo-printer a b c)))]) + #'([prop:custom-write pseudo-printer])) #f)])) (define (id kw . args)