From 8efd89de4135ba97ed0478e294cb52971d944323 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 17 Jan 2006 23:07:15 +0000 Subject: [PATCH] Honu: - Updated todo list - Promoted "name" field of member ASTs to member (rather than field/method/etc.) - Added false? function - Added extend-fenv for formal parameters - Removed class env (folded in with lexical env) - Added abstraction for member names of a type - Added abstractions for enforcing distinct types and names - Updated mixin typing rule svn: r1854 --- collects/honu/ast.ss | 14 +-- collects/honu/cce-notes.txt | 10 +- collects/honu/parsers/post-parsing.ss | 6 +- collects/honu/private/compiler/translate.ss | 4 +- .../honu/private/typechecker/type-utils.ss | 14 ++- .../typechecker/typecheck-class-utils.ss | 67 +++++++------- .../typechecker/typecheck-expression.ss | 2 +- .../typechecker/typecheck-parameters.ss | 9 -- .../honu/private/typechecker/typechecker.ss | 91 +++++++++---------- collects/honu/tenv-utils.ss | 21 ++--- collects/honu/tenv.ss | 5 + collects/honu/utils.ss | 6 +- 12 files changed, 124 insertions(+), 125 deletions(-) diff --git a/collects/honu/ast.ss b/collects/honu/ast.ss index 96037904fc..121fa0278e 100644 --- a/collects/honu/ast.ss +++ b/collects/honu/ast.ss @@ -56,15 +56,15 @@ (define-honu-struct (bind-top defn) (names types value)) ; used for top-level definitions ;; AST nodes for member declarations (in interfaces) - (define-honu-struct (member-decl ast) ()) ; member-decl? - (define-honu-struct (field-decl member-decl) (name type)) ; used for field declarations - (define-honu-struct (method-decl member-decl) (name type arg-types)) ; used for method declarations + (define-honu-struct (member-decl ast) (name)) ; member-decl? + (define-honu-struct (field-decl member-decl) (type)) ; used for field declarations + (define-honu-struct (method-decl member-decl) (type arg-types)) ; used for method declarations ;; AST nodes for member definitions (in classes/mixins) - (define-honu-struct (member-defn ast) ()) ; member-defn? - (define-honu-struct (init-field member-defn) (name type value)) ; used for init fields (value can be #f or expression AST) - (define-honu-struct (field member-defn) (name type value)) ; used for fields (value can be #f or expression AST) - (define-honu-struct (method member-defn) (name type formals body)) ; used for methods + (define-honu-struct (member-defn ast) (name)) ; member-defn? + (define-honu-struct (init-field member-defn) (type value)) ; used for init fields (value can be #f or expression AST) + (define-honu-struct (field member-defn) (type value)) ; used for fields (value can be #f or expression AST) + (define-honu-struct (method member-defn) (type formals body)) ; used for methods ;; AST node for super call (just in mixins/subclasses) (define-honu-struct (super-new ast) (args)) diff --git a/collects/honu/cce-notes.txt b/collects/honu/cce-notes.txt index 84e8586ac6..a4d4194837 100644 --- a/collects/honu/cce-notes.txt +++ b/collects/honu/cce-notes.txt @@ -1,8 +1,12 @@ Todo: -mixin sealing -improve test suite -numeric functionality +Mixin Sealing +- environments + - single value->type environment (remove class-env) + - implement applicative environments +- define type equality +Test Suite Improvements +Numeric Library ------------------------------------------------------------ diff --git a/collects/honu/parsers/post-parsing.ss b/collects/honu/parsers/post-parsing.ss index ec6aae5626..140ffa92c9 100644 --- a/collects/honu/parsers/post-parsing.ss +++ b/collects/honu/parsers/post-parsing.ss @@ -106,7 +106,7 @@ [(null? members) (values (reverse results) env)] [(honu:method? (car members)) (let-values ([(methods remaining) (span honu:method? members)]) - (let ([env (append (map honu:method-name methods) env)]) + (let ([env (append (map honu:member-defn-name methods) env)]) (loop remaining env ;; reverse is here just to keep the order @@ -115,9 +115,7 @@ members)) results))))] [else - (let ([name (if (honu:field? (car members)) - (honu:field-name (car members)) - (honu:init-field-name (car members)))]) + (let ([name (honu:member-defn-name (car members))]) (loop (cdr members) (cons name env) (cons (convert-static-member (car members) env) results)))]))) diff --git a/collects/honu/private/compiler/translate.ss b/collects/honu/private/compiler/translate.ss index 63ced40111..f8f025787e 100644 --- a/collects/honu/private/compiler/translate.ss +++ b/collects/honu/private/compiler/translate.ss @@ -142,9 +142,7 @@ printable-smembers))))))))) (define (translate-member-formatter member indent-delta) - (let ([name (if (honu:field? member) - (honu:field-name member) - (honu:init-field-name member))]) + (let ([name (honu:member-defn-name member)]) `(format "~a~a = ~a;" (make-string (+ indent ,indent-delta) #\space) (quote ,(syntax-e name)) diff --git a/collects/honu/private/typechecker/type-utils.ss b/collects/honu/private/typechecker/type-utils.ss index 04c7fe72b5..2ffa47a04c 100644 --- a/collects/honu/private/typechecker/type-utils.ss +++ b/collects/honu/private/typechecker/type-utils.ss @@ -1,5 +1,6 @@ (module type-utils mzscheme - (require (lib "list.ss" "srfi" "1") + (require (prefix srfi1: (lib "list.ss" "srfi" "1")) + (lib "contract.ss") (lib "plt-match.ss") "../../ast.ss" "../../readerr.ss" @@ -59,7 +60,7 @@ (if (null? args) "void" (string-append "<" - (fold (lambda (t i) + (srfi1:fold (lambda (t i) (string-append i ", " (printable-type t))) (printable-type (car args)) (cdr args)) @@ -174,7 +175,7 @@ (match type-entry [(struct tenv:type (_ supers _ _)) (let ([super-names (map get-type-name supers)]) - (s:member (get-type-name t2) super-names tenv-key=?))]))) + (srfi1:s:member (get-type-name t2) super-names tenv-key=?))]))) ;; is t1 a (ref-trans-closed) subtype of t2? (provide <:_P) @@ -254,6 +255,13 @@ (<:_P t t2)) (tenv:type-supers type-entry))))] [else #f])) + + (provide/contract [type-member-names (honu:type? . -> . (listof identifier?))]) + (define (type-member-names type) + (let* ([entry (get-type-entry type)]) + (map tenv:member-name + (append (tenv:type-members entry) + (tenv:type-inherited entry))))) (provide iface-name) (define (iface-name type) diff --git a/collects/honu/private/typechecker/typecheck-class-utils.ss b/collects/honu/private/typechecker/typecheck-class-utils.ss index c8596d91be..206db059a0 100644 --- a/collects/honu/private/typechecker/typecheck-class-utils.ss +++ b/collects/honu/private/typechecker/typecheck-class-utils.ss @@ -11,8 +11,9 @@ "typecheck-parameters.ss" "type-utils.ss") - (provide extend-cenv-with-type-members typecheck-members typecheck-supernew typecheck-exports) - (define (typecheck-exports cenv selftype init-impls exports) + (provide extend-lenv-with-type-members typecheck-members typecheck-supernew typecheck-exports) + + (define (typecheck-exports lenv selftype init-impls exports) (let loop ([impls init-impls] [exports exports]) (cond @@ -46,7 +47,7 @@ (printable-type selftype)) (honu:ast-stx selftype)) (let ([type-entry (get-type-entry selftype)]) - (typecheck-export cenv type-entry matched) + (typecheck-export lenv type-entry matched) (if (not (null? non-matches)) (raise-read-error-with-stx (format "Extra export statement for unimplemented type ~a" @@ -64,10 +65,10 @@ (honu:ast-stx (car exports))) (let* ([type-entry (get-type-entry matched)] [export (car exports)]) - (typecheck-export cenv type-entry export) + (typecheck-export lenv type-entry export) (loop non-matches (cdr exports)))))]))) - (define (typecheck-export cenv type-entry export) + (define (typecheck-export lenv type-entry export) ;; make sure to use both defined members and inherited members here (let loop ([type-members (append (tenv:type-members type-entry) (tenv:type-inherited type-entry))] [export-binds (honu:export-binds export)]) @@ -92,9 +93,9 @@ (tenv-key=? (tenv:member-name m) (honu:exp-bind-new (car export-binds)))) type-members)] - [(cenv-entry) (cenv (honu:exp-bind-old (car export-binds)))]) + [(lenv-entry) (lenv (honu:exp-bind-old (car export-binds)))]) (cond - [(not cenv-entry) + [(not lenv-entry) (raise-read-error-with-stx (format "No static member named ~a" (printable-key (honu:exp-bind-old (car export-binds)))) @@ -107,39 +108,39 @@ (honu:exp-bind-new (car export-binds)))] ;; if it's a method, then allow exporting a subtype [(honu:type-disp? (tenv:member-type matched)) - (if (<:_P cenv-entry (tenv:member-type matched)) + (if (<:_P lenv-entry (tenv:member-type matched)) (loop non-matches (cdr export-binds)) (raise-read-error-with-stx (format "Exported static member ~a has type ~a which is not a subtype of ~a's type ~a" (printable-key (honu:exp-bind-old (car export-binds))) - (printable-type cenv-entry) + (printable-type lenv-entry) (printable-key (tenv:member-name matched)) (printable-type (tenv:member-type matched))) (honu:exp-bind-old (car export-binds))))] ;; for fields, we just do invariance until we get read-only fields [else - (if (type-equal? cenv-entry (tenv:member-type matched)) + (if (type-equal? lenv-entry (tenv:member-type matched)) (loop non-matches (cdr export-binds)) (raise-read-error-with-stx (format "Exported static member ~a has type ~a which is not the same type as ~a's type ~a" (printable-key (honu:exp-bind-old (car export-binds))) - (printable-type cenv-entry) + (printable-type lenv-entry) (printable-key (tenv:member-name matched)) (printable-type (tenv:member-type matched))) (honu:exp-bind-old (car export-binds))))]))]))) - (define (extend-cenv-with-type-members cenv type) + (define (extend-lenv-with-type-members lenv type) (let ([type-entry (get-type-entry type)]) (fold (lambda (m e) (extend-fenv (tenv:member-name m) (tenv:member-type m) e)) - cenv + lenv (tenv:type-members type-entry)))) - (define (typecheck-supernew cenv lenv withs supernew) + (define (typecheck-supernew lenv withs supernew) (let loop ([withs withs] [args (honu:super-new-args supernew)] [checked-args '()]) @@ -169,10 +170,9 @@ (printable-key (honu:name-arg-name (car args)))) (honu:name-arg-name (car args))) (let ([first-arg (car args)]) - (let-values ([(e1 t1) (parameterize ([current-class-environment cenv]) - (typecheck-expression lenv - (honu:formal-type matched) - (honu:name-arg-value first-arg)))]) + (let-values ([(e1 t1) (typecheck-expression lenv + (honu:formal-type matched) + (honu:name-arg-value first-arg))]) (loop non-matches (cdr args) (cons (copy-struct honu:name-arg first-arg @@ -180,39 +180,39 @@ checked-args))))))]))) - (define (typecheck-members cenv lenv selftype members) + (define (typecheck-members lenv selftype members) (let loop ([members members] - [cenv cenv] + [lenv lenv] [ret '()]) (cond [(null? members) - (values (reverse ret) cenv)] + (values (reverse ret) lenv)] [(or (honu:init-field? (car members)) (honu:field? (car members))) - (let ([member (typecheck-member cenv lenv selftype (car members))]) + (let ([member (typecheck-member lenv selftype (car members))]) (loop (cdr members) (extend-fenv (get-class-member-name (car members)) (get-class-member-type selftype (car members)) - cenv) + lenv) (cons member ret)))] [(honu:method? (car members)) (let-values ([(methods remainder) (span honu:method? members)]) - (let ([cenv (fold (lambda (m cenv) + (let ([lenv (fold (lambda (m lenv) (extend-fenv (get-class-member-name m) (get-class-member-type selftype m) - cenv)) - cenv + lenv)) + lenv methods)]) (loop remainder - cenv + lenv ;; I only through the reverse in to keep the order the same. ;; it doesn't really matter. (append (reverse (map (lambda (m) - (typecheck-member cenv lenv selftype m)) + (typecheck-member lenv selftype m)) methods)) ret))))]))) - (define (typecheck-member cenv lenv selftype member) + (define (typecheck-member lenv selftype member) (match member [(struct honu:init-field (stx name type value)) (if (not (type-valid? type)) @@ -220,8 +220,7 @@ "Type of init field is undefined" (honu:ast-stx type))) (if value - (let-values ([(e1 t1) (parameterize ([current-class-environment cenv]) - (typecheck-expression lenv type value))]) + (let-values ([(e1 t1) (typecheck-expression lenv type value)]) (copy-struct honu:init-field member [honu:init-field-value e1])) member)] @@ -230,8 +229,7 @@ (raise-read-error-with-stx "Type of field is undefined" (honu:ast-stx type))) - (let-values ([(e1 t1) (parameterize ([current-class-environment cenv]) - (typecheck-expression lenv type value))]) + (let-values ([(e1 t1) (typecheck-expression lenv type value)]) (copy-struct honu:field member [honu:field-value e1]))] [(struct honu:method (stx name type args body)) @@ -245,8 +243,7 @@ "Type of method argument is undefined" (honu:ast-stx t)))) (map honu:formal-type args)) - (let-values ([(e1 t1) (parameterize ([current-class-environment cenv] - [current-return-type type]) + (let-values ([(e1 t1) (parameterize ([current-return-type type]) (typecheck-expression (fold (lambda (arg fenv) (extend-fenv (honu:formal-name arg) (honu:formal-type arg) diff --git a/collects/honu/private/typechecker/typecheck-expression.ss b/collects/honu/private/typechecker/typecheck-expression.ss index 29e35fec03..18a53218fc 100644 --- a/collects/honu/private/typechecker/typecheck-expression.ss +++ b/collects/honu/private/typechecker/typecheck-expression.ss @@ -328,7 +328,7 @@ (raise-honu-type-error stx ctype ret-type))))] [(struct honu:member (stx 'my _ name _)) (cond - [((current-class-environment) name) + [(lenv name) => (lambda (t) (if (honu:type-disp? t) diff --git a/collects/honu/private/typechecker/typecheck-parameters.ss b/collects/honu/private/typechecker/typecheck-parameters.ss index e1e1f2d4a7..3827ebf88d 100644 --- a/collects/honu/private/typechecker/typecheck-parameters.ss +++ b/collects/honu/private/typechecker/typecheck-parameters.ss @@ -2,15 +2,6 @@ (provide (all-defined)) - ;; since the class-environment doesn't change within typecheck-expression, we make it a parameter - ;; that we set before calling it. - ;; - ;; cenv : ((syntax/c symbol?) . -> . (union honu:type false/c)) - ;; static environment inside of a class or mixin definition - ;; (i.e. for my.) - - (define current-class-environment (make-parameter (lambda (name) #f))) - ;; since the return type only changes when we go into a lambda in typecheck-expression, we ;; make it a parameter also. ;; diff --git a/collects/honu/private/typechecker/typechecker.ss b/collects/honu/private/typechecker/typechecker.ss index 6d284efbb5..364d8a40f0 100644 --- a/collects/honu/private/typechecker/typechecker.ss +++ b/collects/honu/private/typechecker/typechecker.ss @@ -97,13 +97,7 @@ (match iface [(struct honu:iface (stx name supers members)) (check-valid-types! "interface supertype" supers) - (let ([conflicting-name (get-first-non-unique-name (map (lambda (d) - (cond - [(honu:field-decl? d) - (honu:field-decl-name d)] - [(honu:method-decl? d) - (honu:method-decl-name d)])) - members))]) + (let ([conflicting-name (get-first-non-unique-name (map honu:member-decl-name members))]) (if conflicting-name (raise-read-error-with-stx (format "Field/method name ~a used more than once" @@ -122,30 +116,22 @@ (check-valid-type! "class self-type" type) (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 - [(honu:init-field? d) - (honu:init-field-name d)] - [(honu:field? d) - (honu:field-name d)] - [(honu:method? d) - (honu:method-name d)])) - members)))]) + (map honu:member-defn-name members)))]) (if conflicting-name (raise-read-error-with-stx (format "Init/field/method name ~a used more than once" (printable-key conflicting-name)) conflicting-name))) (check-valid-types! "init slot type" (map honu:formal-type inits)) - (let ([cenv (srfi1:fold (lambda (a e) + (let ([lenv (srfi1:fold (lambda (a e) (extend-fenv (honu:formal-name a) (honu:formal-type a) e)) (lambda (n) #f) inits)]) (let*-values ([(lenv) (extend-fenv #'this type (wrap-lenv))] - [(members cenv) (typecheck-members cenv lenv type members)]) - (typecheck-exports cenv type impls exports) + [(members lenv) (typecheck-members lenv type members)]) + (typecheck-exports lenv type impls exports) (copy-struct honu:class class [honu:class-members members])))])) @@ -160,14 +146,7 @@ (append (tenv:type-members arg-tentry) (tenv:type-inherited arg-tentry))) (map honu:formal-name inits) - (map (lambda (d) - (cond - [(honu:init-field? d) - (honu:init-field-name d)] - [(honu:field? d) - (honu:field-name d)] - [(honu:method? d) - (honu:method-name d)])) + (map honu:member-defn-name (append members-before members-after))))]) (if conflicting-name @@ -188,6 +167,20 @@ (format "Init name ~a used more than once in expected init slots" (printable-key conflicting-name)) conflicting-name)))])) + + ;; check-distinct-names! : String [Listof Identifier] -> Void + ;; Raises an error if any of the names are the same. + (define (check-distinct-names! desc names) + (cond + [(check-duplicate-identifier names) => + (lambda (name) + (raise-read-error-with-stx (format "Duplicate name ~s found in ~s." name desc) name))] + [else (void)])) + + ;; check-distinct-types! : String [Listof Honu:Type] -> Void + ;; Raises an error if any of the types are the same. + (define (check-distinct-types! desc types) + (check-distinct-names! desc (map honu:type-iface-name types))) ;; typecheck-mixin : Mixin -> Mixin ;; Typechecks a mixin definition and produces the annotated version. @@ -195,29 +188,35 @@ (match mixin [(struct honu:mixin (stx name type arg-type final? impls inits withs supernew members-before members-after exports)) + + (define members (append members-before members-after)) + (define member-names (map honu:member-defn-name members)) + (define init-names (map honu:formal-name inits)) + (define super-member-names (type-member-names arg-type)) + (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)) - 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)] - [(cenv) (extend-cenv-with-type-members cenv arg-type)] - [(members-after cenv) (typecheck-members cenv lenv type members-after)]) - (typecheck-exports cenv type impls exports) - (copy-struct honu:mixin mixin - [honu:mixin-members-before members-before] - [honu:mixin-super-new supernew] - [honu:mixin-members-after members-after])))])) + (check-valid-types! "superclass init slot type" (map honu:formal-type withs)) + (check-distinct-types! "mixin implemented types" impls) + (check-distinct-names! "internally visible member/init names" + (append super-member-names init-names member-names)) + (check-distinct-names! "superclass init slot names" + (map honu:formal-name withs)) + + (let*-values ([(lenv) (wrap-lenv)] + [(lenv) (extend-fenv #'this type lenv)] + [(lenv) (srfi1:fold extend-fenv-honu:formal lenv inits)] + [(members-before lenv) (typecheck-members lenv type members-before)] + [(supernew) (typecheck-supernew lenv withs supernew)] + [(lenv) (extend-lenv-with-type-members lenv arg-type)] + [(members-after lenv) (typecheck-members lenv type members-after)]) + (typecheck-exports lenv type impls exports) + (copy-struct honu:mixin mixin + [honu:mixin-members-before members-before] + [honu:mixin-super-new supernew] + [honu:mixin-members-after members-after]))])) ;; typecheck-subclass : Subclass -> Subclass ;; Typechecks a subclass definition and produces the annotated version. diff --git a/collects/honu/tenv-utils.ss b/collects/honu/tenv-utils.ss index cec2d0de4e..0f3ced824b 100644 --- a/collects/honu/tenv-utils.ss +++ b/collects/honu/tenv-utils.ss @@ -4,6 +4,7 @@ "ast.ss" "parameters.ss" "tenv.ss" + "utils.ss" "private/typechecker/type-utils.ss" (lib "plt-match.ss") (lib "struct.ss") @@ -20,15 +21,15 @@ ;; can come from mdidefns [(honu:init-field? d) (make-honu:field-decl (honu:ast-stx d) - (honu:init-field-name d) + (honu:member-defn-name d) (honu:init-field-type d))] [(honu:field? d) (make-honu:field-decl (honu:ast-stx d) - (honu:field-name d) + (honu:member-defn-name d) (honu:field-type d))] [(honu:method? d) (make-honu:method-decl (honu:ast-stx d) - (honu:method-name d) + (honu:member-defn-name d) (honu:method-type d) (map honu:formal-type (honu:method-formals d)))])) (map convert-to-decl (append inits mfidefns))) @@ -41,9 +42,7 @@ ;; can come from inits [(honu:formal? d) (honu:formal-name d)] ;; can come from mdidefns - [(honu:init-field? d) (honu:init-field-name d)] - [(honu:field? d) (honu:field-name d)] - [(honu:method? d) (honu:method-name d)])) + [(honu:member-defn? d) (honu:member-defn-name d)])) (let ([binds (map (lambda (m) (let ([name (grab-name m)]) (make-honu:exp-bind name name))) (append inits mdidefns members))]) @@ -418,13 +417,9 @@ #f)) inits) (map (lambda (d) - (if (not (honu:init-field-value d)) - (make-tenv:init (honu:init-field-name d) - (honu:init-field-type d) - #f) - (make-tenv:init (honu:init-field-name d) - (honu:init-field-type d) - #t))) + (make-tenv:init (honu:member-defn-name d) + (honu:init-field-type d) + (not (false? (honu:init-field-value d))))) init-fields)))) (define (generate-subclass-tenv defn) diff --git a/collects/honu/tenv.ss b/collects/honu/tenv.ss index 69637e44af..61f4efd5a3 100644 --- a/collects/honu/tenv.ss +++ b/collects/honu/tenv.ss @@ -135,6 +135,7 @@ (format "Definition of ~a is not a type" (printable-key name)) name)] [else entry])))) + (define (get-class-entry name) (let ([entry (get-tenv-entry name)]) (cond @@ -200,6 +201,9 @@ value (fenv name)))) + (define (extend-fenv-honu:formal formal fenv) + (extend-fenv (honu:formal-name formal) (honu:formal-type formal) fenv)) + (define empty-fenv (lambda (name) #f)) (provide (struct tenv:entry (stx)) @@ -241,6 +245,7 @@ [wrap-lenv (-> fenv?)] [empty-fenv fenv?] [extend-fenv (identifier? honu:type? fenv? . -> . fenv?)] + [extend-fenv-honu:formal (honu:formal? fenv? . -> . fenv?)] ) ) diff --git a/collects/honu/utils.ss b/collects/honu/utils.ss index 4fe4aa7079..e1131d859f 100644 --- a/collects/honu/utils.ss +++ b/collects/honu/utils.ss @@ -16,7 +16,8 @@ map-two-values partition-first unique? - curry) + curry + false?) (define-syntax (define/p stx) (syntax-case stx () @@ -144,5 +145,8 @@ (define (curry f . args) (lambda rest (apply f (append args rest)))) + + (define (false? v) + (eq? v #f)) )