diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss index b9fdfe2e..2414b552 100644 --- a/collects/typed-scheme/private/prims.ss +++ b/collects/typed-scheme/private/prims.ss @@ -124,16 +124,20 @@ This file defines two sorts of primitives. All of them are provided into any mod (define-syntax (plambda: stx) (syntax-case stx () [(plambda: (tvars ...) formals . body) - (syntax-property #'(lambda: formals . body) - 'typechecker:plambda - #'(tvars ...))])) + (quasisyntax/loc stx + (#%expression + #,(syntax-property (syntax/loc stx (lambda: formals . body)) + 'typechecker:plambda + #'(tvars ...))))])) (define-syntax (pcase-lambda: stx) (syntax-case stx () [(pcase-lambda: (tvars ...) cl ...) - (syntax-property #'(case-lambda: cl ...) - 'typechecker:plambda - #'(tvars ...))])) + (quasisyntax/loc stx + (#%expression + #,(syntax-property (syntax/loc stx (case-lambda: cl ...)) + 'typechecker:plambda + #'(tvars ...))))])) (define-syntax (pdefine: stx) (syntax-case stx (:) @@ -173,8 +177,11 @@ This file defines two sorts of primitives. All of them are provided into any mod (define-syntax (inst stx) (syntax-case stx (:) - [(_ arg : tys ...) - (syntax-property #'arg 'type-inst #'(tys ...))] + [(_ arg : . tys) + (syntax/loc stx (inst arg . tys))] + [(_ arg tys ... ty ddd b) + (eq? (syntax-e #'ddd) '...) + (syntax-property #'arg 'type-inst #'(tys ... (ty . b)))] [(_ arg tys ...) (syntax-property #'arg 'type-inst #'(tys ...))])) diff --git a/collects/typed-scheme/private/type-effect-convenience.ss b/collects/typed-scheme/private/type-effect-convenience.ss index a0c6c815..cf76cb55 100644 --- a/collects/typed-scheme/private/type-effect-convenience.ss +++ b/collects/typed-scheme/private/type-effect-convenience.ss @@ -35,12 +35,12 @@ [(False-Effect:) eff] [_ (error 'internal-tc-error "can't add var to effect ~a" eff)])) -(define-syntax -> - (syntax-rules (:) +(define-syntax (-> stx) + (syntax-case* stx (:) (lambda (a b) (eq? (syntax-e a) (syntax-e b))) [(_ dom ... rng : eff1 eff2) - (->* (list dom ...) rng : eff1 eff2)] + #'(->* (list dom ...) rng : eff1 eff2)] [(_ dom ... rng) - (->* (list dom ...) rng)])) + #'(->* (list dom ...) rng)])) (define-syntax ->* (syntax-rules (:) diff --git a/collects/typed-scheme/private/type-utils.ss b/collects/typed-scheme/private/type-utils.ss index 9da1fe36..5987266e 100644 --- a/collects/typed-scheme/private/type-utils.ss +++ b/collects/typed-scheme/private/type-utils.ss @@ -16,6 +16,7 @@ subst ret instantiate-poly + instantiate-poly-dotted tc-result: tc-result-equal? effects-equal? @@ -52,10 +53,6 @@ (define (sb t) (substitute-dots images name t)) (if (hash-ref (free-vars* target) name #f) (type-case sb target - ;; The way I handled this in my type system is via type validity checking. Hrmm. - #;[#:F name* (if (eq? name* name) - (int-err "substitute-dots: got single variable ~a" name*) - target)] [#:F name* target] [#:arr dom rng rest drest thn-eff els-eff (if (and (pair? drest) @@ -78,6 +75,27 @@ (map (lambda (e) (sub-eff sb e)) els-eff)))]) target)) +;; implements sd from the formalism +;; substitute-dotted : Type Name Type Name -> Type +(define (substitute-dotted image image-bound name target) + (define (sb t) (substitute-dotted image image-bound name t)) + (if (hash-ref (free-vars* target) name #f) + (type-case sb target + [#:F name* + (if (eq? name* name) + image + target)] + [#:arr dom rng rest drest thn-eff els-eff + (make-arr (map sb dom) + (sb rng) + (and rest (sb rest)) + (and drest + (cons (sb (car drest)) + (if (eq? name (cdr drest)) image-bound (cdr drest)))) + (map (lambda (e) (sub-eff sb e)) thn-eff) + (map (lambda (e) (sub-eff sb e)) els-eff))]) + target)) + ;; substitute many variables ;; substitution = Listof[List[Name,Type]] ;; subst-all : substition Type -> Type @@ -105,7 +123,16 @@ [rest-tys (drop types (length fixed))] [body* (subst-all (map list fixed fixed-tys) body)]) (substitute-dots rest-tys dotted body*))] - [_ (int-err "instantiate-many: requires Poly type, got ~a" t)])) + [_ (int-err "instantiate-poly: requires Poly type, got ~a" t)])) + +(define (instantiate-poly-dotted t types image var) + (match t + [(PolyDots: (list fixed ... dotted) body) + (unless (= (length fixed) (length types)) + (int-err "instantiate-poly-dotted: wrong number of types: expected ~a, got ~a" (length fixed) (length types))) + (let ([body* (subst-all (map list fixed types) body)]) + (substitute-dotted image var dotted body*))] + [_ (int-err "instantiate-poly-dotted: requires PolyDots type, got ~a" t)])) ;; this structure represents the result of typechecking an expression