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

Misc minor improvements.

Browse Source 
original commit: 5bd3a9ff2f22666b6f904d62bd9c810086ede4f9
This commit is contained in:
Sam Tobin-Hochstadt 2014-05-01 15:27:23 -04:00
parent 8bba85dd57
commit 854e86d14c
4 changed files with 53 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/type-alias-env.rkt vendored
View File

@ -19,7 +19,7 @@
(define the-mapping
(make-free-id-table))
(define (mapping-put! id v) (dict-set! the-mapping id v))
(define (mapping-put! id v) (free-id-table-set! the-mapping id v))
;(trace mapping-put!)
@ -33,16 +33,16 @@
(mapping-put! id (make-resolved ty)))
(define (lookup-type-alias id parse-type [k (lambda () (tc-error "Unknown type alias: ~a" (syntax-e id)))])
(let/ec return
(match (dict-ref the-mapping id (lambda () (return (k))))
[(struct unresolved (stx #f))
(resolve-type-alias id parse-type)]
[(struct unresolved (stx #t))
(tc-error/stx stx "Recursive Type Alias Reference")]
[(struct resolved (t)) t])))
(match (free-id-table-ref the-mapping id #f)
[#f (k)]
[(struct unresolved (stx #f))
(resolve-type-alias id parse-type)]
[(struct unresolved (stx #t))
(tc-error/stx stx "Recursive Type Alias Reference")]
[(struct resolved (t)) t]))
(define (resolve-type-alias id parse-type)
(define v (dict-ref the-mapping id))
(define v (free-id-table-ref the-mapping id))
(match v
[(struct unresolved (stx _))
(set-unresolved-in-process! v #t)
@ -53,7 +53,7 @@
t]))
(define (resolve-type-aliases parse-type)
(for ([(id _) (in-dict the-mapping)])
(for ([id (in-dict-keys the-mapping)])
(resolve-type-alias id parse-type)))
;; map over the-mapping, producing a list

2
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/infer/promote-demote.rkt
View File

@ -11,7 +11,7 @@
(define (V-in? V . ts)
(for/or ([e (in-list (append* (map fv ts)))])
(memq e V)))
(memq e V)))
;; get-filters : SomeValues -> FilterSet
;; extract filters out of the range of a function type

70
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/rep/type-rep.rkt
View File

@ -615,19 +615,29 @@
(define ((sub-pe st) e)
(pathelem-case (#:Type st
#:PathElem (sub-pe st))
#:PathElem (sub-pe st))
e))
;; abstract-many : Names Type -> Scope^n
;; where n is the length of names
(define (abstract-many names ty)
(define (nameTo name count type)
;; mapping : dict[Type -> Natural]
(define (nameTo mapping type)
(let loop ([outer 0] [ty type])
(define (sb t) (loop outer t))
;; transform : Name (Integer -> a) a -> a
;; apply `mapping` to `name*`, returning `default` if it's not there
;; use `f` to wrap the result
;; note that this takes into account the value of `outer`
(define (transform name* f default)
(cond [(assq name* mapping)
=> (λ (pr)
(f (+ (cdr pr) outer)))]
[else default]))
(type-case
(#:Type sb #:Filter (sub-f sb) #:Object (sub-o sb))
(#:Type sb #:Filter (sub-f sb) #:Object (sub-o sb))
ty
[#:F name* (if (eq? name name*) (*B (+ count outer)) ty)]
[#:F name* (transform name* *B ty)]
;; necessary to avoid infinite loops
[#:Union elems (*Union (remove-dups (sort (map sb elems) type<?)))]
;; functions
@ -637,16 +647,17 @@
(if rest (sb rest) #f)
(if drest
(cons (sb (car drest))
(if (eq? (cdr drest) name) (+ count outer) (cdr drest)))
(let ([c (cdr drest)])
(transform c values c)))
#f)
(map sb kws))]
[#:ValuesDots rs dty dbound
(*ValuesDots (map sb rs)
(sb dty)
(if (eq? dbound name) (+ count outer) dbound))]
(transform dbound values dbound))]
[#:ListDots dty dbound
(*ListDots (sb dty)
(if (eq? dbound name) (+ count outer) dbound))]
(transform dbound values dbound))]
[#:Mu (Scope: body) (*Mu (*Scope (loop (add1 outer) body)))]
[#:PolyRow constraints body*
(let ([body (remove-scopes 1 body*)])
@ -658,28 +669,33 @@
[#:Poly n body*
(let ([body (remove-scopes n body*)])
(*Poly n (add-scopes n (loop (+ n outer) body))))])))
(let ([n (length names)])
(let loop ([ty ty] [names names] [count (sub1 n)])
(if (zero? count)
(add-scopes n (nameTo (car names) 0 ty))
(loop (nameTo (car names) count ty)
(cdr names)
(sub1 count))))))
(define n (length names))
(define mapping (for/list ([nm (in-list names)]
[i (in-range n 0 -1)])
(cons nm (sub1 i))))
(add-scopes n (nameTo mapping ty)))
;; instantiate-many : List[Type] Scope^n -> Type
;; where n is the length of types
;; all of the types MUST be Fs
(define (instantiate-many images sc)
(define (replace image count type)
;; mapping : dict[Natural -> Type]
(define (replace mapping type)
(let loop ([outer 0] [ty type])
;; transform : Integer (Name -> a) a -> a
;; apply `mapping` to `idx`, returning `default` if it's not there
;; use `f` to wrap the result
;; note that this takes into account the value of `outer`
(define (transform idx f default)
(cond [(assf (lambda (v) (eqv? (+ v outer) idx)) mapping)
=> (lambda (pr) (f (cdr pr)))]
[else default]))
(define (sb t) (loop outer t))
(define sf (sub-f sb))
(type-case
(#:Type sb #:Filter sf #:Object (sub-o sb))
ty
[#:B idx (if (= (+ count outer) idx)
image
ty)]
[#:B idx (transform idx values ty)]
;; necessary to avoid infinite loops
[#:Union elems (*Union (remove-dups (sort (map sb elems) type<?)))]
;; functions
@ -689,16 +705,16 @@
(if rest (sb rest) #f)
(if drest
(cons (sb (car drest))
(if (eqv? (cdr drest) (+ count outer)) (F-n image) (cdr drest)))
(transform (cdr drest) F-n (cdr drest)))
#f)
(map sb kws))]
[#:ValuesDots rs dty dbound
(*ValuesDots (map sb rs)
(sb dty)
(if (eqv? dbound (+ count outer)) (F-n image) dbound))]
(transform dbound F-n dbound))]
[#:ListDots dty dbound
(*ListDots (sb dty)
(if (eqv? dbound (+ count outer)) (F-n image) dbound))]
(transform dbound F-n dbound))]
[#:Mu (Scope: body) (*Mu (*Scope (loop (add1 outer) body)))]
[#:PolyRow constraints body*
(let ([body (remove-scopes 1 body*)])
@ -709,13 +725,11 @@
[#:Poly n body*
(let ([body (remove-scopes n body*)])
(*Poly n (add-scopes n (loop (+ n outer) body))))])))
(let ([n (length images)])
(let loop ([ty (remove-scopes n sc)] [images images] [count (sub1 n)])
(if (zero? count)
(replace (car images) 0 ty)
(loop (replace (car images) count ty)
(cdr images)
(sub1 count))))))
(define n (length images))
(define mapping (for/list ([img (in-list images)]
[i (in-range n 0 -1)])
(cons (sub1 i) img)))
(replace mapping (remove-scopes n sc)))
(define (abstract name ty)
(abstract-many (list name) ty))

8
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt
View File

@ -45,17 +45,9 @@
;; syntax? -> (listof def-binding?)
(define (tc-toplevel/pass1 form)
#; ;; pass1 is fast
(do-time (format "pass1 ~a line ~a"
(if #t
(substring (~a (syntax-source form))
(max 0 (- (string-length (~a (syntax-source form))) 20)))
(syntax-source form))
(syntax-line form)))
(parameterize ([current-orig-stx form])
(syntax-parse form
#:literals (values define-values #%plain-app begin define-syntaxes)
;#:literal-sets (kernel-literals)
;; forms that are handled in other ways
[(~or _:ignore^ _:ignore-some^)