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

Handle rest args and case-lambda in app.

Browse Source 
Fix parsing.

svn: r14722
This commit is contained in:
Sam Tobin-Hochstadt 2009-05-05 19:10:21 +00:00
parent 6b89062d6a
commit 59dbcade9c
5 changed files with 99 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/typed-scheme/private/parse-type.ss
View File

@ -570,7 +570,7 @@
[(values t ...)
#:when (eq? 'values (syntax-e #'values))
(ret (map parse-type (syntax->list #'(t ...))))]
[t (parse-type #'t)]))
[t (ret (parse-type #'t))]))
(define parse-tc-results/id (parse/id parse-tc-results))

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

@ -1,13 +1,24 @@
#lang typed-scheme
(: f (Number String -> Number))
(define (f x z) (f x z))
(define (f x z) #;(f x z) 7)
(lambda: ([x : Any] [y : Any]) (values (number? y) (number? x)))
(lambda: ([x : Any] [y : Any]) (values (number? x) (number? y)))
(lambda: ([x : Any] [y : Any]) (values (and (number? x) (boolean? y)) (number? y)))
(lambda: ([x : Any]) (values (number? x) (number? x)))
(: g (Any -> Boolean : Number))
(define g (lambda: ([x : Any]) (number? x)))
(: q ((Number -> Number) -> Number))
(define q (lambda: ([x : (Number -> Number)]) (x 1)))
;(q (lambda (z) (f z "foo")))
(: p (Number * -> Number))
(define (p . x) 7)
(lambda x (number? x))
(+)
(+ 1 2 3)
(+ 1 2 3.5)
;(f 12 "hi")

41
collects/typed-scheme/typecheck/tc-app-helper.ss Normal file
View File

@ -0,0 +1,41 @@
#lang scheme/base
(require "../utils/utils.ss"
(utils tc-utils))
(provide (all-defined-out))
(define (stringify-domain dom rst drst [rng #f])
(let ([doms-string (if (null? dom) "" (string-append (stringify dom) " "))]
[rng-string (if rng (format " -> ~a" rng) "")])
(cond [drst
(format "~a~a ... ~a~a" doms-string (car drst) (cdr drst) rng-string)]
[rst
(format "~a~a *~a" doms-string rst rng-string)]
[else (string-append (stringify dom) rng-string)])))
(define (domain-mismatches ty doms rests drests rngs arg-tys tail-ty tail-bound #:expected [expected #f])
(define arguments-str
(stringify-domain arg-tys (if (not tail-bound) tail-ty #f) (if tail-bound (cons tail-ty tail-bound) #f)))
(cond
[(null? doms)
(int-err "How could doms be null: ~a ~a" ty)]
[(= 1 (length doms))
(format "Domain: ~a~nArguments: ~a~n~a"
(stringify-domain (car doms) (car rests) (car drests))
arguments-str
(if expected
(format "Result type: ~a~nExpected result: ~a~n"
(car rngs) expected)
""))]
[else
(format "~a: ~a~nArguments: ~a~n~a"
(if expected "Types" "Domains")
(stringify (if expected
(map stringify-domain doms rests drests rngs)
(map stringify-domain doms rests drests))
"~n\t")
arguments-str
(if expected
(format "Expected result: ~a~n" expected)
""))]))

51
collects/typed-scheme/typecheck/tc-app.ss
View File

@ -2,9 +2,10 @@
(require (rename-in "../utils/utils.ss" [infer r:infer])
"signatures.ss" "tc-metafunctions.ss"
"tc-app-helper.ss"
stxclass scheme/match mzlib/trace
(for-syntax stxclass)
(types utils abbrev)
(types utils abbrev union subtype)
(utils tc-utils)
(rep type-rep filter-rep object-rep)
(for-template
@ -88,24 +89,48 @@
(define (in-indexes dom)
(in-range (length dom)))
;; syntax? syntax? tc-results? (listof tc-results?) (or/c #f tc-results) -> tc-results?
(define (tc/funapp f-stx args-stx ftype0 argtys expected)
(match* (ftype0 argtys)
[((tc-result1: (Function: (list (arr: dom (Values: (list (Result: t-r lf-r lo-r) ...)) #f #f '()))))
;; we special-case this (no case-lambda) for improved error messages
[((tc-result1: (and t (Function: (list (and a (arr: dom (Values: (list (Result: t-r lf-r lo-r) ...)) rest #f kws))))))
argtys)
(tc/funapp1 f-stx args-stx a argtys expected)]
[((tc-result1: (and t (Function: (and arrs (list (arr: doms rngs rests #f kws) ...)))))
(and argtys (list (tc-result1: argtys-t) ...)))
(let loop ([doms* doms] [rngs rngs] [rests* rests] [a arrs])
(cond [(null? doms*)
(tc-error/expr
#:return (or expected (ret (Un)))
(string-append "No function domains matched in function application:\n"
(domain-mismatches t doms rests #f rngs argtys #f #f)))]
[(subtypes/varargs argtys-t (car doms*) (car rests*))
(tc/funapp1 f-stx args-stx (car a) argtys expected #:check #f)]
[else (loop (cdr doms*) (cdr rngs) (cdr rests*) (cdr a))]))]))
;; syntax? syntax? arr? (listof tc-results?) (or/c #f tc-results) [boolean?] -> tc-results?
(define (tc/funapp1 f-stx args-stx ftype0 argtys expected #:check [check? #t])
(match* (ftype0 argtys)
[((arr: dom (Values: (list (Result: t-r lf-r lo-r) ...)) rest #f '())
(list (tc-result1: t-a phi-a o-a) ...))
(unless (= (length dom) (length t-a))
(tc-error/expr #:return (ret t-r)
"Wrong number of arguments"))
(for ([dom-t (in-list dom)] [arg-t (in-list t-a)])
(check-below arg-t dom-t))
(when check?
(cond [(and (not rest) (not (= (length dom) (length t-a))))
(tc-error/expr #:return (ret t-r)
"Wrong number of arguments, expected ~a and got ~a" (length dom) (length t-a))]
[(and rest (< (length t-a) (length dom)))
(tc-error/expr #:return (ret t-r)
"Wrong number of arguments, expected at least ~a and got ~a" (length dom) (length t-a))])
(for ([dom-t (in-list-forever dom rest)] [a (syntax->list args-stx)] [arg-t (in-list t-a)])
(parameterize ([current-orig-stx a]) (check-below arg-t dom-t))))
(let* (;; Listof[Listof[LFilterSet]]
[lfs-f (for/list ([lf lf-r])
(for/list ([i (in-indexes dom)])
(split-lfilters lf i)))]
(for/list ([i (in-indexes dom)])
(split-lfilters lf i)))]
;; Listof[FilterSet]
[f-r (for/list ([lfs lfs-f])
(merge-filter-sets (for/list ([lf lfs] [t t-a] [o o-a])
(apply-filter lf t o))))]
(merge-filter-sets
(for/list ([lf lfs] [t t-a] [o o-a])
(apply-filter lf t o))))]
;; Listof[Object]
[o-r (for/list ([lo lo-r])
(match lo
@ -116,4 +141,4 @@
[_ (make-Empty)]))])
(ret t-r f-r o-r))]
[(_ _)
(int-err "funapp with keyword/rest args NYI")]))
(int-err "funapp with keyword args NYI")]))

13
collects/typed-scheme/typecheck/tc-lambda-unit.ss
View File

@ -5,7 +5,7 @@
"tc-metafunctions.ss"
mzlib/trace
scheme/list
stxclass/util
stxclass/util syntax/stx
(rename-in scheme/contract [-> -->] [->* -->*] [one-of/c -one-of/c])
(except-in (rep type-rep) make-arr)
(rename-in (types convenience utils union)
@ -160,10 +160,11 @@
#f
(tc-exprs (syntax->list body)))))]))]))
;; FIXED TO HERE
;(trace tc-args)
(define (formals->list l)
(let loop ([l (syntax-e l)])
(cond [(stx-pair? l) (cons (stx-car l) (loop (stx-cdr l)))]
[(pair? l) (cons (car l) (loop (cdr l)))]
[else null])))
;; tc/mono-lambda : syntax-list syntax-list (or/c #f tc-results) -> (listof lam-result)
;; typecheck a sequence of case-lambda clauses
@ -200,7 +201,7 @@
[(tc-result1: (Function: (list (arr: argss rets rests drests '()) ...)))
(for/list ([args argss] [ret rets] [rest rests] [drest drests])
(tc/lambda-clause/check (car (syntax->list formals)) (car (syntax->list bodies))
args (values->tc-results ret (syntax->list (car (syntax->list formals)))) rest drest))]
args (values->tc-results ret (formals->list (car (syntax->list formals)))) rest drest))]
[_ (go (syntax->list formals) (syntax->list bodies) null null null)]))]
;; otherwise
[else (go (syntax->list formals) (syntax->list bodies) null null null)]))