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

Add handling of dotted functions when not wrapped with a big lambda.

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2008-06-17 12:57:29 -04:00
parent 8bf60f9faf
commit 1bef5f9d0b
3 changed files with 135 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -120,80 +120,133 @@
;(trace tc-args) ;(trace tc-args)
(define (tc/apply f args) (define (tc/apply f args)
(let* ([f-ty (tc-expr f)] (define f-ty (tc-expr f))
[arg-tys0 (map tc-expr/t (syntax->list args))]) ;; produces the first n-1 elements of the list, and the last element
;; produces the first n-1 elements of the list, and the last element (define (split l)
(define (split l) (let loop ([l l] [acc '()])
(let loop ([l l] [acc '()]) (if (null? (cdr l))
(if (null? (cdr l)) (values (reverse acc) (car l))
(values (reverse acc) (car l)) (loop (cdr l) (cons (car l) acc)))))
(loop (cdr l) (cons (car l) acc))))) (define (printable dom rst drst)
(let-values ([(arg-tys tail-ty) (split arg-tys0)]) (let ([doms-string (if (null? dom) "" (string-append (stringify dom) " "))])
(define (printable dom rst) (if rst
(list dom rst '..)) (format "~a~a *" doms-string rst)
(match f-ty (format "~a~a ... ~a" doms-string (car drst) (cdr drst)))))
[(tc-result: (Function: (list (arr: doms rngs rests #f thn-effs els-effs) ..1))) (define-values (fixed-args tail) (split (syntax->list args)))
(let loop ([doms* doms] [rngs* rngs] [rests* rests]) (define (apply-error doms rests drests arg-tys tail-ty tail-bound)
(cond [(null? doms*) (if (and (not (null? doms)) (null? (cdr doms)))
(if (and (not (null? doms)) (null? (cdr doms))) (tc-error/expr
#:return (ret (Un))
(string-append
"bad arguments to apply~n - function expected ~a as fixed arguments and ~a as a rest argument,~n"
" - given ~a as fixed arguments and ~a as a rest argument~n")
(if (null? (car doms))
"nothing"
(stringify (car doms)))
(if (car rests)
(format "~a *" (car rests))
(format "~a ... ~a" (car (car drests)) (cdr (car drests))))
(if (null? arg-tys)
"nothing"
(stringify arg-tys))
(if tail-bound
(format "~a ... ~a" tail-ty tail-bound)
tail-ty))
(tc-error/expr
#:return (ret (Un))
"no function domain matched in apply~ndomains were: ~n\t~a~narguments were: \n\t~a\n"
(stringify (map printable doms rests drests) "\n\t")
(stringify (append arg-tys (list (if tail-bound
(string-append tail-ty " ... " tail-bound)
tail-ty)))))))
(match f-ty
[(tc-result: (Function: (list (arr: doms rngs rests drests thn-effs els-effs) ...)))
(when (null? doms)
(tc-error/expr #:return (ret (Un))
"empty case-lambda given as argument to apply"))
(let ([arg-tys (map tc-expr/t fixed-args)])
(let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests])
(cond [(null? doms*)
(let-values ([(tail-ty tail-bound)
(with-handlers ([exn:fail? (lambda _ (values #f #f))])
(tc/dots tail))])
(if tail-ty
(apply-error doms rests drests arg-tys tail-ty tail-bound)
(apply-error doms rests drests arg-tys (tc-expr/t tail) #f)))]
[(and (car rests*)
(let-values ([(tail-ty tail-bound)
(with-handlers ([exn:fail? (lambda _ (values #f #f))])
(tc/dots tail))])
(and tail-ty
(subtype (apply -lst* arg-tys #:tail (make-Listof tail-ty))
(apply -lst* (car doms*) #:tail (make-Listof (car rests*)))))))
(ret (car rngs*))]
[(and (car rests*)
(let ([tail-ty (with-handlers ([exn:fail? (lambda _ #f)])
(tc-expr/t tail))])
(and tail-ty
(subtype (apply -lst* arg-tys #:tail tail-ty)
(apply -lst* (car doms*) #:tail (make-Listof (car rests*)))))))
(ret (car rngs*))]
[(and (car drests*)
(let-values ([(tail-ty tail-bound)
(with-handlers ([exn:fail? (lambda _ (values #f #f))])
(tc/dots tail))])
(and tail-ty
(eq? (cdr (car drests*)) tail-bound)
(subtypes arg-tys (car doms*))
(subtype tail-ty (car (car drests*))))))
(ret (car rngs*))]
[else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))]
[(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests #f thn-effs els-effs) ..1))))
(let*-values ([(arg-tys tail-ty) (values (map tc-expr/t fixed-args)
(tc-expr/t tail))]
[(arg-tys0) (append arg-tys (list tail-ty))])
(for-each (lambda (x) (unless (not (Poly? x))
(tc-error "Polymorphic argument ~a to polymorphic function in apply not allowed" x)))
(cons tail-ty arg-tys))
(let loop ([doms* doms] [rngs* rngs] [rests* rests])
(cond [(null? doms*)
(match f-ty
[(tc-result: (Poly-names: vars (Function: (list (arr: doms rngs rests #f thn-effs els-effs) ..1))))
(cond
[(null? doms) (int-err "how could doms be null: ~a ~a" doms f-ty)]
[(= 1 (length doms))
(if (car rests)
(tc-error/expr
#:return (ret (Un))
"polymorphic function domain did not match -~ndomain was: ~a~nrest argument was: ~a~narguments were ~a~n"
(car doms) (car rests) (stringify arg-tys0))
(tc-error/expr
#:return (ret (Un))
"polymorphic function domain did not match -~ndomain was: ~a~narguments were ~a~n"
(car doms) (stringify arg-tys0)))]
[else
(tc-error/expr (tc-error/expr
#:return (ret (Un)) #:return (ret (Un))
"bad arguments to apply - function expected ~a fixed arguments and (Listof ~a) rest argument, given ~a" "no polymorphic function domain matched - ~ndomains were: ~a~narguments were ~a~n"
(car doms) (car rests) arg-tys0) (stringify
(tc-error/expr (for/list ([dom doms] [rest rests])
#:return (ret (Un)) (if rest
"no function domain matched - domains were: ~a arguments were ~a" (format "~a rest argument: " (stringify dom) rest)
(map printable doms rests) (stringify dom)))
arg-tys0))] "\n")
[(and (subtypes arg-tys (car doms*)) (car rests*) (subtype tail-ty (make-Listof (car rests*)))) (stringify arg-tys0))])])]
(ret (car rngs*))] [(and (= (length (car doms*))
[else (loop (cdr doms*) (cdr rngs*) (cdr rests*))]))] (length arg-tys))
[(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests #f thn-effs els-effs) ..1)))) (infer vars arg-tys0 (append (car doms*) (list (make-Listof (car rests*)))) (car rngs*)))
(for-each (lambda (x) (unless (not (Poly? x)) => (lambda (substitution)
(tc-error "Polymorphic argument ~a to polymorphic function in apply not allowed" x))) (let* ([s (lambda (t) (subst-all substitution t))]
arg-tys0) [new-doms* (append (map s (car doms*)) (list (make-Listof (s (car rests*)))))])
(let loop ([doms* doms] [rngs* rngs] [rests* rests]) (unless (andmap subtype arg-tys0 new-doms*)
(cond [(null? doms*) (int-err "Inconsistent substitution - arguments not subtypes: ~n~a~n~a~n" arg-tys0 new-doms*)))
(match f-ty (ret (subst-all substitution (car rngs*))))]
[(tc-result: (Poly-names: vars (Function: (list (arr: doms rngs rests #f thn-effs els-effs) ..1)))) [else (loop (cdr doms*) (cdr rngs*) (cdr rests*))])))]
(cond [(tc-result: (Poly: vars (Function: '())))
[(null? doms) (int-err "how could doms be null: ~a ~a" doms f-ty)] (tc-error/expr #:return (ret (Un))
[(= 1 (length doms)) "Function has no cases")]
(if (car rests) [f-ty (tc-error/expr #:return (ret (Un))
(tc-error/expr "Type of argument to apply is not a function type: ~n~a" f-ty)]))
#:return (ret (Un))
"polymorphic function domain did not match -~ndomain was: ~a~nrest argument was: ~a~narguments were ~a~n"
(car doms) (car rests) (stringify arg-tys0))
(tc-error/expr
#:return (ret (Un))
"polymorphic function domain did not match -~ndomain was: ~a~narguments were ~a~n"
(car doms) (stringify arg-tys0)))]
[else
(tc-error/expr
#:return (ret (Un))
"no polymorphic function domain matched - ~ndomains were: ~a~narguments were ~a~n"
(stringify
(for/list ([dom doms] [rest rests])
(if rest
(format "~a rest argument: " (stringify dom) rest)
(stringify dom)))
"\n")
(stringify arg-tys0))])])]
[(and (= (length (car doms*))
(length arg-tys))
(infer vars arg-tys0 (append (car doms*) (list (make-Listof (car rests*)))) (car rngs*)))
=> (lambda (substitution)
(let* ([s (lambda (t) (subst-all substitution t))]
[new-doms* (append (map s (car doms*)) (list (make-Listof (s (car rests*)))))])
(unless (andmap subtype arg-tys0 new-doms*)
(int-err "Inconsistent substitution - arguments not subtypes: ~n~a~n~a~n" arg-tys0 new-doms*)))
(ret (subst-all substitution (car rngs*))))]
[else (loop (cdr doms*) (cdr rngs*) (cdr rests*))]))]
[(tc-result: (Poly: vars (Function: '())))
(tc-error/expr #:return (ret (Un))
"Function has no cases")]
[f-ty (tc-error/expr #:return (ret (Un))
"Type of argument to apply is not a function type: ~n~a" f-ty)]))))
(define (tc/funapp f-stx args-stx ftype0 argtys expected) (define (tc/funapp f-stx args-stx ftype0 argtys expected)

9
collects/typed-scheme/private/tc-lambda-unit.ss
View File

@ -144,9 +144,12 @@
(define (syntax-len s) (define (syntax-len s)
(cond [(syntax->list s) => length] (cond [(syntax->list s) => length]
[else (let loop ([s s]) [else (let loop ([s s])
(if (pair? (syntax-e s)) (cond
(+ 1 (loop (cdr (syntax-e s)))) [(pair? s)
1))])) (+ 1 (loop (cdr s)))]
[(pair? (syntax-e s))
(+ 1 (loop (cdr (syntax-e s))))]
[else 1]))]))
(if (and expected (if (and expected
(= 1 (length (syntax->list formals)))) (= 1 (length (syntax->list formals))))
;; special case for not-case-lambda ;; special case for not-case-lambda

7
collects/typed-scheme/private/type-effect-convenience.ss
View File

@ -164,9 +164,10 @@
(define -Sexp (-mu x (*Un Sym N B -String (-val null) (-pair x x)))) (define -Sexp (-mu x (*Un Sym N B -String (-val null) (-pair x x))))
(define -Port (*Un -Input-Port -Output-Port)) (define -Port (*Un -Input-Port -Output-Port))
(define (-lst* . args) (if (null? args) (define (-lst* #:tail [tail (-val null)] . args)
(-val null) (if (null? args)
(-pair (car args) (apply -lst* (cdr args))))) tail
(-pair (car args) (apply -lst* #:tail tail (cdr args)))))
#;(define NE (-mu x (Un N (make-Listof x)))) #;(define NE (-mu x (Un N (make-Listof x))))