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

compiles

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2008-09-01 14:55:51 -04:00
parent a8417c7c1c
commit b5a07f4646
2 changed files with 16 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/typed-scheme/private/check-subforms-unit.ss
View File

@ -21,7 +21,7 @@
(define body-ty #f) (define body-ty #f)
(define (get-result-ty t) (define (get-result-ty t)
(match t (match t
[(Function: (list (arr: _ rngs #f _ _ _) ...)) (apply Un rngs)] [(Function: (list (arr: _ rngs #f _ '() _ _) ...)) (apply Un rngs)]
[_ (tc-error "Internal error in get-result-ty: not a function type: ~n~a" t)])) [_ (tc-error "Internal error in get-result-ty: not a function type: ~n~a" t)]))
(let loop ([form form]) (let loop ([form form])
(parameterize ([current-orig-stx form]) (parameterize ([current-orig-stx form])

30
collects/typed-scheme/private/tc-app-unit.ss
View File

@ -159,7 +159,7 @@
(define-values (fixed-args tail) (split (syntax->list args))) (define-values (fixed-args tail) (split (syntax->list args)))
(match f-ty (match f-ty
[(tc-result: (Function: (list (arr: doms rngs rests drests thn-effs els-effs) ...))) [(tc-result: (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ...)))
(when (null? doms) (when (null? doms)
(tc-error/expr #:return (ret (Un)) (tc-error/expr #:return (ret (Un))
"empty case-lambda given as argument to apply")) "empty case-lambda given as argument to apply"))
@ -204,7 +204,7 @@
(printf/log "Non-poly apply, ... arg\n") (printf/log "Non-poly apply, ... arg\n")
(ret (car rngs*))] (ret (car rngs*))]
[else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))]
[(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests drests thn-effs els-effs) ..1)))) [(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ..1))))
(let*-values ([(arg-tys) (map tc-expr/t fixed-args)] (let*-values ([(arg-tys) (map tc-expr/t fixed-args)]
[(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))]) [(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))])
(tc/dots tail))]) (tc/dots tail))])
@ -214,7 +214,7 @@
(let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests])
(cond [(null? doms*) (cond [(null? doms*)
(match f-ty (match f-ty
[(tc-result: (Poly-names: _ (Function: (list (arr: doms rngs rests drests _ _) ..1)))) [(tc-result: (Poly-names: _ (Function: (list (arr: doms rngs rests drests '() _ _) ..1))))
(tc-error/expr #:return (ret (Un)) (tc-error/expr #:return (ret (Un))
(string-append (string-append
"Bad arguments to polymorphic function in apply:~n" "Bad arguments to polymorphic function in apply:~n"
@ -259,14 +259,14 @@
(tc-error/expr #:return (ret (Un)) (tc-error/expr #:return (ret (Un))
"Function has no cases")] "Function has no cases")]
[(tc-result: (PolyDots: (and vars (list fixed-vars ... dotted-var)) [(tc-result: (PolyDots: (and vars (list fixed-vars ... dotted-var))
(Function: (list (arr: doms rngs rests drests thn-effs els-effs) ..1)))) (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ..1))))
(let*-values ([(arg-tys) (map tc-expr/t fixed-args)] (let*-values ([(arg-tys) (map tc-expr/t fixed-args)]
[(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))]) [(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))])
(tc/dots tail))]) (tc/dots tail))])
(let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests])
(cond [(null? doms*) (cond [(null? doms*)
(match f-ty (match f-ty
[(tc-result: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests _ _) ..1)))) [(tc-result: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests '() _ _) ..1))))
(tc-error/expr #:return (ret (Un)) (tc-error/expr #:return (ret (Un))
(string-append (string-append
"Bad arguments to polymorphic function in apply:~n" "Bad arguments to polymorphic function in apply:~n"
@ -378,8 +378,8 @@
(define (poly-fail t argtypes #:name [name #f]) (define (poly-fail t argtypes #:name [name #f])
(match t (match t
[(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests _ _) ...))) [(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '() _ _) ...)))
(PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests _ _) ...)))) (PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '() _ _) ...))))
(let ([fcn-string (if name (let ([fcn-string (if name
(format "function ~a (over ~~a)" (syntax->datum name)) (format "function ~a (over ~~a)" (syntax->datum name))
"function over ~a")]) "function over ~a")])
@ -429,7 +429,7 @@
"Wrong number of arguments to parameter - expected 0 or 1, got ~a" "Wrong number of arguments to parameter - expected 0 or 1, got ~a"
(length argtypes))])] (length argtypes))])]
;; single clause functions ;; single clause functions
[(tc-result: (and t (Function: (list (arr: dom rng rest #f latent-thn-effs latent-els-effs)))) [(tc-result: (and t (Function: (list (arr: dom rng rest #f '() latent-thn-effs latent-els-effs))))
thn-eff els-eff) thn-eff els-eff)
(let-values ([(thn-eff els-eff) (let-values ([(thn-eff els-eff)
(tc-args argtypes arg-thn-effs arg-els-effs dom rest (tc-args argtypes arg-thn-effs arg-els-effs dom rest
@ -437,7 +437,7 @@
(syntax->list args))]) (syntax->list args))])
(ret rng thn-eff els-eff))] (ret rng thn-eff els-eff))]
;; non-polymorphic case-lambda functions ;; non-polymorphic case-lambda functions
[(tc-result: (and t (Function: (list (arr: doms rngs rests (and drests #f) latent-thn-effs latent-els-effs) ..1))) [(tc-result: (and t (Function: (list (arr: doms rngs rests (and drests #f) '() latent-thn-effs latent-els-effs) ..1)))
thn-eff els-eff) thn-eff els-eff)
(let loop ([doms* doms] [rngs rngs] [rests* rests]) (let loop ([doms* doms] [rngs rngs] [rests* rests])
(cond [(null? doms*) (cond [(null? doms*)
@ -453,19 +453,19 @@
;; simple polymorphic functions, no rest arguments ;; simple polymorphic functions, no rest arguments
[(tc-result: (and t [(tc-result: (and t
(or (Poly: vars (or (Poly: vars
(Function: (list (arr: doms rngs (and rests #f) (and drests #f) thn-effs els-effs) ...))) (Function: (list (arr: doms rngs (and rests #f) (and drests #f) '() thn-effs els-effs) ...)))
(PolyDots: (list vars ... _) (PolyDots: (list vars ... _)
(Function: (list (arr: doms rngs (and rests #f) (and drests #f) thn-effs els-effs) ...)))))) (Function: (list (arr: doms rngs (and rests #f) (and drests #f) '() thn-effs els-effs) ...))))))
(handle-clauses (doms rngs) f-stx (handle-clauses (doms rngs) f-stx
(lambda (dom _) (= (length dom) (length argtypes))) (lambda (dom _) (= (length dom) (length argtypes)))
(lambda (dom rng) (infer (fv/list (cons rng dom)) argtypes dom rng (fv rng) expected)) (lambda (dom rng) (infer (fv/list (cons rng dom)) argtypes dom rng (fv rng) expected))
t argtypes expected)] t argtypes expected)]
;; polymorphic varargs ;; polymorphic varargs
[(tc-result: (and t [(tc-result: (and t
(or (Poly: vars (Function: (list (arr: doms rngs rests (and drests #f) thn-effs els-effs) ...))) (or (Poly: vars (Function: (list (arr: doms rngs rests (and drests #f) '() thn-effs els-effs) ...)))
;; we want to infer the dotted-var here as well, and we don't use these separately ;; we want to infer the dotted-var here as well, and we don't use these separately
;; so we can just use "vars" instead of (list fixed-vars ... dotted-var) ;; so we can just use "vars" instead of (list fixed-vars ... dotted-var)
(PolyDots: vars (Function: (list (arr: doms rngs rests (and drests #f) thn-effs els-effs) ...)))))) (PolyDots: vars (Function: (list (arr: doms rngs rests (and drests #f) '() thn-effs els-effs) ...))))))
(printf/log "Polymorphic varargs function application (~a)\n" (syntax->datum f-stx)) (printf/log "Polymorphic varargs function application (~a)\n" (syntax->datum f-stx))
(handle-clauses (doms rests rngs) f-stx (handle-clauses (doms rests rngs) f-stx
(lambda (dom rest rng) (<= (length dom) (length argtypes))) (lambda (dom rest rng) (<= (length dom) (length argtypes)))
@ -474,7 +474,7 @@
;; polymorphic ... type ;; polymorphic ... type
[(tc-result: (and t (PolyDots: [(tc-result: (and t (PolyDots:
(and vars (list fixed-vars ... dotted-var)) (and vars (list fixed-vars ... dotted-var))
(Function: (list (arr: doms rngs (and #f rests) (cons dtys dbounds) thn-effs els-effs) ...))))) (Function: (list (arr: doms rngs (and #f rests) (cons dtys dbounds) '() thn-effs els-effs) ...)))))
(printf/log "Polymorphic ... function application (~a)\n" (syntax->datum f-stx)) (printf/log "Polymorphic ... function application (~a)\n" (syntax->datum f-stx))
(handle-clauses (doms dtys dbounds rngs) f-stx (handle-clauses (doms dtys dbounds rngs) f-stx
(lambda (dom dty dbound rng) (and (<= (length dom) (length argtypes)) (lambda (dom dty dbound rng) (and (<= (length dom) (length argtypes))
@ -585,7 +585,7 @@
[(Values: ts) ts] [(Values: ts) ts]
[_ (list t)])) [_ (list t)]))
(match prod-t (match prod-t
[(Function: (list (arr: (list) vals _ #f _ _))) [(Function: (list (arr: (list) vals _ #f '() _ _)))
(tc/funapp #'con #'prod (tc-expr #'con) (map ret (values-ty->list vals)) expected)] (tc/funapp #'con #'prod (tc-expr #'con) (map ret (values-ty->list vals)) expected)]
[_ (tc-error/expr #:return (ret (Un)) [_ (tc-error/expr #:return (ret (Un))
"First argument to call with values must be a function that can accept no arguments, got: ~a" "First argument to call with values must be a function that can accept no arguments, got: ~a"