diff --git a/collects/honu/private/typechecker/typecheck-utils.ss b/collects/honu/private/typechecker/typecheck-utils.ss index 5d757aa807..88b5e8c575 100644 --- a/collects/honu/private/typechecker/typecheck-utils.ss +++ b/collects/honu/private/typechecker/typecheck-utils.ss @@ -9,6 +9,7 @@ (provide/contract [check-valid-type! (string? honu:type? . -> . void?)] + [check-valid-types! (string? (listof honu:type?) . -> . void?)] ) ;; check-valid-type! : Name Type -> Void @@ -19,4 +20,9 @@ (format "~s is undefined" name) (honu:ast-stx type)))) + ;; check-valid-types! : Name [Listof Type] -> Void + ;; Raises an error if any of the named types are not valid. + (define (check-valid-types! name types) + (for-each (curry check-valid-type! name) types)) + ) diff --git a/collects/honu/private/typechecker/typechecker.ss b/collects/honu/private/typechecker/typechecker.ss index 66e9f9f027..6d284efbb5 100644 --- a/collects/honu/private/typechecker/typechecker.ss +++ b/collects/honu/private/typechecker/typechecker.ss @@ -43,8 +43,7 @@ (format "Argument name ~a used more than once" (printable-key conflicting-name)) conflicting-name))) - (for-each (curry check-valid-type! "function argument type") - (map honu:formal-type args)) + (check-valid-types! "function argument type" (map honu:formal-type args)) (make-func-type stx (make-tuple-type stx (map honu:formal-type args)) type)])) ;; first we add the functions to the lexical environment so that when we typecheck ;; the bodies, they'll be in scope. @@ -97,8 +96,7 @@ (define (typecheck-iface iface) (match iface [(struct honu:iface (stx name supers members)) - (for-each (curry check-valid-type! "interface supertype") - supers) + (check-valid-types! "interface supertype" supers) (let ([conflicting-name (get-first-non-unique-name (map (lambda (d) (cond [(honu:field-decl? d) @@ -122,8 +120,7 @@ (match class [(struct honu:class (stx name type final? impls inits members exports)) (check-valid-type! "class self-type" type) - (for-each (curry check-valid-type! "implemented type of class") - impls) + (check-valid-types! "implemented type of class" impls) (let ([conflicting-name (get-first-non-unique-name (append (map honu:formal-name inits) (map (lambda (d) (cond @@ -139,8 +136,7 @@ (format "Init/field/method name ~a used more than once" (printable-key conflicting-name)) conflicting-name))) - (for-each (curry check-valid-type! "init slot type") - (map honu:formal-type inits)) + (check-valid-types! "init slot type" (map honu:formal-type inits)) (let ([cenv (srfi1:fold (lambda (a e) (extend-fenv (honu:formal-name a) (honu:formal-type a) @@ -153,16 +149,12 @@ (copy-struct honu:class class [honu:class-members members])))])) - ;; typecheck-mixin : Mixin -> Mixin - ;; Typechecks a mixin definition and produces the annotated version. - (define (typecheck-mixin mixin) + ;; check-mixin-internal-names! : Mixin -> Void + ;; Raises an error if defined names in a mixin conflict with each other. + (define (check-mixin-internal-names! mixin) (match mixin [(struct honu:mixin (stx name type arg-type final? impls inits withs supernew members-before members-after exports)) - (check-valid-type! "mixin argument type" arg-type) - (check-valid-type! "mixin result type" type) - (for-each (curry check-valid-type! "mixin implemented type") - impls) (let* ([arg-tentry (get-type-entry arg-type)] [conflicting-name (get-first-non-unique-name (append (map tenv:member-name (append (tenv:type-members arg-tentry) @@ -182,23 +174,40 @@ (raise-read-error-with-stx (format "Init/field/method name ~a used more than once in mixin or conflicts with members of argument type" (printable-key conflicting-name)) - (honu:ast-stx mixin)))) - (for-each (curry check-valid-type! "init slot type") - (map honu:formal-type inits)) + (honu:ast-stx mixin))))])) + + ;; check-mixin-expected-init-names! : Mixin -> Void + ;; Raises an error if init arguments expected of mixin's argument contain conflicts + (define (check-mixin-expected-init-names! mixin) + (match mixin + [(struct honu:mixin (stx name type arg-type final? impls inits withs + supernew members-before members-after exports)) (let ([conflicting-name (get-first-non-unique-name (map honu:formal-name withs))]) (if conflicting-name (raise-read-error-with-stx (format "Init name ~a used more than once in expected init slots" (printable-key conflicting-name)) - conflicting-name))) - (for-each (curry check-valid-type! "type of expected init slot") - (map honu:formal-type withs)) + conflicting-name)))])) + + ;; typecheck-mixin : Mixin -> Mixin + ;; Typechecks a mixin definition and produces the annotated version. + (define (typecheck-mixin mixin) + (match mixin + [(struct honu:mixin (stx name type arg-type final? impls inits withs + supernew members-before members-after exports)) + (check-valid-type! "mixin argument type" arg-type) + (check-valid-type! "mixin result type" type) + (check-valid-types! "mixin implemented type" impls) + (check-mixin-internal-names! mixin) + (check-valid-types! "init slot type" (map honu:formal-type inits)) + (check-mixin-expected-init-names! mixin) + (check-valid-types! "type of expected init slot" (map honu:formal-type withs)) (let ([cenv (srfi1:fold (lambda (a e) - (extend-fenv (honu:formal-name a) - (honu:formal-type a) - e)) - (lambda (n) #f) - inits)]) + (extend-fenv (honu:formal-name a) + (honu:formal-type a) + e)) + empty-fenv + inits)]) (let*-values ([(lenv) (extend-fenv #'this type (wrap-lenv))] [(members-before cenv) (typecheck-members cenv lenv type members-before)] [(supernew) (typecheck-supernew cenv lenv withs supernew)] @@ -238,7 +247,6 @@ (check-valid-type! "field type" type)] [(struct honu:method-decl (stx name type args)) (check-valid-type! "method return type" type) - (for-each (curry check-valid-type! "method argument type") - args)])) + (check-valid-types! "method argument type" args)])) ) diff --git a/collects/honu/tenv.ss b/collects/honu/tenv.ss index daf5283cbc..69637e44af 100644 --- a/collects/honu/tenv.ss +++ b/collects/honu/tenv.ss @@ -7,15 +7,6 @@ "parameters.ss" "readerr.ss") - (provide (struct tenv:entry (stx)) - (struct tenv:init (name type optional?)) - (struct tenv:member (stx name type)) - (struct tenv:type (supers members inherited)) - (struct tenv:class (sub-type impls inits final? super)) - (struct tenv:mixin (arg-type sub-type impls inits - withs final?)) - (struct tenv:value (type))) - (define-struct tenv:entry (stx) #f) (define-struct tenv:init (name type optional?) #f) @@ -81,20 +72,8 @@ (make-honu:type-prim #f 'float))) )) - (provide tenv?) (define tenv? bound-identifier-mapping?) - (provide/contract [printable-key (identifier? . -> . symbol?)] - [tenv-key=? (identifier? identifier? . -> . any)] - [tenv-key . any)] - [tenv-map (tenv? - (identifier? tenv:entry? . -> . any) - . -> . - list?)] - [tenv-for-each (tenv? - (identifier? tenv:entry? . -> . void?) - . -> . - void?)]) (define printable-key syntax-e) (define tenv-key=? bound-identifier=?) (define (tenv-key tenv?)] - [get-builtin-lenv (-> tenv?)] - [extend-tenv (identifier? tenv:entry? . -> . void?)] - [extend-lenv (identifier? tenv:value? . -> . void?)] - [extend-tenv-without-checking (identifier? tenv:entry? . -> . void?)]) - (define (empty-tenv) (make-bound-identifier-mapping)) (define (get-builtin-lenv) (create-tenv (map car builtin-list) @@ -142,21 +115,11 @@ table))) ;; only use this if you a) don't want an error or b) don't know what you should get. - (provide/contract [get-tenv-entry (identifier? . -> . (union tenv:entry? false/c))] - [get-lenv-entry (identifier? . -> . (union tenv:entry? false/c))]) (define (get-tenv-entry key) (bound-identifier-mapping-get (current-type-environment) key (lambda () #f))) (define (get-lenv-entry key) (bound-identifier-mapping-get (current-lexical-environment) key (lambda () #f))) - (provide/contract [get-type-entry ((union honu:type-iface? - honu:type-iface-top?) . -> . tenv:type?)] - [get-class-entry (identifier? . -> . tenv:class?)] - [get-mixin-entry (identifier? . -> . tenv:mixin?)] - [get-member-type ((union honu:type-iface? - honu:type-iface-top?) - identifier? . -> . honu:type?)] - [get-value-entry (identifier? . -> . tenv:value?)]) (define (get-type-entry type) (if (honu:type-iface-top? type) (make-tenv:type #f (list) (list) (list)) @@ -224,8 +187,7 @@ name)] [else entry]))) - (provide wrap-lenv extend-fenv) - + (define (fenv? v) (and (procedure? v) (procedure-arity-includes? v 1))) (define (wrap-lenv) (wrap-as-function (current-lexical-environment))) (define (wrap-as-function tenv) (lambda (name) @@ -238,4 +200,47 @@ value (fenv name)))) + (define empty-fenv (lambda (name) #f)) + + (provide (struct tenv:entry (stx)) + (struct tenv:init (name type optional?)) + (struct tenv:member (stx name type)) + (struct tenv:type (supers members inherited)) + (struct tenv:class (sub-type impls inits final? super)) + (struct tenv:mixin (arg-type sub-type impls inits + withs final?)) + (struct tenv:value (type))) + (provide/contract [tenv? (any/c . -> . boolean?)] + [printable-key (identifier? . -> . symbol?)] + [tenv-key=? (identifier? identifier? . -> . any)] + [tenv-key . any)] + [tenv-map (tenv? + (identifier? tenv:entry? . -> . any) + . -> . + list?)] + [tenv-for-each (tenv? + (identifier? tenv:entry? . -> . void?) + . -> . + void?)] + [empty-tenv (-> tenv?)] + [get-builtin-lenv (-> tenv?)] + [extend-tenv (identifier? tenv:entry? . -> . void?)] + [extend-lenv (identifier? tenv:value? . -> . void?)] + [extend-tenv-without-checking (identifier? tenv:entry? . -> . void?)] + [get-tenv-entry (identifier? . -> . (union tenv:entry? false/c))] + [get-lenv-entry (identifier? . -> . (union tenv:entry? false/c))] + [get-type-entry ((union honu:type-iface? + honu:type-iface-top?) . -> . tenv:type?)] + [get-class-entry (identifier? . -> . tenv:class?)] + [get-mixin-entry (identifier? . -> . tenv:mixin?)] + [get-member-type ((union honu:type-iface? + honu:type-iface-top?) + identifier? . -> . honu:type?)] + [get-value-entry (identifier? . -> . tenv:value?)] + [fenv? (any/c . -> . boolean?)] + [wrap-lenv (-> fenv?)] + [empty-fenv fenv?] + [extend-fenv (identifier? honu:type? fenv? . -> . fenv?)] + ) + )