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

Add missing file.

Browse Source 
Fix bug in struct type creation.
Add ability to disable printing dynamically.
Fix recursion into objects & paths.

svn: r14747
This commit is contained in:
Sam Tobin-Hochstadt 2009-05-08 19:00:07 +00:00
parent d2cc1b2400
commit dbe5556b45
10 changed files with 114 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/typed-scheme/infer/infer-unit.ss
View File

@ -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)

17
collects/typed-scheme/rep/type-rep.ss
View File

@ -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<?
remove-dups
sub-lf
sub-lf sub-lo sub-pe
Values: Values? Values-rs
(rename-out [Mu:* Mu:]
[Poly:* Poly:]

2
collects/typed-scheme/test.ss
View File

@ -86,7 +86,7 @@ xxx6-y
(lambda () (values 1 1))
(lambda () 1)
#{(lambda (x) x) :: (Number -> Number)}
;; BUG - this should work
{ann (values (lambda (x) x) (lambda (x) x)) (values (Number -> Number) (String -> String))}
(list 1 2 3)

9
collects/typed-scheme/test2.ss
View File

@ -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)})
@ -47,3 +49,4 @@
;(map + (list 1 2 3) (list 1 2 "foo"))
((lambda (a b . c) (+ a b (car c))) 1 2 3 4)
|#

65
collects/typed-scheme/typecheck/find-annotation.ss Normal file
View File

@ -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 ...)))]))

4
collects/typed-scheme/typecheck/tc-structs.ss
View File

@ -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?

4
collects/typed-scheme/typed-scheme.ss
View File

@ -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]

2
collects/typed-scheme/types/printer.ss
View File

@ -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)]

2
collects/typed-scheme/types/utils.ss
View File

@ -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)]

24
collects/typed-scheme/utils/utils.ss
View File

@ -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)
@ -201,6 +202,18 @@ at least theoretically.
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)
(define-syntax (define-struct/printer stx)
@ -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)