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

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

@ -120,38 +120,91 @@
;(trace tc-args)
(define (tc/apply f args)
(let* ([f-ty (tc-expr f)]
[arg-tys0 (map tc-expr/t (syntax->list args))])
(define f-ty (tc-expr f))
;; produces the first n-1 elements of the list, and the last element
(define (split l)
(let loop ([l l] [acc '()])
(if (null? (cdr l))
(values (reverse acc) (car l))
(loop (cdr l) (cons (car l) acc)))))
(let-values ([(arg-tys tail-ty) (split arg-tys0)])
(define (printable dom rst)
(list dom rst '..))
(match f-ty
[(tc-result: (Function: (list (arr: doms rngs rests #f thn-effs els-effs) ..1)))
(let loop ([doms* doms] [rngs* rngs] [rests* rests])
(cond [(null? doms*)
(define (printable dom rst drst)
(let ([doms-string (if (null? dom) "" (string-append (stringify dom) " "))])
(if rst
(format "~a~a *" doms-string rst)
(format "~a~a ... ~a" doms-string (car drst) (cdr drst)))))
(define-values (fixed-args tail) (split (syntax->list args)))
(define (apply-error doms rests drests arg-tys tail-ty tail-bound)
(if (and (not (null? doms)) (null? (cdr doms)))
(tc-error/expr
#:return (ret (Un))
"bad arguments to apply - function expected ~a fixed arguments and (Listof ~a) rest argument, given ~a"
(car doms) (car rests) arg-tys0)
(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 - domains were: ~a arguments were ~a"
(map printable doms rests)
arg-tys0))]
[(and (subtypes arg-tys (car doms*)) (car rests*) (subtype tail-ty (make-Listof (car rests*))))
"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*))]
[else (loop (cdr doms*) (cdr rngs*) (cdr rests*))]))]
[(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)))
arg-tys0)
(cons tail-ty arg-tys))
(let loop ([doms* doms] [rngs* rngs] [rests* rests])
(cond [(null? doms*)
(match f-ty
@ -188,12 +241,12 @@
(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*))]))]
[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)]))))
"Type of argument to apply is not a function type: ~n~a" f-ty)]))
(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)
(cond [(syntax->list s) => length]
[else (let loop ([s s])
(if (pair? (syntax-e s))
(+ 1 (loop (cdr (syntax-e s))))
1))]))
(cond
[(pair? s)
(+ 1 (loop (cdr s)))]
[(pair? (syntax-e s))
(+ 1 (loop (cdr (syntax-e s))))]
[else 1]))]))
(if (and expected
(= 1 (length (syntax->list formals))))
;; 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 -Port (*Un -Input-Port -Output-Port))
(define (-lst* . args) (if (null? args)
(-val null)
(-pair (car args) (apply -lst* (cdr args)))))
(define (-lst* #:tail [tail (-val null)] . args)
(if (null? args)
tail
(-pair (car args) (apply -lst* #:tail tail (cdr args)))))
#;(define NE (-mu x (Un N (make-Listof x))))