From 7dbb99d3c6bad3e586e4fd398ae247b0ac3dfa65 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sat, 2 Jul 2005 04:03:02 +0000 Subject: [PATCH] merged 292:296 from branches/sstrickl svn: r297 --- collects/honu/ast.ss | 147 ++- collects/honu/base.ss | 67 +- collects/honu/compile.ss | 90 +- collects/honu/doc.txt | 135 +- collects/honu/examples/List.honu | 43 +- collects/honu/examples/Y.honu | 45 +- collects/honu/examples/bind-tup-top.honu | 1 + collects/honu/examples/cond-test.honu | 5 + collects/honu/examples/exprs.honu | 48 + .../honu/examples/{ => old}/Character.honu | 0 .../honu/examples/{ => old}/Fact-Integer.honu | 0 collects/honu/examples/{ => old}/Fact.honu | 0 collects/honu/examples/{ => old}/Float.honu | 0 .../honu/examples/{ => old}/Integer-box.honu | 0 .../honu/examples/{ => old}/Integer-old.honu | 0 .../examples/{ => old}/Integer-value.honu | 0 collects/honu/examples/{ => old}/Integer.honu | 0 .../honu/examples/{ => old}/List-main.honu | 0 collects/honu/examples/{ => old}/List.cm | 0 collects/honu/examples/old/List.honu | 177 +++ .../honu/examples/{ => old}/Stack-main.honu | 0 collects/honu/examples/{ => old}/Stack.cm | 0 collects/honu/examples/{ => old}/Stack.honu | 0 collects/honu/examples/{ => old}/String.honu | 0 collects/honu/examples/{ => old}/Y-new.honu | 0 collects/honu/examples/old/Y.honu | 40 + .../honu/examples/{ => old}/error-prim.honu | 0 .../examples/{ => old}/field-exp-sub.honu | 0 .../honu/examples/{ => old}/forgot-init.honu | 0 .../honu/examples/{ => old}/func-test.honu | 0 .../examples/{ => old}/interpreter-str.honu | 0 .../honu/examples/{ => old}/interpreter.honu | 0 .../honu/examples/{ => old}/lambda-test.honu | 0 .../honu/examples/{ => old}/matthias1.honu | 0 .../honu/examples/{ => old}/matthias2.honu | 0 .../honu/examples/{ => old}/mdcall-test.honu | 0 .../honu/examples/{ => old}/mdcall-test2.honu | 0 .../examples/{ => old}/method-exp-sub.honu | 0 .../honu/examples/{ => old}/mixin-init.honu | 0 .../honu/examples/{ => old}/old-stack.honu | 0 collects/honu/examples/old/point.honu | 56 + .../honu/examples/{ => old}/rel-not-prim.honu | 0 .../honu/examples/{ => old}/simple-init.honu | 0 collects/honu/examples/{ => old}/square.honu | 0 .../examples/{ => old}/str-float-prim.honu | 0 .../honu/examples/{ => old}/struct-test.honu | 0 .../honu/examples/{ => old}/sub-bad-init.honu | 0 .../honu/examples/{ => old}/sub-final.honu | 0 .../honu/examples/{ => old}/subclass-ext.honu | 0 collects/honu/examples/{ => old}/uminus.honu | 0 collects/honu/examples/point.honu | 84 +- collects/honu/examples/struct.honu | 5 + collects/honu/examples/tup-bind.honu | 6 + collects/honu/examples/types-error.honu | 13 + collects/honu/examples/types.honu | 12 + ...onu-compile-context.ss => honu-context.ss} | 2 +- collects/honu/parsers/lex.ss | 276 ++++ collects/honu/parsers/parse.ss | 1115 ++++++++--------- collects/honu/parsers/post-parsing.ss | 852 +++++++++++++ .../compiler/honu-translate-class-utils.ss | 178 --- .../private/compiler/honu-translate-class.ss | 25 - .../compiler/honu-translate-expression.ss | 266 ---- .../compiler/honu-translate-function.ss | 14 - .../compiler/honu-translate-program.ss | 41 - .../compiler/honu-translate-subclass.ss | 59 - .../compiler/honu-translate-type-defn.ss | 35 - .../private/compiler/honu-translate-utils.ss | 83 -- .../private/compiler/translate-class-utils.ss | 151 +++ .../private/compiler/translate-expression.ss | 308 +++++ .../honu/private/compiler/translate-utils.ss | 138 ++ collects/honu/private/compiler/translate.ss | 97 ++ .../typechecker/honu-convert-static.ss | 204 --- .../private/typechecker/honu-type-utils.ss | 399 ------ .../typechecker/honu-typecheck-class-utils.ss | 236 ---- .../typechecker/honu-typecheck-class.ss | 31 - .../private/typechecker/honu-typecheck-exp.ss | 930 -------------- .../typechecker/honu-typecheck-function.ss | 26 - .../typechecker/honu-typecheck-mixin.ss | 98 -- .../typechecker/honu-typecheck-postchecks.ss | 93 -- .../typechecker/honu-typecheck-prechecks.ss | 88 -- .../typechecker/honu-typecheck-type-defn.ss | 73 -- .../private/typechecker/honu-typecheck.ss | 51 - .../honu/private/typechecker/type-utils.ss | 265 ++++ .../typechecker/typecheck-class-utils.ss | 283 +++++ .../typechecker/typecheck-expression.ss | 634 ++++++++++ .../honu/private/typechecker/typechecker.ss | 181 +++ .../{read-error-with-stx.ss => readerr.ss} | 2 +- collects/honu/tenv-utils.ss | 602 +++++++-- collects/honu/tenv.ss | 231 +++- collects/honu/tool.ss | 156 ++- collects/honu/utils.ss | 12 + 91 files changed, 5157 insertions(+), 4052 deletions(-) create mode 100644 collects/honu/examples/bind-tup-top.honu create mode 100644 collects/honu/examples/cond-test.honu create mode 100644 collects/honu/examples/exprs.honu rename collects/honu/examples/{ => old}/Character.honu (100%) rename collects/honu/examples/{ => old}/Fact-Integer.honu (100%) rename collects/honu/examples/{ => old}/Fact.honu (100%) rename collects/honu/examples/{ => old}/Float.honu (100%) rename collects/honu/examples/{ => old}/Integer-box.honu (100%) rename collects/honu/examples/{ => old}/Integer-old.honu (100%) rename collects/honu/examples/{ => old}/Integer-value.honu (100%) rename collects/honu/examples/{ => old}/Integer.honu (100%) rename collects/honu/examples/{ => old}/List-main.honu (100%) rename collects/honu/examples/{ => old}/List.cm (100%) create mode 100644 collects/honu/examples/old/List.honu rename collects/honu/examples/{ => old}/Stack-main.honu (100%) rename collects/honu/examples/{ => old}/Stack.cm (100%) rename collects/honu/examples/{ => old}/Stack.honu (100%) rename collects/honu/examples/{ => old}/String.honu (100%) rename collects/honu/examples/{ => old}/Y-new.honu (100%) create mode 100644 collects/honu/examples/old/Y.honu rename collects/honu/examples/{ => old}/error-prim.honu (100%) rename collects/honu/examples/{ => old}/field-exp-sub.honu (100%) rename collects/honu/examples/{ => old}/forgot-init.honu (100%) rename collects/honu/examples/{ => old}/func-test.honu (100%) rename collects/honu/examples/{ => old}/interpreter-str.honu (100%) rename collects/honu/examples/{ => old}/interpreter.honu (100%) rename collects/honu/examples/{ => old}/lambda-test.honu (100%) rename collects/honu/examples/{ => old}/matthias1.honu (100%) rename collects/honu/examples/{ => old}/matthias2.honu (100%) rename collects/honu/examples/{ => old}/mdcall-test.honu (100%) rename collects/honu/examples/{ => old}/mdcall-test2.honu (100%) rename collects/honu/examples/{ => old}/method-exp-sub.honu (100%) rename collects/honu/examples/{ => old}/mixin-init.honu (100%) rename collects/honu/examples/{ => old}/old-stack.honu (100%) create mode 100644 collects/honu/examples/old/point.honu rename collects/honu/examples/{ => old}/rel-not-prim.honu (100%) rename collects/honu/examples/{ => old}/simple-init.honu (100%) rename collects/honu/examples/{ => old}/square.honu (100%) rename collects/honu/examples/{ => old}/str-float-prim.honu (100%) rename collects/honu/examples/{ => old}/struct-test.honu (100%) rename collects/honu/examples/{ => old}/sub-bad-init.honu (100%) rename collects/honu/examples/{ => old}/sub-final.honu (100%) rename collects/honu/examples/{ => old}/subclass-ext.honu (100%) rename collects/honu/examples/{ => old}/uminus.honu (100%) create mode 100644 collects/honu/examples/struct.honu create mode 100644 collects/honu/examples/tup-bind.honu create mode 100644 collects/honu/examples/types-error.honu create mode 100644 collects/honu/examples/types.honu rename collects/honu/{honu-compile-context.ss => honu-context.ss} (58%) create mode 100644 collects/honu/parsers/lex.ss create mode 100644 collects/honu/parsers/post-parsing.ss delete mode 100644 collects/honu/private/compiler/honu-translate-class-utils.ss delete mode 100644 collects/honu/private/compiler/honu-translate-class.ss delete mode 100644 collects/honu/private/compiler/honu-translate-expression.ss delete mode 100644 collects/honu/private/compiler/honu-translate-function.ss delete mode 100644 collects/honu/private/compiler/honu-translate-program.ss delete mode 100644 collects/honu/private/compiler/honu-translate-subclass.ss delete mode 100644 collects/honu/private/compiler/honu-translate-type-defn.ss delete mode 100644 collects/honu/private/compiler/honu-translate-utils.ss create mode 100644 collects/honu/private/compiler/translate-class-utils.ss create mode 100644 collects/honu/private/compiler/translate-expression.ss create mode 100644 collects/honu/private/compiler/translate-utils.ss create mode 100644 collects/honu/private/compiler/translate.ss delete mode 100644 collects/honu/private/typechecker/honu-convert-static.ss delete mode 100644 collects/honu/private/typechecker/honu-type-utils.ss delete mode 100644 collects/honu/private/typechecker/honu-typecheck-class-utils.ss delete mode 100644 collects/honu/private/typechecker/honu-typecheck-class.ss delete mode 100644 collects/honu/private/typechecker/honu-typecheck-exp.ss delete mode 100644 collects/honu/private/typechecker/honu-typecheck-function.ss delete mode 100644 collects/honu/private/typechecker/honu-typecheck-mixin.ss delete mode 100644 collects/honu/private/typechecker/honu-typecheck-postchecks.ss delete mode 100644 collects/honu/private/typechecker/honu-typecheck-prechecks.ss delete mode 100644 collects/honu/private/typechecker/honu-typecheck-type-defn.ss delete mode 100644 collects/honu/private/typechecker/honu-typecheck.ss create mode 100644 collects/honu/private/typechecker/type-utils.ss create mode 100644 collects/honu/private/typechecker/typecheck-class-utils.ss create mode 100644 collects/honu/private/typechecker/typecheck-expression.ss create mode 100644 collects/honu/private/typechecker/typechecker.ss rename collects/honu/{read-error-with-stx.ss => readerr.ss} (95%) diff --git a/collects/honu/ast.ss b/collects/honu/ast.ss index b81526c2ce..ee572d5421 100644 --- a/collects/honu/ast.ss +++ b/collects/honu/ast.ss @@ -2,66 +2,93 @@ (provide (all-defined)) - (define-struct honu-program (defns)) + (define-syntax (define-honu-struct stx) + (syntax-case stx () + [(_ (id sup) (field ...)) + (with-syntax [(new-id (datum->syntax-object #'id (string->symbol (string-append "honu:" (symbol->string (syntax-e #'id)))) #'id #'id)) + (new-sup (datum->syntax-object #'sup (string->symbol (string-append "honu:" (symbol->string (syntax-e #'sup)))) #'sup #'sup))] + #'(define-struct (new-id new-sup) (field ...) #f))] + [(_ id (field ...)) + (with-syntax [(new-id (datum->syntax-object #'id (string->symbol (string-append "honu:" (symbol->string (syntax-e #'id)))) #'id #'id))] + #'(define-struct new-id (field ...) #f))])) - (define-struct honu-ast (src-stx)) - - (define-struct (honu-defn honu-ast) ()) - - (define-struct (honu-type honu-ast) ()) - - (define-struct (honu-prim-type honu-type) (name)) - (define-struct (honu-func-type honu-type) (args return)) - (define-struct (honu-dispatch-type honu-type) (dispatches args return)) - (define-struct (honu-iface-type honu-type) (name)) - (define-struct (honu-iface-bottom-type honu-type) ()) - (define-struct (honu-iface-top-type honu-type) ()) - (define-struct (honu-bottom-type honu-type) ()) - (define-struct (honu-top-type honu-type) ()) - - (define-struct (honu-function honu-defn) (name type arg-names arg-types body)) - (define-struct (honu-type-defn honu-defn) (name supers decls)) - (define-struct (honu-class honu-defn) (name type final? init-names init-types impls defns exports)) - (define-struct (honu-mixin honu-defn) (name type arg-type final? init-names init-types impls with-names with-types - defns-before super-new defns-after exports)) - (define-struct (honu-subclass honu-defn) (name mixin base)) + (define-honu-struct ast (stx)) ; ensures that all nodes have a stx obj - (define-struct (honu-field-decl honu-ast) (name type)) - (define-struct (honu-method-decl honu-ast) (name type arg-types)) - - (define-struct (honu-init-field honu-ast) (name type value)) - (define-struct (honu-field honu-ast) (name type value)) - (define-struct (honu-method honu-ast) (name type arg-names arg-types body)) - - (define-struct (honu-super-new honu-ast) (arg-names arg-vals)) - - (define-struct (honu-export honu-ast) (type old-names new-names)) - - (define-struct (honu-exp honu-ast) ()) + ;; Type AST nodes + (define-honu-struct (type ast) ()) ; used only for type? + (define-honu-struct (type-top type) ()) ; used to represent "void" (i.e. unit) + (define-honu-struct (type-bot type) ()) ; used to represent a term okay in _any_ context (like error) + (define-honu-struct (type-prim type) (name)) ; used to represent primitive types (int, string, char, etc.) + (define-honu-struct (type-tuple type) (args)) ; used to represent a tuple of types + (define-honu-struct (type-func type) (arg ret)) ; used for functions (no dispatch) + (define-honu-struct (type-disp type) (disp arg ret)) ; used for methods (single dispatch) or multi-dispatch (if later added) + (define-honu-struct (type-iface type) (name)) ; used for interface types (except for next two, which are more specific) + (define-honu-struct (type-iface-top type) ()) ; used for the Any type + (define-honu-struct (type-iface-bot type) ()) ; used for the type that null has + + (define-honu-struct (type-select type) (slot type)) ; used only for context type in the typechecker when #n is encountered - (define-struct (honu-null honu-exp) ()) - (define-struct (honu-int honu-exp) (value)) - (define-struct (honu-float honu-exp) (value)) - (define-struct (honu-bool honu-exp) (value)) - (define-struct (honu-char honu-exp) (value)) - (define-struct (honu-str honu-exp) (value)) - (define-struct (honu-lambda honu-exp) (arg-names arg-types body)) - (define-struct (honu-prim honu-exp) (op op-stx op-type left right)) - (define-struct (honu-uprim honu-exp) (op op-stx op-type body)) - (define-struct (honu-facc honu-exp) (obj elab field)) - (define-struct (honu-fassn honu-exp) (obj elab field rhs)) - (define-struct (honu-mcall honu-exp) (obj elab method args)) - (define-struct (honu-var honu-exp) (name builtin?)) - (define-struct (honu-assn honu-exp) (name rhs)) - (define-struct (honu-call honu-exp) (name args builtin?)) - (define-struct (honu-this honu-exp) ()) - (define-struct (honu-cast honu-exp) (obj type)) - (define-struct (honu-isa honu-exp) (obj type)) - (define-struct (honu-if honu-exp) (cond true false)) - (define-struct (honu-new honu-exp) (class type arg-names arg-vals)) - (define-struct (honu-while honu-exp) (cond body)) - (define-struct (honu-block honu-exp) (binds exps)) - (define-struct (honu-return honu-exp) (body)) - - (define-struct (honu-binding honu-ast) (name type rhs)) - ) + ;; Definition AST nodes + (define-honu-struct (defn ast) ()) ; used for defn? + (define-honu-struct (iface defn) (name supers members)) ; used for interface definitions + (define-honu-struct (class defn) (name type final? impls inits ; used for class definitions + members exports)) + (define-honu-struct (mixin defn) (name type sub-type final? impls ; used for mixin definitions + inits withs super-new + members-before members-after exports)) + (define-honu-struct (subclass defn) (name base mixin)) ; used for subclass definitions + + (define-honu-struct (struct defn) (name type final? impls inits ; used for structs, later replaced with components + members exports)) + (define-honu-struct (substruct defn) (name type base arg-type final? impls ; same, but for structs that are subclasses + inits withs super-new + members-before members-after exports)) + + (define-honu-struct (function defn) (name type formals body)) ; used for function definitions + (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 + + ;; 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 + + ;; AST node for super call (just in mixins/subclasses) + (define-honu-struct (super-new ast) (args)) + + ;; Expression AST nodes + (define-honu-struct (expr ast) ()) + (define-honu-struct (this expr) ()) + (define-honu-struct (var expr) (name)) + (define-honu-struct (assn expr) (lhs rhs)) + (define-honu-struct (call expr) (func arg)) + (define-honu-struct (lit expr) (type value)) + (define-honu-struct (un-op expr) (op op-stx op-type arg)) + (define-honu-struct (bin-op expr) (op op-stx op-type larg rarg)) + (define-honu-struct (lambda expr) (type formals body)) + (define-honu-struct (if expr) (cond then else)) + (define-honu-struct (cast expr) (obj type)) + (define-honu-struct (isa expr) (obj type)) + (define-honu-struct (member expr) (obj elab name method?)) ;; method is only needed for translation + (define-honu-struct (let expr) (bindings body)) + (define-honu-struct (seq expr) (effects value)) + (define-honu-struct (new expr) (class type args)) + (define-honu-struct (cond expr) (clauses else)) + (define-honu-struct (while expr) (cond body)) + (define-honu-struct (return expr) (body)) + (define-honu-struct (tuple expr) (vals)) + (define-honu-struct (select expr) (slot arg)) + + ;; Miscellaneous AST nodes + (define-honu-struct (binding ast) (names types value)) ; used for bindings in lets + (define-honu-struct (export ast) (type binds)) ; used for export statements + (define-honu-struct exp-bind (old new)) ; used for export bindings + (define-honu-struct (formal ast) (name type)) ; used for formal arguments + (define-honu-struct name-arg (name value)) ; used for by-name arguments (like new) + (define-honu-struct (cond-clause ast) (pred rhs)) ; used for cond clauses + ) diff --git a/collects/honu/base.ss b/collects/honu/base.ss index 930614effc..ad1faef6d0 100644 --- a/collects/honu/base.ss +++ b/collects/honu/base.ss @@ -2,60 +2,73 @@ (require (lib "class.ss")) - (define (printStr s) - (display s)) + (define null% + (class object% + (super-new))) + + (define null-obj (new null%)) + + (define Any<%> + (interface ())) + + (define (printString s) + (display s) + '()) (define (printLine s) (display s) - (newline)) + (newline) + '()) - (define (readChar) + (define (readChar arg-tuple) (read-char)) - (define (readLine) + (define (readLine arg-tuple) (read-line)) - (define (strToInt s) + (define (stringToInt s) (let ([number (string->number s)]) (if (and number (integer? number)) number (error (format "Tried to convert \"~a\" to an integer" s))))) - (define (strToFloat s) + (define (stringToFloat s) (let ([number (string->number s)]) (if (and number (inexact? number)) number (error (format "Tried to convert \"~a\" to an float" s))))) - (define (intToStr i) + (define (intToString i) (number->string i)) - (define (floatToStr f) + (define (floatToString f) (number->string f)) - (define (charToStr c) + (define (charToString c) (string c)) - (define (strLen s) + (define (strlen s) (string-length s)) - (define (substr s start end) - (cond - [(< start 0) - (error (format "Start index for substr must be positive, got ~a" start))] - [(> start end) - (error (format "Start index (~a) must be <= end index (~a)" start end))] - [(> end (string-length s)) - (error (format "End index for substr must be <= strLen(s), got ~a" end))] - [else (substring s start end)])) + (define (substr arg-tuple) + (let-values ([(s start end) (apply values arg-tuple)]) + (cond + [(< start 0) + (error (format "Start index for substr must be positive, got ~a" start))] + [(> start end) + (error (format "Start index (~a) must be <= end index (~a)" start end))] + [(> end (string-length s)) + (error (format "End index for substr must be <= strlen(s), got ~a" end))] + [else (substring s start end)]))) - (define (charAt s i) - (cond - [(< i 0) - (error (format "Index for charAt must be positive, got ~a" i))] - [(> i (- (string-length s) 1)) - (error (format "Index for charAt must be < strLen(s), got ~a" i))] - [else (string-ref s i)])) + (define (charAt arg-tuple) + (let-values ([(s i) (apply values arg-tuple)]) + (cond + [(< i 0) + (error (format "Index for charAt must be non-negative, got ~a" i))] + [(> i (- (string-length s) 1)) + (error (format "Index for charAt must be < strlen(s), got ~a" i))] + [else (string-ref s i)]))) (provide (all-from mzscheme) (all-from (lib "class.ss")) diff --git a/collects/honu/compile.ss b/collects/honu/compile.ss index c6508fd835..30efbc263b 100644 --- a/collects/honu/compile.ss +++ b/collects/honu/compile.ss @@ -1,52 +1,56 @@ (module compile mzscheme - (require (lib "contract.ss")) - - (require "ast.ss") - (require "tenv.ss") - (require "tenv-utils.ss") - (require "honu-compile-context.ss") - (require "private/compiler/honu-translate-utils.ss") - (require "private/compiler/honu-translate-program.ss") - (require "private/compiler/honu-translate-expression.ss") - (require "private/typechecker/honu-typecheck.ss") - (require "private/typechecker/honu-typecheck-exp.ss") - (require "read-error-with-stx.ss") + (require (lib "boundmap.ss" "syntax") + (lib "contract.ss") + (lib "plt-match.ss") + "ast.ss" + "honu-context.ss" + "readerr.ss" + "tenv.ss" + "tenv-utils.ss" + "parsers/post-parsing.ss" + "private/compiler/translate.ss" + "private/compiler/translate-expression.ss" + "private/compiler/translate-utils.ss" + "private/typechecker/type-utils.ss" + "private/typechecker/typechecker.ss" + "private/typechecker/typecheck-expression.ss") - (provide/contract [compile/complete-program - (tenv? honu-program? + (provide/contract [compile/defns + (tenv? tenv? (listof honu:defn?) . -> . -; (listof (syntax/c any/c))] - list?)] + (listof (syntax/c any/c)))] [compile/interaction - ((tenv? - any/c - (union honu-binding? honu-exp?)) - . ->* . -; (listof (syntax/c any/c))] - (any/c any/c))]) - (define (compile/complete-program tenv pgm) - (add-defns-to-tenv (honu-program-defns pgm) tenv) - (let ([checked (honu-typecheck-program tenv pgm)]) - (parameterize ([current-compile-context honu-compile-context]) - (honu-translate-program tenv checked)))) + (tenv? + tenv? + (union honu:bind-top? honu:expr?) + . -> . + (syntax/c any/c))]) + (define (compile/defns tenv lenv pgm) + (let ([pgm (post-parse-program tenv (add-defns-to-tenv pgm tenv))]) + (let ([checked (typecheck tenv lenv pgm)]) + (parameterize ([current-compile-context honu-compile-context]) + (translate tenv checked))))) - (define (compile/interaction tenv env ast) - (cond - [(honu-binding? ast) - (if (env (honu-binding-name ast)) - (raise-read-error-with-stx - (format "~a already bound" (printable-key (honu-binding-name ast))) - (honu-binding-name ast)) - (let-values ([(checked new-env) - ((honu-typecheck-binding tenv #f) ast env)]) - (parameterize ([current-compile-context honu-compile-context]) - (values (honu-translate-binding tenv #f checked #t) - new-env))))] - [(honu-exp? ast) - (let-values ([(checked type) ((honu-typecheck-exp tenv env #f) ast #f)]) + (define (check-bound-names lenv names) + (for-each (lambda (n) + (if (and n (bound-identifier-mapping-get lenv n (lambda () #f))) + (raise-read-error-with-stx + (format "~a already bound" (printable-key n)) + n))) + names)) + + (define (compile/interaction tenv lenv ast) + (match (post-parse-interaction tenv ast) + [(struct honu:bind-top (stx names _ value)) + (check-bound-names lenv names) + (let ([checked (typecheck-defn tenv lenv ast)]) (parameterize ([current-compile-context honu-compile-context]) - (values (honu-translate-expression tenv #f checked) - env)))])) + (translate-defn tenv checked)))] + [else + (let-values ([(checked type) (typecheck-expression tenv (lambda (n) #f) + (wrap-as-function lenv) (make-top-type #f) #f ast)]) + (parameterize ([current-compile-context honu-compile-context]) + (translate-expression tenv #f checked)))])) ) diff --git a/collects/honu/doc.txt b/collects/honu/doc.txt index b3602c540c..c1e85b8877 100644 --- a/collects/honu/doc.txt +++ b/collects/honu/doc.txt @@ -2,19 +2,10 @@ _Honu_ _TODO_ - * At the moment you can only apply method references or lexically - bound variables to arguments in order to invoke a function or - method. The syntax will be reworked in the extremely near future - to allow application of arbitrary expressions (assuming they - result in a method or function type) to arguments. - > Rewrite TODO list in terms of interfaces (not implementations) The next bullet is a prime example. I have added a second bullet to show what I mean. -- MF - * Fix up honu-mcall and honu-new in honu-typecheck-exp.ss to use - type context argument. - * Admit statements as elements of mixin bodies, i.e., struct ExamplesC() : Examples { @@ -28,9 +19,6 @@ _TODO_ * Work out details of standard library, including boxed versions of primitive types. - * Let's use _string_ for _str_. (In principle we should probably use - String eventually, if it becomes a class.) - * If you do have a standard library, document it please. -- MF * Let's add arrays. @@ -44,68 +32,68 @@ _TODO_ _Primitive types_ - int - integers - float - floating point numbers - str - strings (double quoted) - bool - booleans (true, false) - char - characters (single quoted) + int - integers + float - floating point numbers + string - strings (double quoted) + bool - booleans (true, false) + char - characters (single quoted) _Built-in functions_ Error reporting: -> error(str message) => 'a +> error(string message) => 'a - Raises an error and prints the string as an error message. - Calls to error() do not return. Input/output: -> printStr(str message) => void +> printString(string message) => void - Takes a string and prints it on the standard output. -> printLine(str message) => void - - Like printStr, but prints a newline after printing the string. +> printLine(string message) => void + - Like printString, but prints a newline after printing the string. > readChar() => char - Reads a single character from the standard input. -> readLine() => str +> readLine() => string - Reads a line of text from the standard input. Conversions to string: -> intToStr(int val) => str +> intToString(int val) => string - Converts an integer to a string. -> floatToStr(float val) => str +> floatToString(float val) => string - Converts a floating point number to a string. -> charToStr(char val) => str +> charToString(char val) => string - Converts a character to a string. String conversions: -> strToInt(str val) => int +> stringToInt(string val) => int - Converts a string to an integer. - Raises an error if the string cannot be converted. -> strToFloat(str val) => float +> stringToFloat(string val) => float - Converts a string to a floating point number. - Raises an error if the string cannot be converted. String operations: -> strLen(str s) => int +> strlen(string s) => int - Takes a string and returns the string length. -> substr(str s, int start, int end) => str +> substr(string s, int start, int end) => string - Takes a string, a start index, and an end index and returns the corresponding substring. - The indexes are zero-based. - The start index cannot be negative or greater than the end index. - The end index must be less than or equal to the string length. -> charAt(str s, int i) => char +> charAt(string s, int i) => char - Takes a string and an index into the string and returns the corresponding character. - The zero-based index cannot be negative and must be less @@ -119,27 +107,29 @@ NOTE: Since I want to use parentheses to mean "real" parentheses, I use ::= * ::= + | | | | | - ::= ( ) + ::= = ; + | ( [, ]* ) = ; - ::= type { * } - | interface { * } + ::= + | _ + + ::= ( ) ::= | | + | - ::= [ ] -> + ::= -> -NOTE: The above are literal braces as opposed to the meta-braces. - This is the only place they occur right now. - - ::= [, ]* - | + ::= < > + | < [, ]* > ::= id | Any @@ -151,6 +141,9 @@ NOTE: The above are literal braces as opposed to the meta-braces. | char | void + ::= type { * } + | interface { * } + ::= extends [, ]* | <: [, ]* | @@ -164,33 +157,34 @@ NOTE: The above are literal braces as opposed to the meta-braces. ::= | - ::= struct : - | final struct : + ::= struct : + | final struct : + | struct : + extends : + | final struct : + extends : ::= class : | final class : + | class = ( ) ; + | class : + extends : + | final class : + extends : - ::= mixin : - | final mixin : - ::= subclass = ( ) ; - | subclass : - | final subclass : + ::= mixin : -> + + | final mixin : -> + ::= ( [, ]* ) | ( ) - ::= extends - - ::= at - | @ - ::= implements [, ]* | impl [, ]* | - ::= { * } - ::= { * * } ::= { * * * } @@ -200,7 +194,7 @@ NOTE: The above are literal braces as opposed to the meta-braces. | = ; | ( ) - ::= super_new( ) ; + ::= super( ) ; ::= [, ]* | @@ -221,13 +215,17 @@ NOTE: The above are literal braces as opposed to the meta-braces. ::= | + | + | #n | - | = - | ( ) + | = + | | this | : | isa - | if else + | if [else ]? + | cond { [ => ;]+ } + | cond { [ => ;]* else } | while | new : ( ) | new ( ) @@ -248,9 +246,7 @@ NOTE: The above are literal braces as opposed to the meta-braces. | / | % | . - | . = - | . ( ) - | ( ) + | return | NOTE: Here's the precedence and associativity of things above. @@ -264,6 +260,8 @@ NOTE: Here's the precedence and associativity of things above. ----------+----------+----------- . | | | : isa | + | | #n (tuple selector) + | | ( (function application) | | !, - (un) * / % | | + - | | @@ -274,8 +272,11 @@ NOTE: Here's the precedence and associativity of things above. || | | = | | else | | + | | return - ::= fun ( ) + ::= ( ) + | ( ) + ::= fun ( ) ::= [, ]* | @@ -286,11 +287,15 @@ NOTE: Here's the precedence and associativity of things above. | false | | + | null - ::= { * + } + ::= { } - ::= = ; + ::= + | + | + + ::= = ; + | ( [, ]* ) = ; ::= ; - | return ; - | return ; diff --git a/collects/honu/examples/List.honu b/collects/honu/examples/List.honu index 45738d8bf6..a48e0863c6 100644 --- a/collects/honu/examples/List.honu +++ b/collects/honu/examples/List.honu @@ -4,7 +4,6 @@ type List { List addToEnd(Any); Any first(); - List rest(); Any atIndex(int); Any last(); @@ -19,10 +18,10 @@ type List { int length(); bool empty(); - List map([Any] -> Any); - Any foldl([Any, Any] -> Any, Any); - Any foldr([Any, Any] -> Any, Any); - List filter([Any] -> bool); + List map(Any -> Any); + Any foldl( -> Any, Any); + Any foldr( -> Any, Any); + List filter(Any -> bool); } @@ -40,10 +39,6 @@ class MTList() : List impl List { error("The empty list has no elements!"); } - List rest() { - error("The empty list has no elements!"); - } - List drop(int n) { if n == 0 { this : List; @@ -68,29 +63,27 @@ class MTList() : List impl List { bool empty() { return true; } - List map([Any] -> Any f) { return (this : List); } + List map(Any -> Any f) { return (this : List); } - Any fold([Any, Any] -> Any f, Any i) { return i; } + Any fold( -> Any f, Any i) { return i; } - List filter([Any] -> bool f) { return (this : List); } + List filter(Any -> bool f) { return (this : List); } export List : add as addToFront, add as addToEnd, - no_elt as first, rest, no_elts as atIndex, - no_elt as last, drop, take, reverse, + no_elt as first, no_elts as atIndex, no_elt as last, + drop, take, reverse, ret_other as appendToEnd, ret_other as appendToFront, length, empty, map, fold as foldl, fold as foldr, filter; } -class ConsList() : List impl List { - - init Any car; - init List cdr; +// Since init slots get translated to init fields by need, we can put +// car and cdr here, and then use them appropriately inside the methods +// which will make them fields. +class ConsList(Any car, List cdr) : List impl List { Any first() { return car; } - List rest() { return cdr; } - Any atIndex(int n) { if n == 0 { car; @@ -151,19 +144,19 @@ class ConsList() : List impl List { bool empty() { return false; } - List map([Any] -> Any f) { + List map(Any -> Any f) { return new ConsList(car = f(car), cdr = cdr.map(f)); } - Any foldl([Any, Any] -> Any f, Any i) { + Any foldl( -> Any f, Any i) { return f(car, cdr.foldl(f, i)); } - Any foldr([Any, Any] -> Any f, Any i) { + Any foldr( -> Any f, Any i) { return cdr.foldr(f, f(car, i)); } - List filter([Any] -> bool f) { + List filter(Any -> bool f) { if f(car) { new ConsList(car = car, cdr = cdr.filter(f)); } else { @@ -171,7 +164,7 @@ class ConsList() : List impl List { }; } - export List : addToFront, addToEnd, first, rest, atIndex, last, reverse, + export List : addToFront, addToEnd, first, atIndex, last, reverse, drop, take, appendToEnd, appendToFront, length, empty, map, foldl, foldr, filter; } diff --git a/collects/honu/examples/Y.honu b/collects/honu/examples/Y.honu index 93e34205b1..c3ec36e2ef 100644 --- a/collects/honu/examples/Y.honu +++ b/collects/honu/examples/Y.honu @@ -1,40 +1,15 @@ -// compute the fixpoint of f -[int] -> int fix([[int] -> int] -> [int] -> int f) { - [T] -> [int] -> int g = fun(T x) { - [int] -> int h = fun (int y) { // will become: ((outT(x))(x))(y) - [T] -> [int] -> int g = outT(x); - [int] -> int i = g(x); - return i(y); - }; - return f(h); - }; - return g(inT(g)); +int -> int fix( int> -> int -> int f) { + T -> int -> int g = int->int fun(T x) { f(int fun(int y) { x.f(x)(y); }); }; + g (new Y(f = g)); } -// type T = Y of T -> int -> int +struct Y(T -> int -> int f) : T { } -struct Y() : T { - init [T] -> [int] -> int f; +int -> int factorialor(int -> int factorial) { + int fun(int x) { + if(x == 0) { 1; } + else { x * factorial(x - 1); }; + }; } -[T] -> [int] -> int outT(T x) { return x.f; } -T inT([T] -> [int] -> int x) { return new Y(f = x); } - -// ----------------------------------------------------------------------------- - -[int] -> int factorialor([int] -> int factorial) { - return - fun (int x) { - if (x == 0) { - return 1; - } - else { - return x * factorial(x - 1); - }; - }; -} - -int main(int n) { - [int] -> int factorial = fix(factorialor); - return factorial(n); -} +int main(int n) { fix(factorialor)(n); } diff --git a/collects/honu/examples/bind-tup-top.honu b/collects/honu/examples/bind-tup-top.honu new file mode 100644 index 0000000000..9fcd93a46d --- /dev/null +++ b/collects/honu/examples/bind-tup-top.honu @@ -0,0 +1 @@ +(int x, int y) = { int x = 3; int y = 4; (x, y); }; diff --git a/collects/honu/examples/cond-test.honu b/collects/honu/examples/cond-test.honu new file mode 100644 index 0000000000..7ca2ba873a --- /dev/null +++ b/collects/honu/examples/cond-test.honu @@ -0,0 +1,5 @@ +int x = cond { + 1 > 3 => 4; + 5 < 6 => 2; + else 8; + }; diff --git a/collects/honu/examples/exprs.honu b/collects/honu/examples/exprs.honu new file mode 100644 index 0000000000..e87c5c81e0 --- /dev/null +++ b/collects/honu/examples/exprs.honu @@ -0,0 +1,48 @@ +int fact(int n) { + if (n == 0) { return 1; } + else { return n * fact(n - 1); }; +} + + divrem(int x, int y) { + (int a, int b) = (x / y, x % y); + return (a, b); +} + +int impfact(int n) { + int ret = 1; + while(n > 1) { + ret = ret * n; + n = n - 1; + }; + return ret; +} + +int factacc(int n, int a) { + if (n == 0) { return a; } + else { return factacc(n - 1, n * a); }; +} + +int fact2(int n) { + return factacc(n, 1); +} + +int fib_h(int n, int a, int b) { + if(n == 0) { return a; } + else { return fib_h(n - 1, b, a + b); }; +} + +int fib(int n) { + return fib_h(n, 0, 1); +} + + fibfact(int n) { + return (fib(n), fact(n)); +} + +void printFibUpTo(int n) { + int x = 0; + while(x < n) { + printLine(intToString(fib(x))); + x = x + 1; + }; +} \ No newline at end of file diff --git a/collects/honu/examples/Character.honu b/collects/honu/examples/old/Character.honu similarity index 100% rename from collects/honu/examples/Character.honu rename to collects/honu/examples/old/Character.honu diff --git a/collects/honu/examples/Fact-Integer.honu b/collects/honu/examples/old/Fact-Integer.honu similarity index 100% rename from collects/honu/examples/Fact-Integer.honu rename to collects/honu/examples/old/Fact-Integer.honu diff --git a/collects/honu/examples/Fact.honu b/collects/honu/examples/old/Fact.honu similarity index 100% rename from collects/honu/examples/Fact.honu rename to collects/honu/examples/old/Fact.honu diff --git a/collects/honu/examples/Float.honu b/collects/honu/examples/old/Float.honu similarity index 100% rename from collects/honu/examples/Float.honu rename to collects/honu/examples/old/Float.honu diff --git a/collects/honu/examples/Integer-box.honu b/collects/honu/examples/old/Integer-box.honu similarity index 100% rename from collects/honu/examples/Integer-box.honu rename to collects/honu/examples/old/Integer-box.honu diff --git a/collects/honu/examples/Integer-old.honu b/collects/honu/examples/old/Integer-old.honu similarity index 100% rename from collects/honu/examples/Integer-old.honu rename to collects/honu/examples/old/Integer-old.honu diff --git a/collects/honu/examples/Integer-value.honu b/collects/honu/examples/old/Integer-value.honu similarity index 100% rename from collects/honu/examples/Integer-value.honu rename to collects/honu/examples/old/Integer-value.honu diff --git a/collects/honu/examples/Integer.honu b/collects/honu/examples/old/Integer.honu similarity index 100% rename from collects/honu/examples/Integer.honu rename to collects/honu/examples/old/Integer.honu diff --git a/collects/honu/examples/List-main.honu b/collects/honu/examples/old/List-main.honu similarity index 100% rename from collects/honu/examples/List-main.honu rename to collects/honu/examples/old/List-main.honu diff --git a/collects/honu/examples/List.cm b/collects/honu/examples/old/List.cm similarity index 100% rename from collects/honu/examples/List.cm rename to collects/honu/examples/old/List.cm diff --git a/collects/honu/examples/old/List.honu b/collects/honu/examples/old/List.honu new file mode 100644 index 0000000000..45738d8bf6 --- /dev/null +++ b/collects/honu/examples/old/List.honu @@ -0,0 +1,177 @@ +type List { + + List addToFront(Any); + List addToEnd(Any); + + Any first(); + List rest(); + Any atIndex(int); + Any last(); + + List drop(int); + List take(int); + + List appendToEnd(List); + List appendToFront(List); + + List reverse(); + + int length(); + bool empty(); + + List map([Any] -> Any); + Any foldl([Any, Any] -> Any, Any); + Any foldr([Any, Any] -> Any, Any); + List filter([Any] -> bool); + +} + +class MTList() : List impl List { + + List add(Any elt) { + return new ConsList(car = elt, cdr = (this : List)); + } + + Any no_elts(int n) { + error("The empty list has no elements!"); + } + + Any no_elt() { + error("The empty list has no elements!"); + } + + List rest() { + error("The empty list has no elements!"); + } + + List drop(int n) { + if n == 0 { + this : List; + } else { + error("Attempt to drop elements from an empty list!"); + }; + } + + List take(int n) { + if n == 0 { + this : List; + } else { + error("Attempt to take elements from an empty list!"); + }; + } + + List ret_other(List l) { return l; } + + List reverse() { return (this : List); } + + int length() { return 0; } + + bool empty() { return true; } + + List map([Any] -> Any f) { return (this : List); } + + Any fold([Any, Any] -> Any f, Any i) { return i; } + + List filter([Any] -> bool f) { return (this : List); } + + export List : add as addToFront, add as addToEnd, + no_elt as first, rest, no_elts as atIndex, + no_elt as last, drop, take, reverse, + ret_other as appendToEnd, ret_other as appendToFront, + length, empty, + map, fold as foldl, fold as foldr, filter; +} + +class ConsList() : List impl List { + + init Any car; + init List cdr; + + Any first() { return car; } + + List rest() { return cdr; } + + Any atIndex(int n) { + if n == 0 { + car; + } else { + cdr.atIndex(n - 1); + }; + } + + Any last() { + if cdr.empty() { + car; + } else { + cdr.last(); + }; + } + + List drop(int n) { + if n == 0 { + this : List; + } else { + cdr.drop(n - 1); + }; + } + + List take(int n) { + if n == 0 { + new MTList(); + } else { + new ConsList(car = car, cdr = cdr.take(n - 1)); + }; + } + + List addToFront(Any x) { + return new ConsList(car = x, cdr = (this : List)); + } + + List addToEnd(Any x) { + return new ConsList(car = car, cdr = cdr.addToEnd(x)); + } + + List appendToFront(List other) { + if other.empty() { + this : List; + } else { + new ConsList(car = other.first(), cdr = other.drop(1)); + }; + } + + List appendToEnd(List other) { + return new ConsList(car = car, cdr = cdr.appendToEnd(other)); + } + + List reverse() { + return cdr.reverse().addToEnd(car); + } + + int length() { return 1 + cdr.length(); } + + bool empty() { return false; } + + List map([Any] -> Any f) { + return new ConsList(car = f(car), cdr = cdr.map(f)); + } + + Any foldl([Any, Any] -> Any f, Any i) { + return f(car, cdr.foldl(f, i)); + } + + Any foldr([Any, Any] -> Any f, Any i) { + return cdr.foldr(f, f(car, i)); + } + + List filter([Any] -> bool f) { + if f(car) { + new ConsList(car = car, cdr = cdr.filter(f)); + } else { + cdr.filter(f); + }; + } + + export List : addToFront, addToEnd, first, rest, atIndex, last, reverse, + drop, take, appendToEnd, appendToFront, length, empty, + map, foldl, foldr, filter; +} diff --git a/collects/honu/examples/Stack-main.honu b/collects/honu/examples/old/Stack-main.honu similarity index 100% rename from collects/honu/examples/Stack-main.honu rename to collects/honu/examples/old/Stack-main.honu diff --git a/collects/honu/examples/Stack.cm b/collects/honu/examples/old/Stack.cm similarity index 100% rename from collects/honu/examples/Stack.cm rename to collects/honu/examples/old/Stack.cm diff --git a/collects/honu/examples/Stack.honu b/collects/honu/examples/old/Stack.honu similarity index 100% rename from collects/honu/examples/Stack.honu rename to collects/honu/examples/old/Stack.honu diff --git a/collects/honu/examples/String.honu b/collects/honu/examples/old/String.honu similarity index 100% rename from collects/honu/examples/String.honu rename to collects/honu/examples/old/String.honu diff --git a/collects/honu/examples/Y-new.honu b/collects/honu/examples/old/Y-new.honu similarity index 100% rename from collects/honu/examples/Y-new.honu rename to collects/honu/examples/old/Y-new.honu diff --git a/collects/honu/examples/old/Y.honu b/collects/honu/examples/old/Y.honu new file mode 100644 index 0000000000..93e34205b1 --- /dev/null +++ b/collects/honu/examples/old/Y.honu @@ -0,0 +1,40 @@ +// compute the fixpoint of f +[int] -> int fix([[int] -> int] -> [int] -> int f) { + [T] -> [int] -> int g = fun(T x) { + [int] -> int h = fun (int y) { // will become: ((outT(x))(x))(y) + [T] -> [int] -> int g = outT(x); + [int] -> int i = g(x); + return i(y); + }; + return f(h); + }; + return g(inT(g)); +} + +// type T = Y of T -> int -> int + +struct Y() : T { + init [T] -> [int] -> int f; +} + +[T] -> [int] -> int outT(T x) { return x.f; } +T inT([T] -> [int] -> int x) { return new Y(f = x); } + +// ----------------------------------------------------------------------------- + +[int] -> int factorialor([int] -> int factorial) { + return + fun (int x) { + if (x == 0) { + return 1; + } + else { + return x * factorial(x - 1); + }; + }; +} + +int main(int n) { + [int] -> int factorial = fix(factorialor); + return factorial(n); +} diff --git a/collects/honu/examples/error-prim.honu b/collects/honu/examples/old/error-prim.honu similarity index 100% rename from collects/honu/examples/error-prim.honu rename to collects/honu/examples/old/error-prim.honu diff --git a/collects/honu/examples/field-exp-sub.honu b/collects/honu/examples/old/field-exp-sub.honu similarity index 100% rename from collects/honu/examples/field-exp-sub.honu rename to collects/honu/examples/old/field-exp-sub.honu diff --git a/collects/honu/examples/forgot-init.honu b/collects/honu/examples/old/forgot-init.honu similarity index 100% rename from collects/honu/examples/forgot-init.honu rename to collects/honu/examples/old/forgot-init.honu diff --git a/collects/honu/examples/func-test.honu b/collects/honu/examples/old/func-test.honu similarity index 100% rename from collects/honu/examples/func-test.honu rename to collects/honu/examples/old/func-test.honu diff --git a/collects/honu/examples/interpreter-str.honu b/collects/honu/examples/old/interpreter-str.honu similarity index 100% rename from collects/honu/examples/interpreter-str.honu rename to collects/honu/examples/old/interpreter-str.honu diff --git a/collects/honu/examples/interpreter.honu b/collects/honu/examples/old/interpreter.honu similarity index 100% rename from collects/honu/examples/interpreter.honu rename to collects/honu/examples/old/interpreter.honu diff --git a/collects/honu/examples/lambda-test.honu b/collects/honu/examples/old/lambda-test.honu similarity index 100% rename from collects/honu/examples/lambda-test.honu rename to collects/honu/examples/old/lambda-test.honu diff --git a/collects/honu/examples/matthias1.honu b/collects/honu/examples/old/matthias1.honu similarity index 100% rename from collects/honu/examples/matthias1.honu rename to collects/honu/examples/old/matthias1.honu diff --git a/collects/honu/examples/matthias2.honu b/collects/honu/examples/old/matthias2.honu similarity index 100% rename from collects/honu/examples/matthias2.honu rename to collects/honu/examples/old/matthias2.honu diff --git a/collects/honu/examples/mdcall-test.honu b/collects/honu/examples/old/mdcall-test.honu similarity index 100% rename from collects/honu/examples/mdcall-test.honu rename to collects/honu/examples/old/mdcall-test.honu diff --git a/collects/honu/examples/mdcall-test2.honu b/collects/honu/examples/old/mdcall-test2.honu similarity index 100% rename from collects/honu/examples/mdcall-test2.honu rename to collects/honu/examples/old/mdcall-test2.honu diff --git a/collects/honu/examples/method-exp-sub.honu b/collects/honu/examples/old/method-exp-sub.honu similarity index 100% rename from collects/honu/examples/method-exp-sub.honu rename to collects/honu/examples/old/method-exp-sub.honu diff --git a/collects/honu/examples/mixin-init.honu b/collects/honu/examples/old/mixin-init.honu similarity index 100% rename from collects/honu/examples/mixin-init.honu rename to collects/honu/examples/old/mixin-init.honu diff --git a/collects/honu/examples/old-stack.honu b/collects/honu/examples/old/old-stack.honu similarity index 100% rename from collects/honu/examples/old-stack.honu rename to collects/honu/examples/old/old-stack.honu diff --git a/collects/honu/examples/old/point.honu b/collects/honu/examples/old/point.honu new file mode 100644 index 0000000000..83eb430e75 --- /dev/null +++ b/collects/honu/examples/old/point.honu @@ -0,0 +1,56 @@ +/* Again, should parse and typecheck, though watch out for constructor + * syntax. + */ + +type Point +{ + int x; + int y; +} + +type ColorPoint extends Point +{ + int color; +} + +type MovingPoint extends Point +{ + float dx; + float dy; +} + +class PtClass() : Point implements Point +{ + init int x; + init int y; + + export Point : x as x, y as y; +} + +class ColorPtClass() : ColorPoint implements Point, ColorPoint +{ + /* We should add syntactic sugar for init fields. */ + + init int x; + init int y; + init int color; + + export Point : x as x, y as y; + export ColorPoint : x as x, y as y, color as color; +} + +mixin makeMovingPoint() : MovingPoint at Point impl MovingPoint +{ + init float dx; + init float dy; + super(); + + export MovingPoint : x, y, dx, dy; +} + +subclass MvPtCls = makeMovingPoint(PtClass); +subclass MvClrPtCls = makeMovingPoint(ColorPtClass); + +MovingPoint main() { + new MvClrPtCls : MovingPoint(x = 3, y = 4, color = 42, dx = 0.4, dy = -3.2); +} diff --git a/collects/honu/examples/rel-not-prim.honu b/collects/honu/examples/old/rel-not-prim.honu similarity index 100% rename from collects/honu/examples/rel-not-prim.honu rename to collects/honu/examples/old/rel-not-prim.honu diff --git a/collects/honu/examples/simple-init.honu b/collects/honu/examples/old/simple-init.honu similarity index 100% rename from collects/honu/examples/simple-init.honu rename to collects/honu/examples/old/simple-init.honu diff --git a/collects/honu/examples/square.honu b/collects/honu/examples/old/square.honu similarity index 100% rename from collects/honu/examples/square.honu rename to collects/honu/examples/old/square.honu diff --git a/collects/honu/examples/str-float-prim.honu b/collects/honu/examples/old/str-float-prim.honu similarity index 100% rename from collects/honu/examples/str-float-prim.honu rename to collects/honu/examples/old/str-float-prim.honu diff --git a/collects/honu/examples/struct-test.honu b/collects/honu/examples/old/struct-test.honu similarity index 100% rename from collects/honu/examples/struct-test.honu rename to collects/honu/examples/old/struct-test.honu diff --git a/collects/honu/examples/sub-bad-init.honu b/collects/honu/examples/old/sub-bad-init.honu similarity index 100% rename from collects/honu/examples/sub-bad-init.honu rename to collects/honu/examples/old/sub-bad-init.honu diff --git a/collects/honu/examples/sub-final.honu b/collects/honu/examples/old/sub-final.honu similarity index 100% rename from collects/honu/examples/sub-final.honu rename to collects/honu/examples/old/sub-final.honu diff --git a/collects/honu/examples/subclass-ext.honu b/collects/honu/examples/old/subclass-ext.honu similarity index 100% rename from collects/honu/examples/subclass-ext.honu rename to collects/honu/examples/old/subclass-ext.honu diff --git a/collects/honu/examples/uminus.honu b/collects/honu/examples/old/uminus.honu similarity index 100% rename from collects/honu/examples/uminus.honu rename to collects/honu/examples/old/uminus.honu diff --git a/collects/honu/examples/point.honu b/collects/honu/examples/point.honu index 83eb430e75..fd4357c81c 100644 --- a/collects/honu/examples/point.honu +++ b/collects/honu/examples/point.honu @@ -1,56 +1,36 @@ -/* Again, should parse and typecheck, though watch out for constructor - * syntax. - */ +struct PointC(int x, int y) : Point { } +struct ColorC(int r, int g, int b) : Color { } -type Point -{ - int x; - int y; +// Make extends clause look more like the first part of a class/struct, +// where the "with" args come in the same place as the init slots normally. + +struct Point3DC(int z) : Point3D extends PointC() : Point { super(); } + +type ColorPoint <: Point { Color c; } +type MovingPoint <: Point { void movePoint(int, int); } + +// Make mixins look more like functions for classes to classes by +// making their "type" look more like the following: +// +// () -> + +mixin addColor(Color c) : Point() -> ColorPoint impl ColorPoint { + super(); + export ColorPoint : x, y, c; +} +mixin makeMobile() : Point() -> MovingPoint impl MovingPoint { + super(); + void movePoint(int dx, int dy) { + x = x + dx; + y = y + dy; + } + export MovingPoint : x, y, movePoint; } -type ColorPoint extends Point -{ - int color; -} +class ColorPointC = addColor(PointC); +class MovingPointC = makeMobile(PointC); -type MovingPoint extends Point -{ - float dx; - float dy; -} - -class PtClass() : Point implements Point -{ - init int x; - init int y; - - export Point : x as x, y as y; -} - -class ColorPtClass() : ColorPoint implements Point, ColorPoint -{ - /* We should add syntactic sugar for init fields. */ - - init int x; - init int y; - init int color; - - export Point : x as x, y as y; - export ColorPoint : x as x, y as y, color as color; -} - -mixin makeMovingPoint() : MovingPoint at Point impl MovingPoint -{ - init float dx; - init float dy; - super(); - - export MovingPoint : x, y, dx, dy; -} - -subclass MvPtCls = makeMovingPoint(PtClass); -subclass MvClrPtCls = makeMovingPoint(ColorPtClass); - -MovingPoint main() { - new MvClrPtCls : MovingPoint(x = 3, y = 4, color = 42, dx = 0.4, dy = -3.2); -} +// only useable as a MovingPoint +class MovingColorPointC = makeMobile(ColorPointC); +// only usable as a ColorPoint +class ColorMovingPointC = addColor(MovingPointC); diff --git a/collects/honu/examples/struct.honu b/collects/honu/examples/struct.honu new file mode 100644 index 0000000000..9400c1e080 --- /dev/null +++ b/collects/honu/examples/struct.honu @@ -0,0 +1,5 @@ +struct PosnC(int x, int y) : Posn { } + +struct ColorC(int r, int g, int b) : Color { } + +struct ColorPosnC(Color c) : ColorPosn extends PosnC() : Posn { super(); } diff --git a/collects/honu/examples/tup-bind.honu b/collects/honu/examples/tup-bind.honu new file mode 100644 index 0000000000..22ddd7c403 --- /dev/null +++ b/collects/honu/examples/tup-bind.honu @@ -0,0 +1,6 @@ + f(int x) { return (x, x); } + +struct C() : T { + int x = 3; + int y = { (int x, int y) = f(x); x; }; +} diff --git a/collects/honu/examples/types-error.honu b/collects/honu/examples/types-error.honu new file mode 100644 index 0000000000..88d97fb639 --- /dev/null +++ b/collects/honu/examples/types-error.honu @@ -0,0 +1,13 @@ +type t1 { + int x; +} + +type t2 { + string x; + int m(int); +} + +type t3 <: t1, t2 { + int y; + int m2(int, int); +} diff --git a/collects/honu/examples/types.honu b/collects/honu/examples/types.honu new file mode 100644 index 0000000000..d9b05ed137 --- /dev/null +++ b/collects/honu/examples/types.honu @@ -0,0 +1,12 @@ +type t1 { + int x; +} + +type t2 { + int m(int); +} + +type t3 <: t1, t2 { + int y; + int m2(int, int); +} diff --git a/collects/honu/honu-compile-context.ss b/collects/honu/honu-context.ss similarity index 58% rename from collects/honu/honu-compile-context.ss rename to collects/honu/honu-context.ss index 2e5b7768dc..d98b1d86bb 100644 --- a/collects/honu/honu-compile-context.ss +++ b/collects/honu/honu-context.ss @@ -1,4 +1,4 @@ -(module honu-compile-context (lib "base.ss" "honu") +(module honu-context (lib "base.ss" "honu") (provide honu-compile-context) (define honu-compile-context #'here)) diff --git a/collects/honu/parsers/lex.ss b/collects/honu/parsers/lex.ss new file mode 100644 index 0000000000..bd9a758435 --- /dev/null +++ b/collects/honu/parsers/lex.ss @@ -0,0 +1,276 @@ +(module lex mzscheme + (require (lib "lex.ss" "parser-tools") + (prefix : (lib "lex-sre.ss" "parser-tools")) + "../readerr.ss") + + (define-lex-abbrevs + [lex:letter (:or (:/ #\a #\z) (:/ #\A #\Z))] + [lex:digit (:/ #\0 #\9)] + [lex:whitespace (:or #\newline #\return #\tab #\space #\vtab)] + + [lex:keyword (:or "type" "interface" "class" "mixin" "struct" "extends" "final" + "impl" "implements" "init" "export" "as" "at" "with" "fun" + "this" "my" "isa" "int" "bool" "string" "float" "char" "Any" + "while" "if" "cond" "else" "new" "super" "cast" "return")] + [lex:grouping (:or "{" "}" "[" "]" "(" ")")] + [lex:separator (:or "," ":" ";" "=" "." "<:" "->" "=>" "@" "_")] + [lex:operator (:or "!" "||" "&&" "!=" "==" "<" "<=" ">" ">=" "+" "-" "*" "/" "%" "====")] + [lex:selector (:: "#" (:+ lex:digit))] + + [lex:string (:: #\" ;; A quoted string starts with a " + (:* (:or (:~ #\\ #\") ;; and has things in it which are + (:: #\\ any-char))) ;; not "s (but \" is okay) + #\")] ;; and ends with a ". + [lex:character (:: #\' any-char #\')] + [lex:ident (:: (:or lex:letter) (:* (:or #\_ lex:letter lex:digit)))] + [lex:integer (:: (:? #\-) (:+ lex:digit))] + [lex:float (:: (:? #\-) (:: (:+ lex:digit) #\. (:+ lex:digit)))] + [lex:line-comment (:: "//" (:* (:~ #\newline)))]) + + (provide EOF for-prec lex-errors keywords separators operators val-tokens) + + (define-tokens EOF + (EOF)) + + (define-empty-tokens for-prec + (UMINUS)) + + (define-tokens lex-errors + (UNPARSEABLE)) + + (define-tokens keywords + (type interface class mixin struct + extends final impl implements + init export as at with + this my null isa + int bool string float char Any void + if cond else true false while fun + new super cast return)) + + (define-tokens separators + (O_CURLY C_CURLY O_BRACE C_BRACE O_PAREN C_PAREN COMMA COLON SEMI_COLON BINDS DOT SUBTYPE ARROW THICK_ARROW AT USCORE)) + + (define-tokens operators + (NOT OR AND NEQ EQUALS LT LE GT GE PLUS MINUS TIMES DIV MOD CLS_EQ)) + + (define-tokens val-tokens + (character floatnum string-lit integer id selector)) + + (define stx-for-original-property (read-syntax #f (open-input-string "original"))) + + (provide create-src-stx) + (define (create-src-stx val source-name start-pos end-pos) + (datum->syntax-object #f val + (list + source-name + (position-line start-pos) + (position-col start-pos) + (position-offset start-pos) + (- (position-offset end-pos) + (position-offset start-pos))) + stx-for-original-property)) + + (define-syntax (token stx) + (syntax-case stx () + [(_ name val) + (identifier? (syntax name)) + (let ([name (syntax name)]) + (with-syntax ([token-name (datum->syntax-object + name + (string->symbol + (format "token-~a" (syntax-e name))))] + [source-name (datum->syntax-object name 'source-name)] + [start-pos (datum->syntax-object name 'start-pos)] + [end-pos (datum->syntax-object name 'end-pos)]) + (syntax + (token-name + (create-src-stx val source-name start-pos end-pos)))))])) + + (define-syntax (ttoken stx) + (syntax-case stx () + [(_ name) + (identifier? (syntax name)) + (syntax (token name 'name))])) + + (provide generate-honu-lexer) + (define (generate-honu-lexer source-name) + (define honu-lexer + (lexer-src-pos + ;; can we just use lex:keyword somehow? + ["type" (ttoken type)] + ["interface" (ttoken interface)] + ["class" (ttoken class)] + ["mixin" (ttoken mixin)] + ["struct" (ttoken struct)] + ["extends" (ttoken extends)] + ["final" (ttoken final)] + ["impl" (ttoken impl)] + ["implements" (ttoken implements)] + ["init" (ttoken init)] + ["export" (ttoken export)] + ["as" (ttoken as)] + ["at" (ttoken at)] + ["with" (ttoken with)] + ["fun" (ttoken fun)] + ["this" (ttoken this)] + ["my" (ttoken my)] + ["null" (ttoken null)] + ["isa" (ttoken isa)] + ["int" (ttoken int)] + ["bool" (ttoken bool)] + ["string" (ttoken string)] + ["float" (ttoken float)] + ["char" (ttoken char)] + ["Any" (ttoken Any)] + ["void" (ttoken void)] + ["while" (ttoken while)] + ["if" (ttoken if)] + ["cond" (ttoken cond)] + ["else" (ttoken else)] + ["new" (ttoken new)] + ["super" (ttoken super)] + ["cast" (ttoken cast)] + ["return" (ttoken return)] + ["true" (token true #t)] + ["false" (token false #f)] + ["{" (ttoken O_CURLY)] + ["}" (ttoken C_CURLY)] + ["[" (ttoken O_BRACE)] + ["]" (ttoken C_BRACE)] + ["(" (ttoken O_PAREN)] + [")" (ttoken C_PAREN)] + ["," (ttoken COMMA)] + [":" (ttoken COLON)] + [";" (ttoken SEMI_COLON)] + ["->" (ttoken ARROW)] + ["=>" (ttoken THICK_ARROW)] + ["@" (ttoken AT)] + ["_" (token USCORE '_)] + ["=" (token BINDS 'binds)] + ["!=" (token NEQ 'neq)] + ["==" (token EQUALS 'equal)] + ["====" (token CLS_EQ 'cls_eq)] + ["!" (token NOT 'not)] + ["&&" (token AND 'and)] + ["||" (token OR 'or)] + ["<" (token LT 'lt)] + ["<=" (token LE 'le)] + [">" (token GT 'gt)] + [">=" (token GE 'ge)] + ["+" (token PLUS 'plus)] + ["-" (token MINUS 'minus)] + ["*" (token TIMES 'times)] + ["/" (token DIV 'div)] + ["%" (token MOD 'mod)] + ["." (token DOT 'dot)] + ["<:" (token SUBTYPE 'subtype)] + [lex:selector + (token selector (string->number (substring lexeme 1 (string-length lexeme))))] + [lex:ident + (token id (string->symbol lexeme))] + [lex:integer + (token integer (string->number lexeme))] + [lex:float + (token floatnum (string->number lexeme))] + [lex:character + (token character (string-ref lexeme 1))] + [lex:string + (token string-lit (substring lexeme 1 (- (string-length lexeme) 1)))] + [lex:line-comment + (return-without-pos (honu-lexer input-port))] + [(:: #\/ #\*) + (begin (comment-lexer source-name start-pos input-port) ;; Get the rest of the comment... + (return-without-pos (honu-lexer input-port)))] ;; then get the next token. + [(:+ lex:whitespace) + (return-without-pos (honu-lexer input-port))] + [(eof) + (ttoken EOF)] + [any-char (token UNPARSEABLE (string->symbol lexeme))])) + honu-lexer) + + (define comment-lexer + (lambda (source-name first-pos port) + (letrec ([lxr (lexer-src-pos + [(:: #\/ #\*) + (begin (lxr input-port) ;; once for the nested comment + (return-without-pos (lxr input-port)))] ;; now finish out the current one + [(:: #\* #\/) + #f] ;; This will get ignored by the call to comment-lexer (whether nested or no) + [(eof) + (raise-read-error-with-stx + "Unexpected end of file while inside block comment." + (create-src-stx eof source-name first-pos end-pos))] + [(:~) + (return-without-pos (lxr input-port))])]) + (lxr port)))) + + (define (syn-val lex a b c d) + (values lex a b (position-offset c) (position-offset d))) + + (define get-block-comment + (lexer + [(:: #\/ #\*) + (begin (get-block-comment input-port) ;; once for the nested comment + (get-block-comment input-port))] ;; now finish out the current one + [(:: #\* #\/) + end-pos] ;; This will get ignored by the call to comment-lexer (whether nested or no) + [(eof) + end-pos] + [(:~) + (get-block-comment input-port)])) + + (define (colorize-string my-start-pos) + (define lxr + (lexer + [#\" (syn-val "" 'string #f my-start-pos end-pos)] + [(eof) (syn-val "" 'error #f my-start-pos end-pos)] + [(:: #\\ #\") (lxr input-port)] + [any-char (lxr input-port)])) + lxr) + + (provide get-syntax-token) + (define get-syntax-token + (lexer + [lex:keyword + (syn-val lexeme 'keyword #f start-pos end-pos)] + [lex:operator + (syn-val lexeme 'keyword #f start-pos end-pos)] + [lex:selector + (syn-val lexeme 'keyword #f start-pos end-pos)] + + [lex:separator + (syn-val lexeme 'default #f start-pos end-pos)] + + [lex:grouping + (syn-val lexeme 'parenthesis #f start-pos end-pos)] + + [lex:ident + (syn-val lexeme 'identifier #f start-pos end-pos)] + + [(:or "true" "false" "null") + (syn-val lexeme 'literal #f start-pos end-pos)] + [lex:integer + (syn-val lexeme 'literal #f start-pos end-pos)] + [lex:float + (syn-val lexeme 'literal #f start-pos end-pos)] + [lex:character + (syn-val lexeme 'literal #f start-pos end-pos)] + + [#\" + ((colorize-string start-pos) input-port)] + + [(:+ lex:whitespace) + (syn-val lexeme 'whitespace #f start-pos end-pos)] + + [lex:line-comment + (syn-val lexeme 'comment #f start-pos end-pos)] + [(:: #\/ #\*) + (syn-val lexeme 'comment #f start-pos (get-block-comment input-port))] + + [(eof) + (syn-val lexeme 'eof #f start-pos end-pos)] + + [any-char + (syn-val lexeme 'error #f start-pos end-pos)])) + + ) diff --git a/collects/honu/parsers/parse.ss b/collects/honu/parsers/parse.ss index 4516505665..e90628effe 100644 --- a/collects/honu/parsers/parse.ss +++ b/collects/honu/parsers/parse.ss @@ -1,228 +1,50 @@ (module parse mzscheme - (require (lib "lex.ss" "parser-tools") - (prefix : (lib "lex-sre.ss" "parser-tools")) - (lib "yacc.ss" "parser-tools") - (lib "readerr.ss" "syntax") - "../ast.ss") - (define (make-struct-type-decls mfidefns) + (require (lib "yacc.ss" "parser-tools") + "lex.ss" + "../readerr.ss" + "../ast.ss" + "../utils.ss" + "../private/typechecker/type-utils.ss") + + (define (make-struct-type-decls inits mfidefns) (define (convert-to-decl d) (cond - [(honu-init-field? d) - (make-honu-field-decl (honu-ast-src-stx d) - (honu-init-field-name d) - (honu-init-field-type d))] - [(honu-field? d) - (make-honu-field-decl (honu-ast-src-stx d) - (honu-field-name d) - (honu-field-type d))] - [(honu-method? d) - (make-honu-method-decl (honu-ast-src-stx d) - (honu-method-name d) - (honu-method-type d) - (honu-method-arg-types d))])) - (map convert-to-decl mfidefns)) + [(honu:formal? d) + (make-honu:field-decl (honu:ast-stx d) + (honu:formal-name d) + (honu:formal-type d))] + [(honu:init-field? d) + (make-honu:field-decl (honu:ast-stx d) + (honu:init-field-name d) + (honu:init-field-type d))] + [(honu:field? d) + (make-honu:field-decl (honu:ast-stx d) + (honu:field-name d) + (honu:field-type d))] + [(honu:method? d) + (make-honu:method-decl (honu:ast-stx d) + (honu:method-name d) + (honu:method-type d) + (map honu:formal-type (honu:method-formals d)))])) + (map convert-to-decl (append inits mfidefns))) - (define (make-struct-exports typ mfidefns) + (define (make-struct-exports typ inits members) (define (grab-name 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)])) - (let ((names (map grab-name mfidefns))) - (list (make-honu-export #f typ names names)))) - - (define-lex-abbrevs [lex:letter (:or (:/ #\a #\z) (:/ #\A #\Z))] - [lex:digit (:/ #\0 #\9)] - [lex:whitespace (:or #\newline #\return #\tab #\space #\vtab)]) - - (define-tokens EOF - (EOF)) - - (define-empty-tokens for-prec - (UMINUS)) - - (define-tokens lex-errors - (UNPARSEABLE)) - - (define-tokens keywords - (type interface class mixin subclass struct - extends final impl implements - init export as at with - this my null isa - int bool str float char Any void - if else true false while fun - new super cast return)) - - (define-tokens separators - (O_CURLY C_CURLY O_BRACE C_BRACE O_PAREN C_PAREN COMMA COLON SEMI_COLON BINDS DOT SUBTYPE ARROW)) - - (define-tokens operators - (NOT OR AND NEQ EQUALS LT LE GT GE PLUS MINUS TIMES DIV MOD CLS_EQ)) - - (define-tokens val-tokens - (character floatnum string integer id)) - - (define stx-for-original-property (read-syntax #f (open-input-string "original"))) - - (define (create-src-stx val source-name start-pos end-pos) - (datum->syntax-object #f val - (list - source-name - (position-line start-pos) - (position-col start-pos) - (position-offset start-pos) - (- (position-offset end-pos) - (position-offset start-pos))) - stx-for-original-property)) - - (define (raise-read-error-with-stx str stx) - (raise-read-error str - (syntax-source stx) - (syntax-line stx) - (syntax-column stx) - (syntax-position stx) - (syntax-span stx))) - - (define-syntax (token stx) - (syntax-case stx () - [(_ name val) - (identifier? (syntax name)) - (let ([name (syntax name)]) - (with-syntax ([token-name (datum->syntax-object - name - (string->symbol - (format "token-~a" (syntax-e name))))] - [source-name (datum->syntax-object name 'source-name)] - [start-pos (datum->syntax-object name 'start-pos)] - [end-pos (datum->syntax-object name 'end-pos)]) - (syntax - (token-name - (create-src-stx val source-name start-pos end-pos)))))])) - - (define-syntax (ttoken stx) - (syntax-case stx () - [(_ name) - (identifier? (syntax name)) - (syntax (token name 'name))])) - - - (define (generate-honu-lexer source-name) - (define honu-lexer - (lexer-src-pos - ["type" (ttoken type)] - ["interface" (ttoken interface)] - ["class" (ttoken class)] - ["mixin" (ttoken mixin)] - ["subclass" (ttoken subclass)] - ["struct" (ttoken struct)] - ["extends" (ttoken extends)] - ["final" (ttoken final)] - ["impl" (ttoken impl)] - ["implements" (ttoken implements)] - ["init" (ttoken init)] - ["export" (ttoken export)] - ["as" (ttoken as)] - ["at" (ttoken at)] - ["with" (ttoken with)] - ["fun" (ttoken fun)] - ["this" (ttoken this)] - ["my" (ttoken my)] - ["null" (ttoken null)] - ["isa" (ttoken isa)] - ["int" (ttoken int)] - ["bool" (ttoken bool)] - ["str" (ttoken str)] - ["float" (ttoken float)] - ["char" (ttoken char)] - ["Any" (ttoken Any)] - ["void" (ttoken void)] - ["while" (ttoken while)] - ["if" (ttoken if)] - ["else" (ttoken else)] - ["true" (token true #t)] - ["false" (token false #f)] - ["new" (ttoken new)] - ["super" (ttoken super)] - ["cast" (ttoken cast)] - ["return" (ttoken return)] - ["{" (ttoken O_CURLY)] - ["}" (ttoken C_CURLY)] - ["[" (ttoken O_BRACE)] - ["]" (ttoken C_BRACE)] - ["(" (ttoken O_PAREN)] - [")" (ttoken C_PAREN)] - ["," (ttoken COMMA)] - [":" (ttoken COLON)] - [";" (ttoken SEMI_COLON)] - ["->" (token ARROW 'arrow)] - ["=" (token BINDS 'binds)] - ["!=" (token NEQ 'neq)] - ["==" (token EQUALS 'equal)] - ["====" (token CLS_EQ 'cls_eq)] - ["!" (token NOT 'not)] - ["&&" (token AND 'and)] - ["||" (token OR 'or)] - ["<" (token LT 'lt)] - ["<=" (token LE 'le)] - [">" (token GT 'gt)] - [">=" (token GE 'ge)] - ["+" (token PLUS 'plus)] - ["-" (token MINUS 'minus)] - ["*" (token TIMES 'times)] - ["/" (token DIV 'div)] - ["%" (token MOD 'mod)] - ["." (token DOT 'dot)] - ["<:" (token SUBTYPE 'subtype)] - [(:: (:or lex:letter) - (:* (:or #\_ lex:letter lex:digit))) - (token id (string->symbol lexeme))] - [(:: (:? #\-) - (:+ lex:digit)) - (token integer (string->number lexeme))] - [(:: (:? #\-) - (:: (:+ lex:digit) #\. (:+ lex:digit))) - (token floatnum (string->number lexeme))] - [(:: #\' any-char #\') - (token character (string-ref lexeme 1))] - [(:: #\" ;; A quoted string starts with a " - (:* (:or (:~ #\\ #\") ;; and has things in it which are - (:: #\\ any-char))) ;; not "s (but \" is okay) - #\") ;; and ends with a ". - (token string (substring lexeme 1 (- (string-length lexeme) 1)))] - [(:: "//" - (:* (:~ #\newline))) - (return-without-pos (honu-lexer input-port))] - [(:: #\/ #\*) - (begin (comment-lexer source-name start-pos input-port) ;; Get the rest of the comment... - (return-without-pos (honu-lexer input-port)))] ;; then get the next token. - [(:+ lex:whitespace) - (return-without-pos (honu-lexer input-port))] - [(eof) - (ttoken EOF)] - [any-char (token UNPARSEABLE (string->symbol lexeme))])) - honu-lexer) - - (define comment-lexer - (lambda (source-name first-pos port) - (letrec ([lxr (lexer-src-pos - [(:: #\/ #\*) - (begin (lxr input-port) ;; once for the nested comment - (return-without-pos (lxr input-port)))] ;; now finish out the current one - [(:: #\* #\/) - #f] ;; This will get ignored by the call to comment-lexer (whether nested or no) - [(eof) - (raise-read-error-with-stx - "Unexpected end of file while inside block comment." - (create-src-stx eof source-name first-pos end-pos))] - [(:~) - (return-without-pos (lxr input-port))])]) - (lxr port)))) + [(honu:formal? d) (honu:formal-name d)] + [(honu:init-field? d) (honu:init-field-name d)] + [(honu:field? d) (honu:field-name d)] + [(honu:method? d) (honu:method-name d)])) + (let ([binds (map (lambda (m) + (let ([name (grab-name m)]) + (make-honu:exp-bind name name))) (append inits members))]) + (list (make-honu:export #f typ binds)))) (define (generate-honu-parser source-name) (define honu-parser (parser - (start program interact) + (start ) (end EOF) (src-pos) ;; (debug "honu.debug") @@ -233,7 +55,10 @@ ;; ignored. I don't want to turn off the warnings yet in case this ;; number increases, which means that I've added additional ;; conflicts. - (precs (left else) + (precs (right ARROW) ;; for types + + (nonassoc return) + (left else) ;; for expressions (left BINDS) (left OR) (left AND) @@ -242,7 +67,9 @@ (nonassoc LT LE GT GE) (left PLUS MINUS) (left TIMES DIV MOD) - (nonassoc NOT UMINUS) + (nonassoc NOT UMINUS) ;; unary operators + (left O_PAREN) ;; this gives application a precedence + (nonassoc selector) (right COLON isa) (left DOT)) (tokens keywords separators operators val-tokens lex-errors EOF for-prec) @@ -251,507 +78,557 @@ (format "parse error near ~a" (syntax-e stx)) stx))) (grammar - (program - [(defns) - (make-honu-program $1)]) - (defns - [(defn defns) - (if (honu-ast? $1) + ( + [() + $1]) + ( + [( ) + (if (honu:ast? $1) (cons $1 $2) (append $1 $2))] [() (list)]) - (defn - [(fun-defn) + ( + [() $1] - [(type-defn) + [() $1] - [(class-defn) + [() $1] - [(struct-defn) + [() $1] - [(mixin-defn) + [() $1] - [(subclass-defn) + [() $1]) + + ( + [( BINDS SEMI_COLON) + (make-honu:bind-top + (create-src-stx 'honu:bind-top source-name $1-start-pos $4-end-pos) + (list (honu:formal-name $1)) (list (honu:formal-type $1)) $3)] + [(O_PAREN C_PAREN BINDS SEMI_COLON) + (let-values ([(names types) (map-two-values (lambda (f) + (values (honu:formal-name f) + (honu:formal-type f))) + $2)]) + (make-honu:bind-top + (create-src-stx 'honu:bind-top source-name $1-start-pos $6-end-pos) + names types $5))]) + ( + [( COMMA ) + (cons $1 $3)] + [() + (list $1)]) + ( + [( id) + (make-honu:formal + (create-src-stx 'honu:formal source-name $1-start-pos $2-end-pos) + $2 $1)] + [(USCORE) + (make-honu:formal + (create-src-stx 'honu:formal source-name $1-start-pos $1-end-pos) + #f (make-top-type $1))]) - (fun-defn - [(any-type id O_PAREN args C_PAREN block) - (make-honu-function - (create-src-stx 'honu-function source-name $1-start-pos $6-end-pos) - $2 $1 (cdr $4) (car $4) $6)]) + ( + [( id O_PAREN C_PAREN ) + (make-honu:function + (create-src-stx 'honu:function source-name $1-start-pos $6-end-pos) + $2 $1 $4 $6)]) ;; Type definitions and needed parts - (type-defn - [(type id ext-clause - O_CURLY fmdecs C_CURLY) - (make-honu-type-defn - (create-src-stx 'honu-type-defn source-name $1-start-pos $6-end-pos) - $2 $3 $5)] - [(interface id ext-clause - O_CURLY fmdecs C_CURLY) - (make-honu-type-defn - (create-src-stx 'honu-type-defn source-name $1-start-pos $6-end-pos) + ( + [( id O_CURLY C_CURLY) + (make-honu:iface + (create-src-stx 'honu:iface source-name $1-start-pos $6-end-pos) $2 $3 $5)]) - (type-id + ( + [(type) (void)] + [(interface) (void)]) + ( [(id) - (make-honu-iface-type $1 $1)] + (make-iface-type $1 $1)] [(Any) - (make-honu-iface-top-type - (create-src-stx 'Any source-name $1-start-pos $1-end-pos))]) - (any-type - [(type-id) + (make-any-type $1)]) + ( + [() $1] [(void) - (make-honu-top-type - (create-src-stx 'void source-name $1-start-pos $1-end-pos))] + (make-void-type $1)] [(int) - (make-honu-prim-type $1 'int)] + (make-int-type $1)] [(bool) - (make-honu-prim-type $1 'bool)] + (make-bool-type $1)] [(float) - (make-honu-prim-type $1 'float)] + (make-float-type $1)] [(char) - (make-honu-prim-type $1 'char)] - [(str) - (make-honu-prim-type $1 'str)] - [(O_BRACE tup-type C_BRACE ARROW any-type) - (make-honu-func-type - (create-src-stx 'honu-func-type source-name $2-start-pos $5-end-pos) - $2 $5)]) - (tup-type - [() - (list)] - [(tup-type+) - $1]) - (tup-type+ - [(any-type) + (make-char-type $1)] + [(string) + (make-string-type $1)] + [() + $1] + [( ARROW ) + (make-func-type + (create-src-stx 'honu:func-type source-name $1-start-pos $3-end-pos) + $1 $3)]) + ( + [(LT GT) + (make-tuple-type + (create-src-stx 'honu:type-tuple source-name $1-start-pos $2-end-pos) + (list))] + [(LT GT) + (if (null? (cdr $2)) + (car $2) + (make-tuple-type + (create-src-stx 'honu:type-tuple source-name $1-start-pos $3-end-pos) + $2))]) + ( + [() (list $1)] - [(any-type COMMA tup-type+) + [( COMMA ) (cons $1 $3)]) - (ext-clause - [(extends type-ids+) + ( + [(extends ) $2] - [(SUBTYPE type-ids+) + [(SUBTYPE ) $2] [() '()]) - (ids+ - [(id COMMA ids+) + ( + [( COMMA ) (cons $1 $3)] - [(id) + [() (list $1)]) - (type-ids+ - [(type-id COMMA type-ids+) - (cons $1 $3)] - [(type-id) - (list $1)]) - (args - [(args-cd) + ( + [() $1] - [() - (cons (list) (list))]) - (args-cd - [(arg COMMA args-cd) - (cons (cons (car $1) (car $3)) (cons (cdr $1) (cdr $3)))] - [(arg) - (cons (list (car $1)) (list (cdr $1)))]) - (arg - [(any-type id) - (cons $1 $2)]) - (fmdecs - [(fdec fmdecs) - (cons $1 $2)] - [(mdec fmdecs) - (cons $1 $2)] [() (list)]) - (fdec - [(any-type field-id SEMI_COLON) - (make-honu-field-decl - (create-src-stx 'honu-field-decl source-name $1-start-pos $3-end-pos) + ( + [( COMMA ) + (cons $1 $3)] + [() + (list $1)]) + ( + [( id) + (make-honu:formal + (create-src-stx 'honu:formal source-name $1-start-pos $2-end-pos) $2 $1)]) - (field-id - [(id) - $1]) - (mdec - [(any-type meth-id O_PAREN mdec-args C_PAREN SEMI_COLON) - (make-honu-method-decl - (create-src-stx 'honu-method-decl source-name $1-start-pos $6-end-pos) + ( + [( ) + (cons $1 $2)] + [( ) + (cons $1 $2)] + [() + (list)]) + ( + [( id SEMI_COLON) + (make-honu:field-decl + (create-src-stx 'honu:field-decl source-name $1-start-pos $3-end-pos) + $2 $1)]) + ( + [( id O_PAREN C_PAREN SEMI_COLON) + (make-honu:method-decl + (create-src-stx 'honu:method-decl source-name $1-start-pos $6-end-pos) $2 $1 $4)]) - (meth-id - [(id) - $1]) - (mdec-args - [(mdec-args-cd) + ( + [() $1] [() (list)]) - (mdec-args-cd - [(mdec-arg COMMA mdec-args-cd) + ( + [( COMMA ) (cons $1 $3)] - [(mdec-arg) + [() (list $1)]) - (mdec-arg - [(any-type) + ( + [() $1] - [(any-type id) + [( id) $1]) + ( + [(struct id COLON O_CURLY C_CURLY) + (make-honu:struct + (create-src-stx 'honu:struct source-name $1-start-pos $10-end-pos) + $2 $5 #f $6 $3 $8 $9)] + [(final struct id COLON O_CURLY C_CURLY) + (make-honu:struct + (create-src-stx 'honu:struct source-name $1-start-pos $11-end-pos) + $3 $6 #t $7 $4 $9 $10)] + [(struct id COLON extends id COLON + O_CURLY C_CURLY) + (make-honu:substruct + (create-src-stx 'honu:substruct source-name $1-start-pos $17-end-pos) + $2 $5 $7 $10 #f $11 $3 $8 $14 $13 $15 $16)] + [(final struct id COLON extends id COLON + O_CURLY C_CURLY) + (make-honu:substruct + (create-src-stx 'honu:substruct source-name $1-start-pos $18-end-pos) + $3 $6 $8 $11 #t $12 $4 $9 $15 $14 $16 $17)]) - (struct-defn - [(struct class-id init-args COLON type-id O_CURLY fmidefns C_CURLY) - (let ([struct-stx (create-src-stx 'honu-struct source-name $1-start-pos $8-end-pos)]) - (list (make-honu-type-defn struct-stx (honu-iface-type-name $5) (list) (make-struct-type-decls $7)) - (make-honu-class struct-stx $2 $5 #f (cdr $3) (car $3) (list $5) $7 - (make-struct-exports $5 $7))))] - [(final struct class-id init-args COLON type-id O_CURLY fmidefns C_CURLY) - (let ([struct-stx (create-src-stx 'honu-struct source-name $1-start-pos $9-end-pos)]) - (list (make-honu-type-defn struct-stx (honu-iface-type-name $6) (list) (make-struct-type-decls $8)) - (make-honu-class struct-stx $3 $6 #t (cdr $4) (car $4) (list $6) $8 - (make-struct-exports $6 $8))))]) + ;; Class and subclass definitions and needed parts - ;; Class definitions and needed parts + ( + [(class id COLON O_CURLY C_CURLY) + (make-honu:class + (create-src-stx 'honu:class source-name $1-start-pos $10-end-pos) + $2 $5 #f $6 $3 $8 $9)] + [(final class id COLON O_CURLY C_CURLY) + (make-honu:class + (create-src-stx 'honu:class source-name $1-start-pos $11-end-pos) + $3 $6 #t $7 $3 $9 $10)] + [(class id BINDS id O_PAREN id C_PAREN SEMI_COLON) + (make-honu:subclass + (create-src-stx 'honu:subclass source-name $1-start-pos $8-end-pos) + $2 $6 $4)] + [(class id COLON extends id COLON + O_CURLY C_CURLY) + (let ([mixin-name (datum->syntax-object $2 (string->symbol (string-append "$" (symbol->string (syntax-e $2)))) $2)] + [subclass-stx (create-src-stx 'honu:subclass source-name $1-start-pos $17-end-pos)]) + (list (make-honu:mixin subclass-stx mixin-name $5 $10 #f $11 $3 $8 $14 $13 $15 $16) + (make-honu:subclass subclass-stx $2 $7 mixin-name)))] + [(final class id COLON extends id COLON + O_CURLY C_CURLY) + (let ([mixin-name (datum->syntax-object $3 (string->symbol (string-append "$" (symbol->string (syntax-e $3)))))] + [subclass-stx (create-src-stx 'honu:subclass source-name $1-start-pos $18-end-pos)]) + (list (make-honu:mixin subclass-stx mixin-name $6 $10 #t $12 $4 $9 $15 $14 $16 $17) + (make-honu:subclass subclass-stx $3 $8 mixin-name)))]) - (class-defn - [(class class-id init-args COLON type-id imp-clause - O_CURLY fmidefns exports C_CURLY) - (make-honu-class - (create-src-stx 'honu-class source-name $1-start-pos $10-end-pos) - $2 $5 #f (cdr $3) (car $3) $6 $8 $9)] - [(final class class-id init-args COLON type-id imp-clause - O_CURLY fmidefns exports C_CURLY) - (make-honu-class - (create-src-stx 'honu-class source-name $1-start-pos $11-end-pos) - $3 $6 #t (cdr $4) (car $4) $7 $9 $10)]) - (class-id - [(id) - $1]) - (init-args - [(O_PAREN args-cd C_PAREN) + ( + [(impl ) $2] - [(O_PAREN C_PAREN) - (cons (list) (list))]) - (imp-clause - [(impl type-ids+) - $2] - [(implements type-ids+) + [(implements ) $2] [() '()]) - (fmidefns - [(fdefn fmidefns) + ( + [(O_PAREN C_PAREN) + $2]) + ( + [(at ) + $2] + [(AT ) + $2]) + ( + [( ) (cons $1 $2)] - [(mdefn fmidefns) + [( ) (cons $1 $2)] - [(initdefn fmidefns) + [( ) (cons $1 $2)] [() (list)]) - (fdefn - [(any-type field-id BINDS expr SEMI_COLON) - (make-honu-field - (create-src-stx 'honu-field source-name $1-start-pos $5-end-pos) + ( + [( id BINDS SEMI_COLON) + (make-honu:field + (create-src-stx 'honu:field source-name $1-start-pos $5-end-pos) $2 $1 $4)]) - (mdefn - [(any-type meth-id O_PAREN args C_PAREN block) - (make-honu-method - (create-src-stx 'honu-method source-name $1-start-pos $6-end-pos) - $2 $1 (cdr $4) (car $4) $6)]) - (initdefn - [(init any-type field-id SEMI_COLON) - (make-honu-init-field - (create-src-stx 'honu-init-field source-name $1-start-pos $4-end-pos) + ( + [( id O_PAREN C_PAREN ) + (make-honu:method + (create-src-stx 'honu:method source-name $1-start-pos $6-end-pos) + $2 $1 $4 $6)]) + ( + [(init id SEMI_COLON) + (make-honu:init-field + (create-src-stx 'honu:init-field source-name $1-start-pos $4-end-pos) $3 $2 #f)] - [(init any-type field-id BINDS expr SEMI_COLON) - (make-honu-init-field - (create-src-stx 'honu-init-field source-name $1-start-pos $4-end-pos) + [(init id BINDS SEMI_COLON) + (make-honu:init-field + (create-src-stx 'honu:init-field source-name $1-start-pos $4-end-pos) $3 $2 $5)]) - (exports - [(expdefn exports) + ( + [( ) (cons $1 $2)] [() (list)]) - (expdefn - [(export type-id COLON expdecs SEMI_COLON) - (make-honu-export - (create-src-stx 'honu-export source-name $1-start-pos $5-end-pos) - $2 (car $4) (cdr $4))] - [(export type-id SEMI_COLON) - (make-honu-export - (create-src-stx 'honu-export source-name $1-start-pos $3-end-pos) - $2 (list) (list))]) - (expdecs - [(expdec COMMA expdecs) - (cons (cons (car $1) (car $3)) (cons (cdr $1) (cdr $3)))] - [(expdec) - (cons (list (car $1)) (list (cdr $1)))]) - (expdec - [(id as id) + ( + [(export COLON SEMI_COLON) + (make-honu:export + (create-src-stx 'honu:export source-name $1-start-pos $5-end-pos) + $2 $4)] + [(export SEMI_COLON) + (make-honu:export + (create-src-stx 'honu:export source-name $1-start-pos $3-end-pos) + $2 (list))]) + ( + [( COMMA ) (cons $1 $3)] + [() + (list $1)]) + ( + [(id as id) + (make-honu:exp-bind $1 $3)] [(id) - (cons $1 $1)]) + (make-honu:exp-bind $1 $1)]) ;; Mixin definitions - (mixin-defn - [(mixin mixin-id init-args COLON type-id at type-id imp-clause with-clause - O_CURLY fmidefns supernew fmidefns exports C_CURLY) - (make-honu-mixin - (create-src-stx 'honu-mixin source-name $1-start-pos $15-end-pos) - $2 $5 $7 #f (cdr $3) (car $3) $8 (cdr $9) (car $9) $11 $12 $13 $14)] - [(final mixin mixin-id init-args COLON type-id at type-id imp-clause with-clause - O_CURLY fmidefns supernew fmidefns exports C_CURLY) - (make-honu-mixin - (create-src-stx 'honu-mixin source-name $1-start-pos $16-end-pos) - $3 $6 $8 #t (cdr $4) (car $4) $9 (cdr $10) (car $10) $12 $13 $14 $15)]) - (mixin-id - [(id) - $1]) - (with-clause - [(with args-cd) + ( + [(mixin id COLON ARROW + O_CURLY C_CURLY) + (make-honu:mixin + (create-src-stx 'honu:mixin source-name $1-start-pos $15-end-pos) + $2 $8 $5 #f $9 $3 $6 $12 $11 $13 $14)] + [(final mixin id COLON ARROW + O_CURLY C_CURLY) + (make-honu:mixin + (create-src-stx 'honu:mixin source-name $1-start-pos $16-end-pos) + $3 $9 $6 #t $10 $4 $7 $13 $12 $14 $15)]) + ( + [(with ) $2] [() - (cons (list) (list))]) - (supernew - [(super O_PAREN newargs C_PAREN SEMI_COLON) - (make-honu-super-new - (create-src-stx 'honu-super-new source-name $1-start-pos $4-end-pos) - (car $3) (cdr $3))]) - - ;; Subclass definitions - - (subclass-defn - [(subclass class-id BINDS mixin-id O_PAREN class-id C_PAREN SEMI_COLON) - (make-honu-subclass - (create-src-stx 'honu-subclass source-name $1-start-pos $8-end-pos) - $2 $4 $6)] - [(subclass class-id init-args COLON type-id extends class-id at type-id imp-clause with-clause - O_CURLY fmidefns supernew fmidefns exports C_CURLY) - (let ([mixin-name (datum->syntax-object $2 (string->symbol (string-append "$" (symbol->string (syntax-e $2)))) $2)] - [subclass-stx (create-src-stx 'honu-subclass source-name $1-start-pos $17-end-pos)]) - (list (make-honu-mixin subclass-stx mixin-name $5 $9 #f (cdr $3) (car $3) $10 (cdr $11) (car $11) $13 $14 $15 $16) - (make-honu-subclass subclass-stx $2 mixin-name $7)))] - [(final subclass class-id init-args COLON type-id extends class-id at type-id imp-clause with-clause - O_CURLY fmidefns supernew fmidefns exports C_CURLY) - (let ([mixin-name (datum->syntax-object $3 (string->symbol (string-append "$" (symbol->string (syntax-e $3)))))] - [subclass-stx (create-src-stx 'honu-subclass source-name $1-start-pos $18-end-pos)]) - (list (make-honu-mixin subclass-stx mixin-name $6 $10 #t (cdr $4) (car $4) $11 (cdr $12) (car $12) $14 $15 $16 $17) - (make-honu-subclass subclass-stx $3 mixin-name $8)))]) + (list)]) + ( + [(super O_PAREN C_PAREN SEMI_COLON) + (make-honu:super-new + (create-src-stx 'honu:super-new source-name $1-start-pos $4-end-pos) + $3)]) + ( + [() + $1] + [() + (list)]) + ( + [( COMMA ) + (cons $1 $3)] + [() + (list $1)]) + ( + [(id BINDS ) + (make-honu:name-arg $1 $3)]) ;; Expressions - (block - [(O_CURLY bindings expr-sc+ C_CURLY) - (make-honu-block - (create-src-stx 'honu-block source-name $1-start-pos $4-end-pos) - (reverse $2) $3)]) - (expr-sc+ - [(expr-sc expr-sc+) - (cons $1 $2)] - [(expr-sc) - (list $1)]) - (expr-sc - [(expr SEMI_COLON) - $1] - [(return SEMI_COLON) - (make-honu-return - (create-src-stx 'honu-return source-name $1-start-pos $2-end-pos) - #f)] - [(return expr SEMI_COLON) - (make-honu-return - (create-src-stx 'honu-return source-name $1-start-pos $3-end-pos) - $2)]) - (expr - [(MINUS expr) + ( + [(O_CURLY C_CURLY) + (if $2 + $2 + (raise-read-error-with-stx + "Blocks must have at least one expression" + (create-src-stx 'honu:block source-name $1-start-pos $3-end-pos)))]) + ( + [( SEMI_COLON ) + (if $3 + (make-honu:seq + (create-src-stx 'honu:seq source-name $1-start-pos $3-end-pos) + (list $1) $3) + $1)] + [( ) + (if $2 + (make-honu:let + (create-src-stx 'honu:let source-name $1-start-pos $2-end-pos) + (list $1) $2) + (raise-read-error-with-stx + "Block must end with an expression" + (create-src-stx 'honu:block source-name $1-start-pos $1-end-pos)))] + [() + #f]) + ( + ;; unary operators + [(selector ) + (make-honu:select + (create-src-stx 'honu:select source-name $1-start-pos $2-end-pos) + (syntax-e $1) $2)] + [(MINUS ) (prec UMINUS) - (make-honu-uprim - (create-src-stx 'honu-uprim source-name $1-start-pos $2-end-pos) + (make-honu:un-op + (create-src-stx 'honu:un-op source-name $1-start-pos $2-end-pos) 'minus $1 #f $2)] - [(NOT expr) - (make-honu-uprim - (create-src-stx 'honu-uprim source-name $1-start-pos $2-end-pos) + [(NOT ) + (make-honu:un-op + (create-src-stx 'honu:un-op source-name $1-start-pos $2-end-pos) 'not $1 #f $2)] - [(expr OR expr) - (make-honu-prim - (create-src-stx 'honu-prim source-name $1-start-pos $3-end-pos) + ;; binary operators + [( OR ) + (make-honu:bin-op + (create-src-stx 'honu:bin-op source-name $1-start-pos $3-end-pos) 'or $2 #f $1 $3)] - [(expr AND expr) - (make-honu-prim - (create-src-stx 'honu-prim source-name $1-start-pos $3-end-pos) + [( AND ) + (make-honu:bin-op + (create-src-stx 'honu:bin-op source-name $1-start-pos $3-end-pos) 'and $2 #f $1 $3)] - [(expr CLS_EQ expr) - (make-honu-prim - (create-src-stx 'honu-prim source-name $1-start-pos $3-end-pos) + [( CLS_EQ ) + (make-honu:bin-op + (create-src-stx 'honu:bin-op source-name $1-start-pos $3-end-pos) 'clseq $2 #f $1 $3)] - [(expr NEQ expr) - (make-honu-prim - (create-src-stx 'honu-prim source-name $1-start-pos $3-end-pos) + [( NEQ ) + (make-honu:bin-op + (create-src-stx 'honu:bin-op source-name $1-start-pos $3-end-pos) 'neq $2 #f $1 $3)] - [(expr EQUALS expr) - (make-honu-prim - (create-src-stx 'honu-prim source-name $1-start-pos $3-end-pos) + [( EQUALS ) + (make-honu:bin-op + (create-src-stx 'honu:bin-op source-name $1-start-pos $3-end-pos) 'equal $2 #f $1 $3)] - [(expr LT expr) - (make-honu-prim - (create-src-stx 'honu-prim source-name $1-start-pos $3-end-pos) + [( LT ) + (make-honu:bin-op + (create-src-stx 'honu:bin-op source-name $1-start-pos $3-end-pos) 'lt $2 #f $1 $3)] - [(expr LE expr) - (make-honu-prim - (create-src-stx 'honu-prim source-name $1-start-pos $3-end-pos) + [( LE ) + (make-honu:bin-op + (create-src-stx 'honu:bin-op source-name $1-start-pos $3-end-pos) 'le $2 #f $1 $3)] - [(expr GT expr) - (make-honu-prim - (create-src-stx 'honu-prim source-name $1-start-pos $3-end-pos) + [( GT ) + (make-honu:bin-op + (create-src-stx 'honu:bin-op source-name $1-start-pos $3-end-pos) 'gt $2 #f $1 $3)] - [(expr GE expr) - (make-honu-prim - (create-src-stx 'honu-prim source-name $1-start-pos $3-end-pos) + [( GE ) + (make-honu:bin-op + (create-src-stx 'honu:bin-op source-name $1-start-pos $3-end-pos) 'ge $2 #f $1 $3)] - [(expr PLUS expr) - (make-honu-prim - (create-src-stx 'honu-prim source-name $1-start-pos $3-end-pos) + [( PLUS ) + (make-honu:bin-op + (create-src-stx 'honu:bin-op source-name $1-start-pos $3-end-pos) 'plus $2 #f $1 $3)] - [(expr MINUS expr) - (make-honu-prim - (create-src-stx 'honu-prim source-name $1-start-pos $3-end-pos) + [( MINUS ) + (make-honu:bin-op + (create-src-stx 'honu:bin-op source-name $1-start-pos $3-end-pos) 'minus $2 #f $1 $3)] - [(expr TIMES expr) - (make-honu-prim - (create-src-stx 'honu-prim source-name $1-start-pos $3-end-pos) + [( TIMES ) + (make-honu:bin-op + (create-src-stx 'honu:bin-op source-name $1-start-pos $3-end-pos) 'times $2 #f $1 $3)] - [(expr DIV expr) - (make-honu-prim - (create-src-stx 'honu-prim source-name $1-start-pos $3-end-pos) + [( DIV ) + (make-honu:bin-op + (create-src-stx 'honu:bin-op source-name $1-start-pos $3-end-pos) 'div $2 #f $1 $3)] - [(expr MOD expr) - (make-honu-prim - (create-src-stx 'honu-prim source-name $1-start-pos $3-end-pos) + [( MOD ) + (make-honu:bin-op + (create-src-stx 'honu:bin-op source-name $1-start-pos $3-end-pos) 'mod $2 #f $1 $3)] - [(expr DOT field-id) - (make-honu-facc - (create-src-stx 'honu-facc source-name $1-start-pos $3-end-pos) - $1 #f $3)] - [(expr DOT field-id BINDS expr) - (make-honu-fassn - (create-src-stx 'honu-fassn source-name $1-start-pos $5-end-pos) - $1 #f $3 $5)] - [(expr DOT meth-id O_PAREN exprs C_PAREN) - (make-honu-mcall - (create-src-stx 'honu-mcall source-name $1-start-pos $6-end-pos) - $1 #f $3 $5)] - [(my DOT field-id) - (make-honu-facc - (create-src-stx 'honu-facc source-name $1-start-pos $3-end-pos) - 'my #f $3)] - [(my DOT field-id BINDS expr) - (make-honu-fassn - (create-src-stx 'honu-fassn source-name $1-start-pos $5-end-pos) - 'my #f $3 $5)] - [(my DOT meth-id O_PAREN exprs C_PAREN) - (make-honu-mcall - (create-src-stx 'honu-mcall source-name $1-start-pos $6-end-pos) - 'my #f $3 $5)] - [(fun O_PAREN args C_PAREN block) - (make-honu-lambda - (create-src-stx 'honu-lambda source-name $1-start-pos $5-end-pos) - (cdr $3) (car $3) $5)] - [(null) - (make-honu-null $1)] - [(literal) + ;; member access + [( DOT id) + (make-honu:member + (create-src-stx 'honu-member source-name $1-start-pos $3-end-pos) + $1 #f $3 #f)] + [(my DOT id) + (make-honu:member + (create-src-stx 'honu:member source-name $1-start-pos $3-end-pos) + 'my #f $3 #f)] + [( fun O_PAREN C_PAREN ) + (make-honu:lambda + (create-src-stx 'honu:lambda source-name $1-start-pos $6-end-pos) + $1 $4 $6)] + [() $1] [(this) - (make-honu-this $1)] + (make-honu:this $1)] [(id) - (make-honu-var $1 $1 #f)] - [(id BINDS expr) - (make-honu-assn - (create-src-stx 'honu-assn source-name $1-start-pos $3-end-pos) + (make-honu:var $1 $1)] + [( BINDS ) + (make-honu:assn + (create-src-stx 'honu:assn source-name $1-start-pos $3-end-pos) $1 $3)] - [(id O_PAREN exprs C_PAREN) - (make-honu-call - (create-src-stx 'honu-call source-name $1-start-pos $4-end-pos) - $1 $3 #f)] - [(new class-id COLON type-id O_PAREN newargs C_PAREN) - (make-honu-new - (create-src-stx 'honu-new source-name $1-start-pos $7-end-pos) - $2 $4 (car $6) (cdr $6))] - [(new class-id O_PAREN newargs C_PAREN) - (make-honu-new - (create-src-stx 'honu-new source-name $1-start-pos $5-end-pos) - $2 #f (car $4) (cdr $4))] - [(expr COLON type-id) - (make-honu-cast - (create-src-stx 'honu-cast source-name $1-start-pos $3-end-pos) + ;; application + [( ) + (make-honu:call + (create-src-stx 'honu:call source-name $1-start-pos $2-end-pos) + $1 $2)] + [(new id COLON O_PAREN C_PAREN) + (make-honu:new + (create-src-stx 'honu:new source-name $1-start-pos $7-end-pos) + $2 $4 $6)] + [(new id O_PAREN C_PAREN) + (make-honu:new + (create-src-stx 'honu:new source-name $1-start-pos $5-end-pos) + $2 #f $4)] + [( COLON ) + (make-honu:cast + (create-src-stx 'honu:cast source-name $1-start-pos $3-end-pos) $1 $3)] - [(expr isa type-id) - (make-honu-isa - (create-src-stx 'honu-isa source-name $1-start-pos $3-end-pos) + [( isa ) + (make-honu:isa + (create-src-stx 'honu:isa source-name $1-start-pos $3-end-pos) $1 $3)] - [(if expr block else block) - (make-honu-if - (create-src-stx 'honu-if source-name $1-start-pos $5-end-pos) + [(if ) + (make-honu:if + (create-src-stx 'honu:if source-name $1-start-pos $3-end-pos) + $2 $3 #f)] + [(if else ) + (make-honu:if + (create-src-stx 'honu:if source-name $1-start-pos $5-end-pos) $2 $3 $5)] - [(while expr block) - (make-honu-while - (create-src-stx 'honu-while source-name $1-start-pos $3-end-pos) + [(cond O_CURLY C_CURLY) + (make-honu:cond + (create-src-stx 'honu:cond source-name $1-start-pos $4-end-pos) + (car $3) (cadr $3))] + [(while ) + (make-honu:while + (create-src-stx 'honu:while source-name $1-start-pos $3-end-pos) $2 $3)] - [(O_PAREN expr C_PAREN) - $2] - [(block) + [() + $1] + [(return ) + (make-honu:return + (create-src-stx 'honu:return source-name $1-start-pos $2-end-pos) + $2)] + [() $1]) - (literal + ( + [(O_PAREN C_PAREN) + (make-honu:tuple + (create-src-stx 'honu:tuple source-name $1-start-pos $2-end-pos) + (list))] + [(O_PAREN C_PAREN) + (if (null? (cdr $2)) + (car $2) + (make-honu:tuple + (create-src-stx 'honu:tuple source-name $1-start-pos $3-end-pos) + $2))]) + ( [(true) - (make-honu-bool $1 (syntax-e $1))] + (make-honu:lit $1 (make-bool-type $1) $1)] [(false) - (make-honu-bool $1 (syntax-e $1))] + (make-honu:lit $1 (make-bool-type $1) $1)] [(integer) - (make-honu-int $1 (syntax-e $1))] + (make-honu:lit $1 (make-int-type $1) $1)] [(floatnum) - (make-honu-float $1 (syntax-e $1))] + (make-honu:lit $1 (make-float-type $1) $1)] [(character) - (make-honu-char $1 (syntax-e $1))] - [(string) - (make-honu-str $1 (syntax-e $1))]) - (newargs - [(newargs-cd) - $1] - [() - (cons (list) (list))]) - (newargs-cd - [(newarg COMMA newargs-cd) - (cons (cons (car $1) (car $3)) - (cons (cdr $1) (cdr $3)))] - [(newarg) - (cons (list (car $1)) (list (cdr $1)))]) - (newarg - [(id BINDS expr) - (cons $1 $3)]) - (exprs - [(exprs-cd) - $1] - [() - '()]) - (exprs-cd - [(expr COMMA exprs-cd) + (make-honu:lit $1 (make-char-type $1) $1)] + [(string-lit) + (make-honu:lit $1 (make-string-type $1) $1)] + [(null) + (make-honu:lit $1 (make-null-type $1) (datum->syntax-object $1 'null-obj $1))]) + ( + [( THICK_ARROW SEMI_COLON ) + (list (cons (make-honu:cond-clause + (create-src-stx 'honu:cond-clause source-name $1-start-pos $4-end-pos) + $1 $3) + (car $5)) + (cadr $5))] + [( THICK_ARROW SEMI_COLON) + (list (list (make-honu:cond-clause + (create-src-stx 'honu:cond-clause source-name $1-start-pos $4-end-pos) + $1 $3)) + #f)] + [(else SEMI_COLON) + (list '() $2)]) + ( + [( COMMA ) (cons $1 $3)] - [(expr) + [() (list $1)]) - (bindings - [(bindings binding) - (cons $2 $1)] - [() - '()]) - (binding - [(any-type id BINDS expr SEMI_COLON) - (make-honu-binding - (create-src-stx 'honu-binding source-name $1-start-pos $5-end-pos) - $2 $1 $4)]) - (interact - [(binding) + ( + [( BINDS SEMI_COLON) + (make-honu:binding + (create-src-stx 'honu:binding source-name $1-start-pos $4-end-pos) + (list (honu:formal-name $1)) (list (honu:formal-type $1)) $3)] + [(O_PAREN C_PAREN BINDS SEMI_COLON) + (let-values ([(names types) (map-two-values (lambda (f) + (values (honu:formal-name f) + (honu:formal-type f))) + $2)]) + (make-honu:binding + (create-src-stx 'honu:binding source-name $1-start-pos $6-end-pos) + names types $5))]) + ( + [() $1] - [(expr) + [() $1])))) honu-parser) @@ -794,35 +671,31 @@ (define (parse-group port name) (let ([filenames (read-cm port)]) (if (null? filenames) - (make-honu-program '()) + (list) (let loop ((filenames filenames) (defns '())) (let ((parsed (parse-file (simplify-path (path->complete-path (car filenames)))))) (if (null? (cdr filenames)) - (make-honu-program - (append (honu-program-defns parsed) defns)) + (append parsed defns) (loop (cdr filenames) - (append (honu-program-defns parsed) defns)))))))) + (append parsed defns)))))))) (define (parse-group-file dirname filename) (let ([filenames (call-with-input-file (string-append dirname "/" filename) read-cm)]) (if (null? filenames) - (make-honu-program '()) + (list) (let loop ((filenames filenames) (defns '())) (let ((parsed (parse-file (string-append dirname "/" (car filenames))))) (if (null? (cdr filenames)) - (make-honu-program - (append (honu-program-defns parsed) defns)) + (append parsed defns) (loop (cdr filenames) - (append (honu-program-defns parsed) defns)))))))) + (append parsed defns)))))))) (provide parse-file parse-port parse-stdin parse-string parse-group parse-group-file parse-interaction) - ) - diff --git a/collects/honu/parsers/post-parsing.ss b/collects/honu/parsers/post-parsing.ss new file mode 100644 index 0000000000..1cdf2eb92a --- /dev/null +++ b/collects/honu/parsers/post-parsing.ss @@ -0,0 +1,852 @@ +(module post-parsing mzscheme + + (require (lib "list.ss" "srfi" "1") + (lib "plt-match.ss") + (lib "struct.ss") + "../ast.ss" + "../readerr.ss" + "../tenv.ss" + "../utils.ss") + + ;;;; Here are descriptions of what each of the three functions herein do: + ;;;; + ;;;; convert-static : converts bareword references to static slots/fields/methods + ;;;; into my. + ;;;; convert-slots : converts init slots that are used in methods or exports into + ;;;; init fields instead. Since everything is exported from a struct, + ;;;; all init slots are converted in those. + ;;;; check-this : checks to make sure that all uses of this that are not before a dot + ;;;; are on the LHS of a cast or isa expression. Else an error is thrown. + ;;;; (also until we resolve the mixin safety issue, uses of this before a + ;;;; dot are wrapped in a cast to the class's/mixin's selftype). + ;;;; We also go ahead and implement the check that this is only used inside + ;;;; a class or mixin form. + ;;;; simplify-ast : converts lets inside lets or seqs inside seqs into a single let or seq. + ;;;; since the current parser generates a new let or seq for every binding + ;;;; or expression inside of a block, this merges them. + + ;;;; convert-static MUST be run before convert-slots. + + (provide post-parse-program post-parse-interaction) + (define (post-parse-program tenv defns) + (convert-slots (convert-static tenv (check-this (simplify-ast defns))))) + + (define (post-parse-interaction tenv ast) + (cond + [(honu:expr? ast) + (convert-static-expression (check-this-expression (simplify-expression ast) #f) '())] + [(honu:bind-top? ast) + (convert-static-defn tenv (check-this-defn (simplify-defn ast)))])) + +; +; +; @ +; @ @ @ +; $@+@ $@$ @@:@@: @@@ @@@ -@@$ @@-$+ @@@@@ :@@+@ @@@@@ $@$: @@@@@ -@@ $@+@ +; $+ -@ $- -$ @+ :@ $ $ $ -$ @$ : @ @$ -@ @ -@ @ @ $+ -@ +; @ @ @ @ @ +: ++ @@@@@ @ @ @@@@@ :@@$- @ -$@$@ @ @ @ +; @ @ @ @ @ $ $ $ @ @ *@ @ $* @ @ @ @ +; $* -$ $- -$ @ @ $:+ +: @ @: :$ @ :@ @: :$ @- *@ @: :$ @ $* -$ +; $@$- $@$ @@@ @@@ :@ $@@+ @@@@@ :@@$- $+@@: :@@$- -$$-@@ :@@$- @@@@@ $@$- +; +; +; +; + + (define (convert-static tenv defns) + (map (lambda (d) (convert-static-defn tenv d)) defns)) + + (define (convert-static-defn tenv defn) + (match defn + [(struct honu:iface (_ _ _ _)) + defn] + [(struct honu:class (_ _ _ _ _ inits members _)) + (let-values ([(members _) + (map-and-fold convert-static-member (map honu:formal-name inits) members)]) + (copy-struct honu:class defn + [honu:class-members members]))] + [(struct honu:mixin (_ _ _ arg-type _ _ inits _ super-new members-before members-after _)) + (let*-values ([(members-before env) + (map-and-fold convert-static-member (map honu:formal-name inits) members-before)] + [(super-new) + (convert-static-super-new super-new env)] + [(env) + (extend-env-with-type-members tenv env arg-type)] + [(members-after _) + (map-and-fold convert-static-member env members-after)]) + (copy-struct honu:mixin defn + [honu:mixin-super-new super-new] + [honu:mixin-members-before members-before] + [honu:mixin-members-after members-after]))] + [(struct honu:subclass (_ _ _ _)) + defn] + [(struct honu:struct (_ _ _ _ _ inits members _)) + (let-values ([(members _) + (map-and-fold convert-static-member (map honu:formal-name inits) members)]) + (copy-struct honu:struct defn + [honu:struct-members members]))] + [(struct honu:substruct (_ _ _ _ arg-type _ _ inits _ super-new members-before members-after _)) + (let*-values ([(members-before env) + (map-and-fold convert-static-member (map honu:formal-name inits) members-before)] + [(super-new) + (convert-static-super-new super-new env)] + [(env) + (extend-env-with-type-members tenv env arg-type)] + [(members-after _) + (map-and-fold convert-static-member env members-after)]) + (copy-struct honu:substruct defn + [honu:substruct-super-new super-new] + [honu:substruct-members-before members-before] + [honu:substruct-members-after members-after]))] + [(struct honu:function (_ _ _ _ _)) + defn] + [(struct honu:bind-top (_ _ _ _)) + defn])) + + (define (extend-env-with-type-members tenv env type) + (let ([type-entry (get-type-entry tenv type)]) + (fold (lambda (m e) + (cons (tenv:member-name m) e)) + env + (tenv:type-members type-entry)))) + + (define (convert-static-member member env) + (match member + [(struct honu:init-field (_ name _ value)) + (if value + (values + (copy-struct honu:init-field member + [honu:init-field-value (convert-static-expression value env)]) + (cons name env)) + (values member (cons name env)))] + [(struct honu:field (_ name _ value)) + (values + (copy-struct honu:field member + [honu:field-value (convert-static-expression value env)]) + (cons name env))] + [(struct honu:method (_ name _ args body)) + (values + ;; remember to remove lexical bindings! + (let ([env (fold (lambda (name env) + (delete name env bound-identifier=?)) + env (map honu:formal-name args))]) + (copy-struct honu:method member + [honu:method-body (convert-static-expression body env)])) + (cons name env))])) + + (define (convert-static-super-new snew env) + (match snew + [(struct honu:super-new (_ args)) + (copy-struct honu:super-new snew + [honu:super-new-args (map (lambda (a) + (convert-static-name-arg a env)) + args)])])) + + (define (convert-static-name-arg arg env) + (match arg + [(struct honu:name-arg (_ value)) + (copy-struct honu:name-arg arg + [honu:name-arg-value (convert-static-expression value env)])])) + + (define (convert-static-expression expr env) + (match expr + [(struct honu:this (_)) + expr] + [(struct honu:select (_ _ arg)) + (copy-struct honu:select expr + [honu:select-arg (convert-static-expression arg env)])] + [(struct honu:var (stx name)) + (if (s:member name env bound-identifier=?) + (make-honu:member stx 'my #f name #f) + expr)] + [(struct honu:assn (_ lhs rhs)) + (copy-struct honu:assn expr + [honu:assn-lhs (convert-static-expression lhs env)] + [honu:assn-rhs (convert-static-expression rhs env)])] + [(struct honu:call (_ func arg)) + (copy-struct honu:call expr + [honu:call-func (convert-static-expression func env)] + [honu:call-arg (convert-static-expression arg env)])] + [(struct honu:lit (_ _ _)) + expr] + [(struct honu:un-op (_ _ _ _ arg)) + (copy-struct honu:un-op expr + [honu:un-op-arg (convert-static-expression arg env)])] + [(struct honu:bin-op (_ _ _ _ larg rarg)) + (copy-struct honu:bin-op expr + [honu:bin-op-larg (convert-static-expression larg env)] + [honu:bin-op-rarg (convert-static-expression rarg env)])] + ;; originally forgot to remove the identifiers bound by + ;; the lambda from the environment + [(struct honu:lambda (_ _ args body)) + (let ([env (fold (lambda (name env) + (delete name env bound-identifier=?)) + env (map honu:formal-name args))]) + (copy-struct honu:lambda expr + [honu:lambda-body (convert-static-expression body env)]))] + [(struct honu:if (_ cond then else)) + (copy-struct honu:if expr + [honu:if-cond (convert-static-expression cond env)] + [honu:if-then (convert-static-expression then env)] + [honu:if-else (if else (convert-static-expression else env) #f)])] + [(struct honu:cast (_ obj _)) + (copy-struct honu:cast expr + [honu:cast-obj (convert-static-expression obj env)])] + [(struct honu:isa (_ obj _)) + (copy-struct honu:isa expr + [honu:isa-obj (convert-static-expression obj env)])] + [(struct honu:member (_ 'my _ _ _)) + expr] + [(struct honu:member (_ obj _ _ _)) + (copy-struct honu:member expr + [honu:member-obj (convert-static-expression obj env)])] + [(struct honu:new (_ _ _ args)) + (copy-struct honu:new expr + [honu:new-args (map (lambda (a) + (convert-static-name-arg a env)) + args)])] + [(struct honu:while (_ cond body)) + (copy-struct honu:while expr + [honu:while-cond (convert-static-expression cond env)] + [honu:while-body (convert-static-expression body env)])] + [(struct honu:cond (_ clauses else)) + (copy-struct honu:cond expr + [honu:cond-clauses (map (lambda (c) + (convert-static-cond-clause c env) + clauses))] + [honu:cond-else (if else (convert-static-expression else env) #f)])] + [(struct honu:return (_ body)) + (copy-struct honu:return expr + [honu:return-body (convert-static-expression body env)])] + [(struct honu:tuple (_ vals)) + (copy-struct honu:tuple expr + [honu:tuple-vals (map (lambda (e) + (convert-static-expression e env)) + vals)])] + [(struct honu:let (_ bindings body)) + (let*-values ([(bindings env) (map-and-fold convert-static-binding env bindings)] + [(body) (convert-static-expression body env)]) + (copy-struct honu:let expr + [honu:let-bindings bindings] + [honu:let-body body]))] + [(struct honu:seq (_ effects value)) + (let ([effects (map (lambda (e) + (convert-static-expression e env)) + effects)] + [value (convert-static-expression value env)]) + (copy-struct honu:seq expr + [honu:seq-effects effects] + [honu:seq-value value]))])) + + (define (convert-static-binding binding env) + (match binding + [(struct honu:binding (_ names _ value)) + (values + (copy-struct honu:binding binding + [honu:binding-value (convert-static-expression value env)]) + (fold (lambda (name env) + (delete name env bound-identifier=?)) + env names))])) + + (define (convert-static-cond-clause clause env) + (match clause + [(struct honu:cond-clause (_ pred rhs)) + (copy-struct honu:cond-clause clause + [honu:cond-clause-pred (convert-static-expression pred env)] + [honu:cond-clause-rhs (convert-static-expression rhs env)])])) + + +; +; +; @@ +; @ @ @ +; $@+@ $@$ @@:@@: @@@ @@@ -@@$ @@-$+ @@@@@ :@@+@ @ $@$ @@@@@ :@@+@ +; $+ -@ $- -$ @+ :@ $ $ $ -$ @$ : @ @$ -@ @ $- -$ @ @$ -@ +; @ @ @ @ @ +: ++ @@@@@ @ @ @@@@@ :@@$- @ @ @ @ :@@$- +; @ @ @ @ @ $ $ $ @ @ *@ @ @ @ @ *@ +; $* -$ $- -$ @ @ $:+ +: @ @: :$ @ :@ @ $- -$ @: :$ @ :@ +; $@$- $@$ @@@ @@@ :@ $@@+ @@@@@ :@@$- $+@@: @@@@@ $@$ :@@$- $+@@: +; +; +; +; + + ;; CONVERT-SLOTS ASSUMES THAT CONVERT-STATIC HAS BEEN RUN FIRST, SO THAT WE DON'T HAVE TO WORRY + ;; ABOUT SLOT NAMES BEING CAPTURED BY LEXICAL BINDINGS (AS ALL SLOT ACCESSES SHOULD HAVE BEEN + ;; CONVERTED TO MY.) + + (define (convert-slots defns) + (map convert-slots-defn defns)) + + (define (convert-slots-defn defn) + (match defn + [(struct honu:iface (_ _ _ _)) + defn] + [(struct honu:class (_ _ _ _ _ inits members exports)) + (let* ([env (map honu:formal-name inits)] + [used-slots-members (apply append (map (lambda (m) (convert-slots-member m env)) members))] + [used-slots-exports (apply append (map (lambda (e) (convert-slots-export e env)) exports))] + [used-slots (append used-slots-members used-slots-exports)]) + (let loop ([inits inits] + [kept-inits '()] + [new-fields '()]) + (if (null? inits) + (copy-struct honu:class defn + [honu:class-inits (reverse kept-inits)] + [honu:class-members (append (reverse new-fields) members)]) + (if (s:member (honu:formal-name (car inits)) used-slots bound-identifier=?) + (loop (cdr inits) + kept-inits + (cons (make-honu:init-field (honu:ast-stx (car inits)) + (honu:formal-name (car inits)) + (honu:formal-type (car inits)) + #f) + new-fields)) + (loop (cdr inits) + (cons (car inits) kept-inits) + new-fields)))))] + [(struct honu:mixin (_ _ _ _ _ _ inits _ _ members-before members-after exports)) + (let* ([env (map honu:formal-name inits)] + [used-slots-before (apply append (map (lambda (m) (convert-slots-member m env)) members-before))] + [used-slots-after (apply append (map (lambda (m) (convert-slots-member m env)) members-after))] + [used-slots-exports (apply append (map (lambda (e) (convert-slots-export e env)) exports))] + [used-slots (append used-slots-before used-slots-after used-slots-exports)]) + (let loop ([inits inits] + [kept-inits '()] + [new-fields '()]) + (if (null? inits) + (copy-struct honu:mixin defn + [honu:mixin-inits (reverse kept-inits)] + [honu:mixin-members-before (append (reverse new-fields) members-before)]) + (if (s:member (honu:formal-name (car inits)) used-slots bound-identifier=?) + (loop (cdr inits) + kept-inits + (cons (make-honu:init-field (honu:ast-stx (car inits)) + (honu:formal-name (car inits)) + (honu:formal-type (car inits)) + #f) + new-fields)) + (loop (cdr inits) + (cons (car inits) kept-inits) + new-fields)))))] + [(struct honu:subclass (_ _ _ _)) + defn] + [(struct honu:struct (_ _ _ _ _ inits members _)) + (copy-struct honu:struct defn + [honu:struct-inits '()] + [honu:struct-members (append (map (lambda (i) + (make-honu:init-field (honu:ast-stx i) + (honu:formal-name i) + (honu:formal-type i) + #f)) + inits) + members)])] + [(struct honu:substruct (_ _ _ _ _ _ _ inits _ _ members-before _ _)) + (copy-struct honu:substruct defn + [honu:substruct-inits '()] + [honu:substruct-members-before (append (map (lambda (i) + (make-honu:init-field (honu:ast-stx i) + (honu:formal-name i) + (honu:formal-type i) + #f)) + inits) + members-before)])] + [(struct honu:function (_ _ _ _ _)) + defn] + [(struct honu:bind-top (_ _ _ _)) + defn])) + + (define (convert-slots-member member env) + (match member + ;; init fields and fields do not necessitate converting init slots into init fields + [(struct honu:init-field (_ name _ value)) + (list)] + [(struct honu:field (_ name _ value)) + (list)] + ;; methods do, though. + [(struct honu:method (_ name _ _ body)) + (convert-slots-expression body env)])) + + (define (convert-slots-export export env) + (match export + [(struct honu:export (_ _ binds)) + (filter (lambda (old) + (s:member old env bound-identifier=?)) + (map honu:exp-bind-old binds))])) + + (define (convert-slots-name-arg arg env) + (match arg + [(struct honu:name-arg (_ value)) + (convert-slots-expression value env)])) + + (define (convert-slots-expression expr env) + (match expr + [(struct honu:this (_)) + (list)] + [(struct honu:select (_ _ arg)) + (convert-slots-expression arg env)] + [(struct honu:var (_ _)) + (list)] + [(struct honu:assn (_ lhs rhs)) + (append (convert-slots-expression lhs env) + (convert-slots-expression rhs env))] + [(struct honu:call (_ func arg)) + (append (convert-slots-expression func env) + (convert-slots-expression arg env))] + [(struct honu:lit (_ _ _)) + (list)] + [(struct honu:un-op (_ _ _ _ arg)) + (convert-slots-expression arg env)] + [(struct honu:bin-op (_ _ _ _ larg rarg)) + (append (convert-slots-expression larg env) + (convert-slots-expression rarg env))] + [(struct honu:lambda (_ _ _ body)) + (convert-slots-expression body env)] + [(struct honu:if (_ cond then else)) + (append (convert-slots-expression cond env) + (convert-slots-expression then env) + (if else (convert-slots-expression else env) (list)))] + [(struct honu:cast (_ obj _)) + (convert-slots-expression obj env)] + [(struct honu:isa (_ obj _)) + (convert-slots-expression obj env)] + [(struct honu:member (_ 'my _ name _)) + (cond + ;; if this is a (bare-referenced) init slot, + ;; then we return a "set" of it, else we return + ;; an empty "set" + [(s:member name env bound-identifier=?) + => + (lambda (l) (list (car l)))] + [else (list)])] + [(struct honu:member (_ obj _ _ _)) + (convert-slots-expression obj env)] + [(struct honu:new (_ _ _ args)) + (apply append + (map (lambda (a) + (convert-slots-name-arg a env)) + args))] + [(struct honu:while (_ cond body)) + (append (convert-slots-expression cond env) + (convert-slots-expression body env))] + [(struct honu:cond (_ clauses else)) + (apply append (cons (if else (convert-slots-expression else env) (list)) + (map (lambda (c) + (convert-slots-cond-clause c env) + clauses))))] + [(struct honu:return (_ body)) + (convert-slots-expression body env)] + [(struct honu:tuple (_ vals)) + (apply append + (map (lambda (e) + (convert-slots-expression e env)) + vals))] + [(struct honu:let (_ bindings body)) + (let ([bindings (map (lambda (b) + (convert-slots-binding b env)) + bindings)] + [body (convert-slots-expression body env)]) + (apply append (cons body bindings)))] + [(struct honu:seq (_ effects value)) + (apply append (cons (convert-slots-expression value env) + (map (lambda (e) + (convert-slots-expression e env)) + effects)))])) + + (define (convert-slots-binding binding env) + (match binding + [(struct honu:binding (_ _ _ value)) + (convert-slots-expression value env)])) + + (define (convert-slots-cond-clause clause env) + (match clause + [(struct honu:cond-clause (_ pred rhs)) + (append (convert-slots-expression pred env) + (convert-slots-expression rhs env))])) + + +; +; +; @@ @@ @@ @ +; @ @ @ @ +; $@+@ @-@@: -@@$ $@+@ @ @@@ @@@@@ @-@@: -@@ :@@+@ +; $+ -@ @+ :@ $ -$ $+ -@ @ *$ @ @+ :@ @ @$ -@ +; @ @ @ @@@@@ @ @$$ @@@@@ @ @ @ @ :@@$- +; @ @ @ $ @ @$$ @ @ @ @ *@ +; $* -$ @ @ +: $* -$ @ -$ @: :$ @ @ @ @ :@ +; $@$- @@@ @@@ $@@+ $@$- @@ @@@- :@@$-@@@ @@@ @@@@@ $+@@: +; +; +; +; + + (define (check-this defns) + (map check-this-defn defns)) + + (define (check-this-defn defn) + (match defn + [(struct honu:iface (_ _ _ _)) + defn] + [(struct honu:class (_ _ type _ _ _ members _)) + (let ([members (map (lambda (m) (check-this-member m type)) members)]) + (copy-struct honu:class defn + [honu:class-members members]))] + [(struct honu:mixin (_ _ type _ _ _ _ _ super-new members-before members-after _)) + (let ([members-before (map (lambda (m) (check-this-member m type)) members-before)] + [super-new (check-this-super-new super-new type)] + [members-after (map (lambda (m) (check-this-member m type)) members-after)]) + (copy-struct honu:mixin defn + [honu:mixin-super-new super-new] + [honu:mixin-members-before members-before] + [honu:mixin-members-after members-after]))] + [(struct honu:subclass (_ _ _ _)) + defn] + [(struct honu:struct (_ _ type _ _ _ members _)) + (let ([members (map (lambda (m) (check-this-member m type)) members)]) + (copy-struct honu:struct defn + [honu:struct-members members]))] + [(struct honu:substruct (_ _ type _ _ _ _ _ _ super-new members-before members-after _)) + (let ([members-before (map (lambda (m) (check-this-member m type)) members-before)] + [super-new (check-this-super-new super-new type)] + [members-after (map (lambda (m) (check-this-member m type)) members-after)]) + (copy-struct honu:substruct defn + [honu:substruct-super-new super-new] + [honu:substruct-members-before members-before] + [honu:substruct-members-after members-after]))] + [(struct honu:function (_ _ _ _ body)) + ;; we only use check-this-expression here for side-effects (we should not get + ;; a changed AST if this passes, only an exception if the this keyword occurs here). + (begin + (check-this-expression body #f) + defn)] + [(struct honu:bind-top (_ _ _ rhs)) + ;; same check as in honu:function. + (begin + (check-this-expression rhs #f) + defn)])) + + (define (check-this-member member type) + (match member + [(struct honu:init-field (_ name _ value)) + (if value + (copy-struct honu:init-field member + [honu:init-field-value (check-this-expression value type)]) + member)] + [(struct honu:field (_ name _ value)) + (copy-struct honu:field member + [honu:field-value (check-this-expression value type)])] + [(struct honu:method (_ name _ args body)) + (copy-struct honu:method member + [honu:method-body (check-this-expression body type)])])) + + (define (check-this-super-new snew type) + (match snew + [(struct honu:super-new (_ args)) + (copy-struct honu:super-new snew + [honu:super-new-args (map (lambda (a) + (check-this-name-arg a type)) + args)])])) + + (define (check-this-name-arg arg type) + (match arg + [(struct honu:name-arg (_ value)) + (copy-struct honu:name-arg arg + [honu:name-arg-value (check-this-expression value type)])])) + + (define (check-this-expression expr type) + (match expr + [(struct honu:this (stx)) + (if type + (raise-read-error-with-stx + "Unprotected use of this in a client context" + stx) + (raise-read-error-with-stx + "Use of this keyword found outside of a class or mixin" + stx))] + [(struct honu:select (_ _ arg)) + (copy-struct honu:select expr + [honu:select-arg (check-this-expression arg type)])] + [(struct honu:var (_ _)) + expr] + [(struct honu:assn (_ lhs rhs)) + (copy-struct honu:assn expr + [honu:assn-lhs (check-this-expression lhs type)] + [honu:assn-rhs (check-this-expression rhs type)])] + [(struct honu:call (_ func arg)) + (copy-struct honu:call expr + [honu:call-func (check-this-expression func type)] + [honu:call-arg (check-this-expression arg type)])] + [(struct honu:lit (_ _ _)) + expr] + [(struct honu:un-op (_ _ _ _ arg)) + (copy-struct honu:un-op expr + [honu:un-op-arg (check-this-expression arg type)])] + [(struct honu:bin-op (_ _ _ _ larg rarg)) + (copy-struct honu:bin-op expr + [honu:bin-op-larg (check-this-expression larg type)] + [honu:bin-op-rarg (check-this-expression rarg type)])] + [(struct honu:lambda (_ _ _ body)) + (copy-struct honu:lambda expr + [honu:lambda-body (check-this-expression body type)])] + [(struct honu:if (_ cond then else)) + (copy-struct honu:if expr + [honu:if-cond (check-this-expression cond type)] + [honu:if-then (check-this-expression then type)] + [honu:if-else (if else (check-this-expression else type) #f)])] + [(struct honu:cast (_ obj _)) + (if (honu:this? obj) + (if type + expr + (raise-read-error-with-stx + "Use of this keyword found outside of a class or mixin" + (honu:ast-stx obj))) + (copy-struct honu:cast expr + [honu:cast-obj (check-this-expression obj type)]))] + [(struct honu:isa (_ obj _)) + (if (honu:this? obj) + (if type + expr + (raise-read-error-with-stx + "Use of this keyword found outside of a class or mixin" + (honu:ast-stx obj))) + (copy-struct honu:isa expr + [honu:isa-obj (check-this-expression obj type)]))] + [(struct honu:member (_ 'my _ _ _)) + expr] + [(struct honu:member (_ obj _ _ _)) + (if (honu:this? obj) + (if type + ;; to deal with the fact that mixins can mess up the selftype + ;; property, we hack by creating casts in this case. + (copy-struct honu:member expr + [honu:member-obj (make-honu:cast (honu:ast-stx obj) + obj + type)]) + (raise-read-error-with-stx + "Use of this keyword found outside of a class or mixin" + (honu:ast-stx obj))) + (copy-struct honu:member expr + [honu:member-obj (check-this-expression obj type)]))] + [(struct honu:new (_ _ _ args)) + (copy-struct honu:new expr + [honu:new-args (map (lambda (a) + (check-this-name-arg a type)) + args)])] + [(struct honu:while (_ cond body)) + (copy-struct honu:while expr + [honu:while-cond (check-this-expression cond type)] + [honu:while-body (check-this-expression body type)])] + [(struct honu:cond (_ clauses else)) + (copy-struct honu:cond expr + [honu:cond-clauses (map (lambda (c) + (check-this-cond-clause c type) + clauses))] + [honu:cond-else (if else (check-this-expression else type) #f)])] + [(struct honu:return (_ body)) + (copy-struct honu:return expr + [honu:return-body (check-this-expression body type)])] + [(struct honu:tuple (_ vals)) + (copy-struct honu:tuple expr + [honu:tuple-vals (map (lambda (e) + (check-this-expression e type)) + vals)])] + [(struct honu:let (_ bindings body)) + (let ([bindings (map (lambda (b) + (check-this-binding b type)) + bindings)] + [body (check-this-expression body type)]) + (copy-struct honu:let expr + [honu:let-bindings bindings] + [honu:let-body body]))] + [(struct honu:seq (_ effects value)) + (let ([effects (map (lambda (e) + (check-this-expression e type)) + effects)] + [value (check-this-expression value type)]) + (copy-struct honu:seq expr + [honu:seq-effects effects] + [honu:seq-value value]))])) + + (define (check-this-binding binding type) + (match binding + [(struct honu:binding (_ names _ value)) + (copy-struct honu:binding binding + [honu:binding-value (check-this-expression value type)])])) + + (define (check-this-cond-clause clause type) + (match clause + [(struct honu:cond-clause (_ pred rhs)) + (copy-struct honu:cond-clause clause + [honu:cond-clause-pred (check-this-expression pred type)] + [honu:cond-clause-rhs (check-this-expression rhs type)])])) + + +; +; +; @ @@ @ :@@$ +; @ @: @ +; :@@+@ -@@ @@+-$: @@:@$- @ -@@ @@@@@ @@@ @@@ $@$: :@@+@ @@@@@ +; @$ -@ @ @+@$@ @: -$ @ @ @ $- $- -@ @$ -@ @ +; :@@$- @ @ @ @ @ @ @ @ @ -$ $ @@@@@ -$@$@ :@@$- @ +; *@ @ @ @ @ @ @ @ @ @ $*$: $* @ *@ @ +; @ :@ @ @ @ @ @: -$ @ @ @ $$ @- *@ @ :@ @: :$ +; $+@@: @@@@@ @@@@@@@ @-@$ @@@@@ @@@@@ @@@@@ $* -$$-@@ $+@@: :@@$- +; @ $ +; @@@ @@@@ +; +; + + (define (simplify-ast defns) + (map simplify-defn defns)) + + (define (simplify-defn defn) + (match defn + [(struct honu:iface (_ _ _ _)) + defn] + [(struct honu:class (_ _ _ _ _ _ members _)) + (copy-struct honu:class defn + [honu:class-members (map simplify-member members)])] + [(struct honu:mixin (_ _ _ _ _ _ _ _ super-new members-before members-after _)) + (copy-struct honu:mixin defn + [honu:mixin-super-new (simplify-super-new super-new)] + [honu:mixin-members-before (map simplify-member members-before)] + [honu:mixin-members-after (map simplify-member members-after)])] + [(struct honu:subclass (_ _ _ _)) + defn] + [(struct honu:struct (_ _ _ _ _ _ members _)) + (copy-struct honu:struct defn + [honu:struct-members (map simplify-member members)])] + [(struct honu:substruct (_ _ _ _ _ _ _ _ _ super-new members-before members-after _)) + (copy-struct honu:substruct defn + [honu:substruct-super-new (simplify-super-new super-new)] + [honu:substruct-members-before (map simplify-member members-before)] + [honu:substruct-members-after (map simplify-member members-after)])] + [(struct honu:function (_ _ _ _ body)) + (copy-struct honu:function defn + [honu:function-body (simplify-expression body)])] + [(struct honu:bind-top (_ _ _ value)) + (copy-struct honu:bind-top defn + [honu:bind-top-value (simplify-expression value)])])) + + (define (simplify-member member) + (match member + [(struct honu:init-field (_ _ _ value)) + (if value + (copy-struct honu:init-field member + [honu:init-field-value (simplify-expression value)]) + member)] + [(struct honu:field (_ _ _ value)) + (copy-struct honu:field member + [honu:field-value (simplify-expression value)])] + [(struct honu:method (_ _ _ _ body)) + (copy-struct honu:method member + [honu:method-body (simplify-expression body)])])) + + (define (simplify-super-new snew) + (match snew + [(struct honu:super-new (_ args)) + (copy-struct honu:super-new snew + [honu:super-new-args (map simplify-name-arg args)])])) + + (define (simplify-name-arg arg) + (match arg + [(struct honu:name-arg (_ value)) + (copy-struct honu:name-arg arg + [honu:name-arg-value (simplify-expression value)])])) + + (define (simplify-expression expr) + (match expr + [(struct honu:this (_)) + expr] + [(struct honu:select (_ _ arg)) + (copy-struct honu:select expr + [honu:select-arg (simplify-expression arg)])] + [(struct honu:var (_ _)) + expr] + [(struct honu:assn (_ lhs rhs)) + (copy-struct honu:assn expr + [honu:assn-lhs (simplify-expression lhs)] + [honu:assn-rhs (simplify-expression rhs)])] + [(struct honu:call (_ func arg)) + (copy-struct honu:call expr + [honu:call-func (simplify-expression func)] + [honu:call-arg (simplify-expression arg)])] + [(struct honu:lit (_ _ _)) + expr] + [(struct honu:un-op (_ _ _ _ arg)) + (copy-struct honu:un-op expr + [honu:un-op-arg (simplify-expression arg)])] + [(struct honu:bin-op (_ _ _ _ larg rarg)) + (copy-struct honu:bin-op expr + [honu:bin-op-larg (simplify-expression larg)] + [honu:bin-op-rarg (simplify-expression rarg)])] + [(struct honu:lambda (_ _ _ body)) + (copy-struct honu:lambda expr + [honu:lambda-body (simplify-expression body)])] + [(struct honu:if (_ cond then else)) + (copy-struct honu:if expr + [honu:if-cond (simplify-expression cond)] + [honu:if-then (simplify-expression then)] + [honu:if-else (if else (simplify-expression else) #f)])] + [(struct honu:cast (_ obj _)) + (copy-struct honu:cast expr + [honu:cast-obj (simplify-expression obj)])] + [(struct honu:isa (_ obj _)) + (copy-struct honu:isa expr + [honu:isa-obj (simplify-expression obj)])] + [(struct honu:member (_ 'my _ _ _)) + expr] + [(struct honu:member (_ obj _ _ _)) + (copy-struct honu:member expr + [honu:member-obj (simplify-expression obj)])] + [(struct honu:new (_ _ _ args)) + (copy-struct honu:new expr + [honu:new-args (map simplify-name-arg args)])] + [(struct honu:cond (_ clauses else)) + (copy-struct honu:cond expr + [honu:cond-clauses (map simplify-cond-clause clauses)] + [honu:cond-else (if else (simplify-expression else) #f)])] + [(struct honu:while (_ cond body)) + (copy-struct honu:while expr + [honu:while-cond (simplify-expression cond)] + [honu:while-body (simplify-expression body)])] + [(struct honu:return (_ body)) + (copy-struct honu:return expr + [honu:return-body (simplify-expression body)])] + [(struct honu:tuple (_ vals)) + (copy-struct honu:tuple expr + [honu:tuple-vals (map simplify-expression vals)])] + [(struct honu:let (stx bindings body)) + (let ([bindings (map simplify-binding bindings)] + [body (simplify-expression body)]) + (match body + [(struct honu:let (_ sub-bindings sub-body)) + (make-honu:let stx (append bindings sub-bindings) sub-body)] + [_ + (copy-struct honu:let expr + [honu:let-bindings bindings] + [honu:let-body body])]))] + [(struct honu:seq (stx effects value)) + (let ([effects (map simplify-expression effects)] + [value (simplify-expression value)]) + (match value + [(struct honu:seq (_ sub-effects sub-value)) + (make-honu:seq stx (append effects sub-effects) sub-value)] + [_ + (copy-struct honu:seq expr + [honu:seq-effects effects] + [honu:seq-value value])]))])) + + (define (simplify-binding binding) + (match binding + [(struct honu:binding (_ _ _ value)) + (copy-struct honu:binding binding + [honu:binding-value (simplify-expression value)])])) + + (define (simplify-cond-clause clause) + (match clause + [(struct honu:cond-clause (_ pred rhs)) + (copy-struct honu:cond-clause clause + [honu:cond-clause-pred (simplify-expression pred)] + [honu:cond-clause-rhs (simplify-expression rhs)])])) + ) diff --git a/collects/honu/private/compiler/honu-translate-class-utils.ss b/collects/honu/private/compiler/honu-translate-class-utils.ss deleted file mode 100644 index a17ec7a1d1..0000000000 --- a/collects/honu/private/compiler/honu-translate-class-utils.ss +++ /dev/null @@ -1,178 +0,0 @@ -(module honu-translate-class-utils mzscheme - - (require (lib "list.ss" "srfi" "1") - (prefix list: (lib "list.ss")) - (lib "plt-match.ss")) - - (require "../../ast.ss") - (require "../../tenv.ss") - (require "../typechecker/honu-type-utils.ss") - (require "honu-translate-utils.ss") - (require "honu-translate-expression.ss") - - (provide honu-translate-init-slots) - (define (honu-translate-init-slots slot-names) - (map (lambda (name) - (at name `(init ,(at-ctxt name)))) - slot-names)) - - (provide honu-translate-slotdefns) - (define (honu-translate-slotdefns tenv outer-defn defns) - (map (match-lambda - [(struct honu-init-field (stx name type value)) - (if value - (at stx `(begin - (init ([,(add-init name) ,(at-ctxt name)] - ,(honu-translate-expression tenv outer-defn value))) - (define ,(at-ctxt name) ,(add-init name)))) - (at stx `(begin - (init ([,(add-init name) ,(at-ctxt name)])) - (define ,(at-ctxt name) ,(add-init name)))))] - [(struct honu-field (stx name type value)) - (at stx `(define ,(at-ctxt name) - ,(honu-translate-expression tenv outer-defn value)))] - [(struct honu-method (stx name type arg-names arg-types body)) - (if (honu-top-type? type) - (at stx `(define (,(at-ctxt name) ,@arg-names) - ,(honu-translate-expression tenv outer-defn body) - (void))) - (at stx `(define (,(at-ctxt name) ,@arg-names) - ,(honu-translate-expression tenv outer-defn body))))]) - defns)) - - (define (add-init sym) - (at sym - (string->symbol - (string-append "init-" (symbol->string (printable-key sym)))))) - - (define-struct pexp (new-name new-type old-name old-type method?)) - - (provide honu-translate-exports) - (define (honu-translate-exports tenv defn prior-impls exports) - (let* ((processed-exports (apply append (map (lambda (e) - (process-export tenv defn e)) - exports))) - (filtered-exports (filter-exports processed-exports))) - (map (lambda (pexp) - (generate-export tenv prior-impls pexp)) - filtered-exports))) - - (define (check-prior-impls tenv prior-impls typ) - (ormap (lambda (t) - (<:_P tenv t typ)) - prior-impls)) - - (define (generate-export tenv prior-impls pexp) - (let ([new-name (pexp-new-name pexp)] - [new-type (pexp-new-type pexp)] - [old-name (pexp-old-name pexp)] - [old-type (pexp-old-type pexp)] - [method? (pexp-method? pexp)]) - (let ([define-sym (if (check-prior-impls tenv prior-impls new-type) - 'define/override - 'define/public)]) - (if method? - (if old-type - `(,define-sym (,(honu-translate-dynamic-method-name tenv new-name new-type) . args) - (super ,(honu-translate-dynamic-method-name tenv old-name old-type) . args)) - `(,define-sym (,(honu-translate-dynamic-method-name tenv new-name new-type) . args) - (apply ,(at-ctxt old-name) args))) - (if old-type - `(begin - (,define-sym (,(honu-translate-dynamic-field-getter tenv new-name new-type)) - (super ,(honu-translate-dynamic-field-getter tenv old-name old-type))) - (,define-sym (,(honu-translate-dynamic-field-setter tenv new-name new-type) val) - (super ,(honu-translate-dynamic-field-setter tenv old-name old-type) val))) - `(begin - (,define-sym (,(honu-translate-dynamic-field-getter tenv new-name new-type)) - ,(at-ctxt old-name)) - (,define-sym (,(honu-translate-dynamic-field-setter tenv new-name new-type) val) - (set! ,(at-ctxt old-name) val) - (void)))))))) - - (define (process-export tenv defn e) - (map (lambda (old new) - (process-names tenv defn (honu-export-type e) old new)) - (honu-export-old-names e) - (honu-export-new-names e))) - - (define (process-names tenv defn typ old new) - (let ((slotdefns (cond - [(honu-class? defn) - (honu-class-defns defn)] - [(honu-mixin? defn) - (append (honu-mixin-defns-before defn) - (honu-mixin-defns-after defn))]))) - (cond - [(find (lambda (s) - (tenv-key=? old s)) - (get-local-fields slotdefns)) - (make-pexp new (find-type-for-name tenv new typ) - old #f - #f)] - [(find (lambda (s) - (tenv-key=? old s)) - (get-local-methods slotdefns)) - (make-pexp new (find-type-for-name tenv new typ) - old #f - #t)] - [(and (honu-mixin? defn) - (find (lambda (s) - (tenv-key=? old s)) - (get-field-names-for-type tenv (honu-mixin-arg-type defn)))) - (make-pexp new (find-type-for-name tenv new typ) - old (find-type-for-name tenv old (honu-mixin-arg-type defn)) - #f)] - [(and (honu-mixin? defn) - (find (lambda (s) - (tenv-key=? old s)) - (get-method-names-for-type tenv (honu-mixin-arg-type defn)))) - (make-pexp new (find-type-for-name tenv new typ) - old (find-type-for-name tenv old (honu-mixin-arg-type defn)) - #t)] - [else (error (format "Shouldn't reach here!~n~nDefn~n~a~n~nTyp:~n~a~n~nOld:~n~a~n~nNew:~n~a~n~n" - defn - (printable-key (honu-iface-type-name typ)) - (printable-key old) - (printable-key new)))]))) - - (define (pexpstring (printable-key (honu-iface-type-name (pexp-new-type a)))) - (symbol->string (printable-key (honu-iface-type-name (pexp-new-type b))))) - (and (tenv-key=? (honu-iface-type-name (pexp-new-type a)) - (honu-iface-type-name (pexp-new-type b))) - (stringstring (printable-key (pexp-new-name a))) - (symbol->string (printable-key (pexp-new-name b))))))) - - (define (pexp=? a b) - (and (tenv-key=? (honu-iface-type-name (pexp-new-type a)) - (honu-iface-type-name (pexp-new-type b))) - (tenv-key=? (pexp-new-name a) - (pexp-new-name b)))) - - (define (filter-exports pexps) - (let ((sorted-exports (list:quicksort pexps pexp . -; (syntax/c any/c))]) - any)]) - (define (honu-translate-expression tenv defn exp) - (match exp - [(struct honu-null (stx)) - (at stx 'null)] - - [(struct honu-int (stx val)) - (at stx val)] - [(struct honu-float (stx val)) - (at stx val)] - [(struct honu-char (stx val)) - (at stx val)] - [(struct honu-str (stx val)) - (at stx val)] - [(struct honu-bool (stx val)) - (at stx val)] - - [(struct honu-var (stx name builtin?)) - (if builtin? - (get-builtin-translation name) - name)] - [(struct honu-this (stx)) - (at stx 'this)] - - [(struct honu-uprim (stx op op-stx op-type body)) - (let ((body-exp (honu-translate-expression tenv defn body))) - (case op - [(not) - (at stx `(,(at op-stx 'not) ,body-exp))] - [(minus) - (at stx `(,(at op-stx '-) ,body-exp))]))] - [(struct honu-prim (stx op op-stx op-type left right)) - (let ((left-exp (honu-translate-expression tenv defn left)) - (right-exp (honu-translate-expression tenv defn right))) - (case op - [(plus) - (if (eqv? 'str (honu-prim-type-name op-type)) - (at stx `(,(at op-stx 'string-append) ,left-exp ,right-exp)) - (at stx `(,(at op-stx '+) ,left-exp ,right-exp)))] - [(minus) - (at stx `(,(at op-stx '-) ,left-exp ,right-exp))] - [(times) - (at stx `(,(at op-stx '*) ,left-exp ,right-exp))] - [(div) - (if (eqv? 'float (honu-prim-type-name op-type)) - (at stx `(,(at op-stx '/) ,left-exp ,right-exp)) - (at stx `(,(at op-stx 'quotient) ,left-exp ,right-exp)))] - [(mod) - (at stx `(,(at op-stx 'modulo) ,left-exp ,right-exp))] - [(lt) - (case (honu-prim-type-name op-type) - [(int float) - (at stx `(,(at op-stx '<) ,left-exp ,right-exp))] - [(string) - (at stx `(,(at op-stx 'string) ,left-exp ,right-exp))] - [(string) - (at stx `(,(at op-stx 'string>?) ,left-exp ,right-exp))] - [(char) - (at stx `(,(at op-stx 'char>?) ,left-exp ,right-exp))])] - [(ge) - (case (honu-prim-type-name op-type) - [(int float) - (at stx `(,(at op-stx '>=) ,left-exp ,right-exp))] - [(string) - (at stx `(,(at op-stx 'string>=?) ,left-exp ,right-exp))] - [(char) - (at stx `(,(at op-stx 'char>=?) ,left-exp ,right-exp))])] - [(and) - (at stx `(,(at op-stx 'and) ,left-exp ,right-exp))] - [(or) - (at stx `(,(at op-stx 'or) ,left-exp ,right-exp))] - [(clseq) - (at stx `(,(at op-stx 'equal?) ,left-exp ,right-exp))] - [(equal) - (if (and (honu-prim-type? op-type) - (eqv? 'str (honu-prim-type-name op-type))) - (at stx `(,(at op-stx 'string=?) ,left-exp ,right-exp)) - (at stx `(,(at op-stx 'eqv?) ,left-exp ,right-exp)))] - [(neq) - (if (and (honu-prim-type? op-type) - (eqv? 'str (honu-prim-type-name op-type))) - (at stx `(,(at op-stx 'not) (,(at op-stx 'string=?) ,left-exp ,right-exp))) - (at stx `(,(at op-stx 'not) (,(at op-stx 'eqv?) ,left-exp ,right-exp))))]))] - - [(struct honu-lambda (stx arg-names _ body)) - (at stx `(lambda ,(map (lambda (n) (at-ctxt n)) arg-names) - ,(honu-translate-expression tenv defn body)))] - - [(struct honu-assn (stx name rhs)) - (at stx `(set! ,(at-ctxt name) - ,(honu-translate-expression tenv defn rhs)))] - [(struct honu-call (stx name args builtin?)) - (let ([f (if builtin? - (get-builtin-translation name) - (at-ctxt name))]) - (at stx (cons f (map (lambda (e) - (honu-translate-expression tenv defn e)) - args))))] - - [(struct honu-facc (stx obj elab field)) - (if (eqv? obj 'my) - (if (field-in-defn? field defn) - (at stx field) - (at stx `(super ,(honu-translate-dynamic-field-getter tenv - field - (honu-mixin-arg-type defn))))) - (at stx `(send ,(honu-translate-expression tenv defn obj) - ,(honu-translate-dynamic-field-getter tenv field elab))))] - [(struct honu-fassn (stx obj elab field rhs)) - (if (eqv? (honu-fassn-obj exp) 'my) - (if (field-in-defn? field defn) - (at stx `(set! ,(at-ctxt field) - ,(honu-translate-expression tenv defn rhs))) - (at stx `(super ,(honu-translate-dynamic-field-setter tenv - field - (honu-mixin-arg-type defn)) - ,(honu-translate-expression tenv defn rhs)))) - (at stx `(send ,(honu-translate-expression tenv defn obj) - ,(honu-translate-dynamic-field-setter tenv field elab) - ,(honu-translate-expression tenv defn rhs))))] - [(struct honu-mcall (stx obj elab method args)) - (if (eqv? obj 'my) - (if (find (match-lambda - [(struct honu-method (_ name _ _ _ _)) - (tenv-key=? name method)] - [_ #f]) - (cond - [(honu-class? defn) (honu-class-defns defn)] - [(honu-mixin? defn) (append (honu-mixin-defns-before defn) - (honu-mixin-defns-after defn))])) - (at stx `(,(at-ctxt method) - ,@(map (lambda (e) - (honu-translate-expression tenv defn e)) - args))) - (at stx `(super ,(honu-translate-dynamic-method-name tenv - method - (honu-mixin-arg-type defn)) - ,@(map (lambda (e) - (honu-translate-expression tenv defn e)) - args)))) - (at stx `(send ,(honu-translate-expression tenv defn obj) - ,(honu-translate-dynamic-method-name tenv method elab) - ,@(map (lambda (e) - (honu-translate-expression tenv defn e)) - args))))] - - [(struct honu-cast (stx obj type)) - (let ([cast-type (honu-translate-type-name type)]) - (if cast-type - (at stx `(let ((cast-obj ,(honu-translate-expression tenv defn obj))) - (if (is-a? cast-obj ,cast-type) - cast-obj - (error "Cast failed!")))) - (honu-translate-expression tenv defn obj)))] - [(struct honu-isa (stx obj type)) - (let ([isa-type (honu-translate-type-name type)]) - (if isa-type - (at stx `(is-a? ,(honu-translate-expression tenv defn obj) - ,isa-type)) - (honu-translate-expression tenv defn (make-honu-bool stx #t))))] - - [(struct honu-new (stx class type arg-names arg-vals)) - (at stx `(new ,(honu-translate-class-name class) - ,@(map (lambda (a b) (list a (honu-translate-expression tenv defn b))) - arg-names - arg-vals)))] - - [(struct honu-if (stx cond true false)) - (at stx `(if ,(honu-translate-expression tenv defn cond) - ,(honu-translate-expression tenv defn true) - ,(honu-translate-expression tenv defn false)))] - - [(struct honu-while (stx cond body)) - (at stx `(let loop () - (if ,(honu-translate-expression tenv defn cond) - (begin ,(honu-translate-expression tenv defn body) - (loop)))))] - - [(struct honu-return (stx body)) - (at stx (if body - (honu-translate-expression tenv defn body) - `(void)))] - [(struct honu-block (stx binds exps)) - (at stx `(let* ,(map (lambda (b) - (honu-translate-binding tenv defn b #f)) - binds) - ,@(map (lambda (e) - (honu-translate-expression tenv defn e)) - exps)))])) - - (provide/contract [honu-translate-binding - (tenv? - (union false/c - honu-defn?) - honu-binding? - (union false/c - (lambda (b) (eq? #t b))) - . -> . -; (syntax/c any/c))]) - any)]) - (define (honu-translate-binding tenv defn bnd top-level?) - (match bnd - [(struct honu-binding (stx name _ rhs)) - (if top-level? - (at stx `(define ,name - ,(honu-translate-expression tenv defn rhs))) - (at stx `[,(at-ctxt name) ,(honu-translate-expression tenv defn rhs)]))])) - ) - diff --git a/collects/honu/private/compiler/honu-translate-function.ss b/collects/honu/private/compiler/honu-translate-function.ss deleted file mode 100644 index c5a3e5bf59..0000000000 --- a/collects/honu/private/compiler/honu-translate-function.ss +++ /dev/null @@ -1,14 +0,0 @@ -(module honu-translate-function mzscheme - (require (lib "plt-match.ss")) - - (require "../../ast.ss") - (require "honu-translate-utils.ss") - (require "honu-translate-expression.ss") - - (provide honu-translate-function) - (define (honu-translate-function pgm defn) - (match defn - [(struct honu-function (stx name _ arg-names _ body)) - (at stx `(define ,(cons (at-ctxt name) (map at-ctxt arg-names)) - ,(honu-translate-expression pgm defn body)))])) - ) diff --git a/collects/honu/private/compiler/honu-translate-program.ss b/collects/honu/private/compiler/honu-translate-program.ss deleted file mode 100644 index bcfdbe7667..0000000000 --- a/collects/honu/private/compiler/honu-translate-program.ss +++ /dev/null @@ -1,41 +0,0 @@ -(module honu-translate-program mzscheme - - (require (all-except (lib "list.ss" "srfi" "1") any) - (lib "contract.ss")) - - (require "../../ast.ss") - (require "../../tenv.ss") - (require "honu-translate-type-defn.ss") - (require "honu-translate-function.ss") - (require "honu-translate-class.ss") - (require "honu-translate-subclass.ss") - (require "honu-translate-utils.ss") - - (provide/contract [honu-translate-program - (tenv? - honu-program? - . -> . -; (listof (syntax/c any/c))]) - list?)]) - (define (honu-translate-program tenv pgm) - (map (lambda (d) - (honu-translate-defn tenv pgm d)) - (filter (lambda (d) - (not (honu-mixin? d))) - (honu-program-defns pgm)))) - - (define (honu-translate-defn tenv pgm defn) - (cond - [(honu-function? defn) (honu-translate-function tenv defn)] - [(honu-type-defn? defn) (honu-translate-type-defn tenv defn)] - [(honu-class? defn) (honu-translate-class tenv defn)] - ; [(honu-mixin? defn) (honu-translate-mixin pgm defn)] - [(honu-subclass? defn) - (let ([mixin (find (lambda (d) - (and (honu-mixin? d) - (tenv-key=? (honu-mixin-name d) - (honu-subclass-mixin defn)))) - (honu-program-defns pgm))]) - (honu-translate-subclass tenv mixin defn))])) - - ) diff --git a/collects/honu/private/compiler/honu-translate-subclass.ss b/collects/honu/private/compiler/honu-translate-subclass.ss deleted file mode 100644 index d15ff516bc..0000000000 --- a/collects/honu/private/compiler/honu-translate-subclass.ss +++ /dev/null @@ -1,59 +0,0 @@ -(module honu-translate-subclass mzscheme - - (require (lib "list.ss" "srfi" "1") - (lib "plt-match.ss")) - - (require "../../ast.ss") - (require "../../utils.ss") - (require "../../tenv.ss") - (require "honu-translate-utils.ss") - (require "honu-translate-class-utils.ss") - (require "honu-translate-expression.ss") - - (define (get-prior-ifaces tenv cname) - (match-let ([(struct tenv-class (stx sub-type impls _ _ super)) - (get-class-entry cname tenv)]) - (if super - (cons sub-type (append impls (get-prior-ifaces tenv super))) - (cons sub-type impls)))) - - (define (honu-translate-super-new tenv mxn sup-new) - (match sup-new - [(struct honu-super-new (stx arg-names arg-vals)) - (at stx `(super-new - ,@(map (lambda (name exp) - (list name (honu-translate-expression tenv mxn exp))) - arg-names - arg-vals)))])) - - (provide honu-translate-subclass) - - (define (honu-translate-subclass tenv mxn defn) - ;; I would think the below is equivalent to: - -; (match-let ([(struct honu-subclass (stx subc-name mixin base)) defn] -; [(struct honu-mixin (stx mxn-name _ _ _ init-names init-types impls -; _ _ defns-before super-new defns-after exports)) mxn]) - - ;; but it gave me errors, so I separated them out appropriately. Check into this later. - - (match defn - [(struct honu-subclass (stx subc-name mixin base)) - (match mxn - [(struct honu-mixin (stx mxn-name _ _ _ init-names init-types impls - _ _ defns-before super-new defns-after exports)) - (let ([prior-impls (get-prior-ifaces tenv base)]) - (at stx `(define ,(honu-translate-class-name subc-name) - (parameterize ([current-inspector (make-inspector (current-inspector))]) - (define ,(honu-translate-class-name subc-name) - (class* ,(honu-translate-class-name base) - ,(filter-map honu-translate-type-name impls) - ,@(honu-translate-init-slots init-names) - ,@(honu-translate-slotdefns tenv mxn defns-before) - ,(honu-translate-super-new tenv mxn super-new) - ,@(honu-translate-slotdefns tenv mxn defns-after) - ,@(honu-translate-exports tenv mxn prior-impls exports))) - ,(honu-translate-class-name subc-name))))) - ])])) - - ) diff --git a/collects/honu/private/compiler/honu-translate-type-defn.ss b/collects/honu/private/compiler/honu-translate-type-defn.ss deleted file mode 100644 index 136e554edc..0000000000 --- a/collects/honu/private/compiler/honu-translate-type-defn.ss +++ /dev/null @@ -1,35 +0,0 @@ -(module honu-translate-type-defn mzscheme - - (require (lib "list.ss" "srfi" "1") - (lib "plt-match.ss")) - - (require "../../ast.ss") - (require "../../tenv.ss") - (require "../typechecker/honu-type-utils.ss") - (require "honu-translate-utils.ss") - - (provide honu-translate-type-defn) - (define (honu-translate-type-defn tenv defn) - (match defn - [(struct honu-type-defn (stx name supers decls)) - (let ([typ (make-honu-iface-type name name)] - [method-names (filter-map (match-lambda - [(struct honu-method-decl (_ name _ _)) name] - [_ #f]) - decls)] - [field-names (filter-map (match-lambda - [(struct honu-field-decl (_ name _)) name] - [_ #f]) - decls)]) - (at stx `(define ,(honu-translate-type-name typ) - (interface ,(filter-map honu-translate-type-name supers) - ,@(map (lambda (m) - (honu-translate-dynamic-method-name tenv m typ)) - method-names) - ,@(map (lambda (f) - (honu-translate-dynamic-field-getter tenv f typ)) - field-names) - ,@(map (lambda (f) - (honu-translate-dynamic-field-setter tenv f typ)) - field-names)))))])) - ) diff --git a/collects/honu/private/compiler/honu-translate-utils.ss b/collects/honu/private/compiler/honu-translate-utils.ss deleted file mode 100644 index aebb045201..0000000000 --- a/collects/honu/private/compiler/honu-translate-utils.ss +++ /dev/null @@ -1,83 +0,0 @@ -(module honu-translate-utils mzscheme - - (require (lib "list.ss" "srfi" "1")) - - (require "../../ast.ss") - (require "../../tenv.ss") - - (provide current-compile-context) - (define current-compile-context (make-parameter #f)) - -; (provide/contract [at ((syntax/c any/c) any/c . -> . (syntax/c any/c))] -; [at-ctxt ((syntax/c any/c) . -> . (syntax/c any/c))]) - (provide at at-ctxt) - (define (at stx expr) - (datum->syntax-object (current-compile-context) expr stx)) - (define (at-ctxt stx) - (datum->syntax-object (current-compile-context) (syntax-e stx) stx)) - - (provide honu-translate-class-name) - (define (honu-translate-class-name sym) - (at sym - (string->symbol - (string-append "honu-" (symbol->string (printable-key sym)) "%")))) - - (provide honu-translate-type-name) - (define (honu-translate-type-name typ) - (if (honu-iface-top-type? typ) #f - (at (honu-ast-src-stx typ) - (string->symbol - (string-append "honu-" (symbol->string (printable-key (honu-iface-type-name typ))) "<%>"))))) - - (provide honu-translate-mixin-name) - (define (honu-translate-mixin-name mixin) - (at mixin - (string->symbol - (string-append "honu-" (symbol->string (printable-key mixin)) "-mixin")))) - - (provide honu-translate-field-getter) - (define (honu-translate-field-getter sym) - (at sym - (string->symbol (string-append "get-" (symbol->string (printable-key sym)))))) - - (provide honu-translate-field-setter) - (define (honu-translate-field-setter sym) - (at sym - (string->symbol (string-append "set-" (symbol->string (printable-key sym)) "!")))) - - (provide find-type-for-name) - (define (find-type-for-name tenv name typ) - (let ([type-defn (get-type-entry (honu-iface-type-name typ) tenv)]) - (if (ormap (lambda (d) - (cond - [(honu-field-decl? d) (tenv-key=? (honu-field-decl-name d) name)] - [(honu-method-decl? d) (tenv-key=? (honu-method-decl-name d) name)])) - (tenv-type-members type-defn)) - typ - (find (lambda (t) - (find-type-for-name tenv name t)) - (tenv-type-supers type-defn))))) - - (provide honu-translate-dynamic-field-getter) - (define (honu-translate-dynamic-field-getter tenv sym typ) - (at sym - (string->symbol (string-append "get-" - (symbol->string (printable-key (honu-translate-type-name (find-type-for-name tenv sym typ)))) - "-" - (symbol->string (printable-key sym)))))) - - (provide honu-translate-dynamic-field-setter) - (define (honu-translate-dynamic-field-setter tenv sym typ) - (at sym - (string->symbol (string-append "set-" - (symbol->string (printable-key (honu-translate-type-name (find-type-for-name tenv sym typ)))) - "-" - (symbol->string (printable-key sym)) "!")))) - - (provide honu-translate-dynamic-method-name) - (define (honu-translate-dynamic-method-name tenv name typ) - (at name - (string->symbol (string-append (symbol->string (printable-key (honu-translate-type-name (find-type-for-name tenv name typ)))) - "-" - (symbol->string (printable-key name)))))) - ) diff --git a/collects/honu/private/compiler/translate-class-utils.ss b/collects/honu/private/compiler/translate-class-utils.ss new file mode 100644 index 0000000000..75a9a265b5 --- /dev/null +++ b/collects/honu/private/compiler/translate-class-utils.ss @@ -0,0 +1,151 @@ +(module translate-class-utils mzscheme + + (require (lib "list.ss" "srfi" "1") + (lib "plt-match.ss") + "../../ast.ss" + "../../tenv.ss" + "../../utils.ss" + "../typechecker/type-utils.ss" + "translate-expression.ss" + "translate-utils.ss") + + (define-struct comp:export (stx type binds) #f) + (define-struct comp:exp-bind (old new method?) #f) + + (provide translate-class-exports translate-subclass-exports) + (define (translate-class-exports tenv exports) + (let ([exports (filter-exports tenv (generate-exports tenv exports))]) + (map (lambda (e) + (translate-export tenv #f #f e)) + exports))) + + (define (translate-subclass-exports tenv super-types arg-type exports) + (let ([exports (filter-exports tenv (generate-exports tenv exports))]) + (map (lambda (e) + (if (ormap (lambda (t) + (<:_P tenv t (comp:export-type e))) + super-types) + (translate-export tenv #t arg-type e) + (translate-export tenv #f arg-type e))) + exports))) + + + + (define (generate-super-exports tenv type-entry comp-binds) + (let loop ([super-types (tenv:type-supers type-entry)] + [super-comp-exps '()]) + (if (null? super-types) + super-comp-exps + (let ([super-entry (get-type-entry tenv (car super-types))]) + (let loop2 ([super-members (append (tenv:type-members super-entry) + (tenv:type-inherited super-entry))] + [super-comp-binds '()]) + (if (null? super-members) + (loop (cdr super-types) + (cons (make-comp:export #f (car super-types) super-comp-binds) + (append (generate-super-exports tenv super-entry comp-binds) + super-comp-exps))) + (let ([matched (find (lambda (eb) + (tenv-key=? (tenv:member-name (car super-members)) + (comp:exp-bind-new eb))) + comp-binds)]) + (loop2 (cdr super-members) + (cons matched super-comp-binds))))))))) + + + (define (generate-exports tenv exports) + (let loop ([exports exports] + [comp-exps '()]) + (if (null? exports) + comp-exps + (let* ([export (car exports)] + [type-entry (get-type-entry tenv (honu:export-type export))]) + (let loop2 ([exp-binds (honu:export-binds export)] + [members (append (tenv:type-members type-entry) + (tenv:type-inherited type-entry))] + [comp-binds '()]) + (if (null? exp-binds) + (let ([super-exports (generate-super-exports tenv type-entry comp-binds)]) + (loop (cdr exports) + (cons (make-comp:export (honu:ast-stx export) + (honu:export-type export) + comp-binds) + (append super-exports comp-exps)))) + (let-values ([(matched non-matches) (partition-first (lambda (m) + (tenv-key=? (honu:exp-bind-new (car exp-binds)) + (tenv:member-name m))) + members)]) + (loop2 (cdr exp-binds) + non-matches + (cons (make-comp:exp-bind (honu:exp-bind-old (car exp-binds)) + (honu:exp-bind-new (car exp-binds)) + (honu:type-disp? (tenv:member-type matched))) + comp-binds))))))))) + + (define (filter-exports tenv exports) + (let loop ([exports exports] + [kept-exps '()]) + (if (null? exports) + kept-exps + (let-values ([(matches non-matches) (partition (lambda (exp) + (type-equal? tenv + (comp:export-type (car exports)) + (comp:export-type exp))) + exports)]) + (let ([exp-with-stx (find comp:export-stx (cons (car exports) matches))]) + (if exp-with-stx + (loop non-matches (cons exp-with-stx kept-exps)) + (loop non-matches (cons (car exports) kept-exps)))))))) + + (define (translate-export tenv in-super? arg-type export) + (cons 'begin + (map (lambda (b) + (translate-exp-bind tenv in-super? arg-type (comp:export-type export) b)) + (comp:export-binds export)))) + + (define (translate-exp-bind tenv in-super? arg-type type binding) + (let ([right-defn (if in-super? 'define/override 'define/public)]) + (match binding + [(struct comp:exp-bind (old-name new-name #t)) + (at #f `(,right-defn (,(translate-method-name type new-name) args) + ,(translate-static-method tenv arg-type old-name 'args)))] + [(struct comp:exp-bind (old-name new-name #f)) + (at #f `(begin + (,right-defn (,(translate-field-getter-name type new-name) args) + ,(translate-static-field-getter tenv arg-type old-name)) + (,right-defn (,(translate-field-setter-name type new-name) arg) + ,(translate-static-field-setter tenv arg-type old-name 'arg))))]))) + + (provide translate-super-new translate-inits translate-member) + (define (translate-super-new tenv arg-type super-new) + (at (honu:ast-stx super-new) + (cons 'super-new (map (lambda (a) + (list (at-ctxt (honu:name-arg-name a)) + (translate-expression tenv arg-type (honu:name-arg-value a)))) + (honu:super-new-args super-new))))) + + (define (translate-inits inits) + (cons 'init (map (lambda (i) + (at-ctxt (honu:formal-name i))) + inits))) + + (define (mangle-init-name name) + (at name (string->symbol (string-append "init-" (symbol->string (syntax-e name)))))) + + (define (translate-member tenv arg-type member) + (match member + [(struct honu:init-field (stx name _ value)) + (if value + `(begin (init ([,(mangle-init-name name) ,(at-ctxt name)] + ,(translate-expression tenv arg-type value))) + (define ,(at-ctxt name) ,(mangle-init-name))) + `(begin (init ([,(mangle-init-name name) ,(at-ctxt name)])) + (define ,(at-ctxt name) ,(mangle-init-name name))))] + [(struct honu:field (stx name _ value)) + `(define ,(at-ctxt name) ,(translate-expression tenv arg-type value))] + [(struct honu:method (stx name _ formals body)) + (translate-function stx name formals + (translate-expression tenv arg-type body))])) + + + ) \ No newline at end of file diff --git a/collects/honu/private/compiler/translate-expression.ss b/collects/honu/private/compiler/translate-expression.ss new file mode 100644 index 0000000000..a871972dd2 --- /dev/null +++ b/collects/honu/private/compiler/translate-expression.ss @@ -0,0 +1,308 @@ +(module translate-expression mzscheme + + (require (lib "contract.ss") + (lib "plt-match.ss") + "../../ast.ss" + "../../readerr.ss" + "../../tenv.ss" + "translate-utils.ss") + + (provide/contract [translate-expression (tenv? (union honu:type? false/c) honu:expr? + . -> . + (syntax/c any/c))]) + (define (translate-expression tenv arg-type expr) + (match expr + [(struct honu:lit (stx _ value)) + (at stx value)] + [(struct honu:var (stx name)) + (at-ctxt name)] + [(struct honu:tuple (stx args)) + (at stx `(list ,@(map (lambda (e) + (translate-expression tenv arg-type e)) + args)))] + [(struct honu:lambda (stx _ formals body)) + (translate-function stx #f formals (translate-expression tenv arg-type body))] + [(struct honu:call (stx func arg)) + (match func + [(struct honu:member (stx 'my _ name #t)) + (at stx (translate-static-method tenv arg-type name + (translate-expression tenv arg-type arg)))] + [(struct honu:member (stx obj elab name #t)) + (at stx `(send ,(translate-expression tenv arg-type obj) + ,(translate-method-name elab name) + ,(translate-expression tenv arg-type arg)))] + [else + (at stx `(,(translate-expression tenv arg-type func) + ,(translate-expression tenv arg-type arg)))])] + [(struct honu:select (stx slot arg)) + (at stx `(list-ref ,(translate-expression tenv arg-type arg) + (- ,slot 1)))] + [(struct honu:if (stx test then else)) + (if else + (at stx `(if ,(translate-expression tenv arg-type test) + ,(translate-expression tenv arg-type then) + ,(translate-expression tenv arg-type else))) + (at stx `(if ,(translate-expression tenv arg-type test) + ,(translate-expression tenv arg-type then) + ,void-value)))] + [(struct honu:cond (stx clauses else)) + (if else + (at stx `(cond ,@(map (lambda (c) + `(,(translate-expression tenv arg-type (honu:cond-clause-pred c)) + ,(translate-expression tenv arg-type (honu:cond-clause-rhs c)))) + clauses) + (else ,(translate-expression tenv arg-type else)))) + (at stx `(cond ,@(map (lambda (c) + `(,(translate-expression tenv arg-type (honu:cond-clause-pred c)) + ,(translate-expression tenv arg-type (honu:cond-clause-rhs c)))) + clauses) + (else ,void-value))))] + [(struct honu:un-op (stx op op-stx op-type arg)) + (case op + [(not) + (at stx + `(,(at op-stx 'not) ,(translate-expression tenv arg-type arg)))] + [(minus) + (at stx + `(,(at op-stx '-) ,(translate-expression tenv arg-type arg)))] + [else (raise-read-error-with-stx + "Haven't translated unary operator yet." + op-stx)])] + [(struct honu:bin-op (stx op op-stx op-type larg rarg)) + (case op + [(equal) + (if (and (honu:type-prim? op-type) + (eqv? (honu:type-prim-name op-type) 'string)) + (at stx + `(,(at op-stx 'string=?) + ,(translate-expression tenv arg-type larg) + ,(translate-expression tenv arg-type rarg))) + (at stx + `(,(at op-stx 'eqv?) + ,(translate-expression tenv arg-type larg) + ,(translate-expression tenv arg-type rarg))))] + [(neq) + (if (and (honu:type-prim? op-type) + (eqv? (honu:type-prim-name op-type) 'string)) + (at stx + `(,(at op-stx 'not) + (,(at op-stx 'string=?) + ,(translate-expression tenv arg-type larg) + ,(translate-expression tenv arg-type rarg)))) + (at stx + `(,(at op-stx 'not) + (,(at op-stx 'eqv?) + ,(translate-expression tenv arg-type larg) + ,(translate-expression tenv arg-type rarg)))))] + [(clseq) + (at stx + `(,(at op-stx 'equal?) + ,(translate-expression tenv arg-type larg) + ,(translate-expression tenv arg-type rarg)))] + [(and) + (at stx + `(,(at op-stx 'and) + ,(translate-expression tenv arg-type larg) + ,(translate-expression tenv arg-type rarg)))] + [(or) + (at stx + `(,(at op-stx 'or) + ,(translate-expression tenv arg-type larg) + ,(translate-expression tenv arg-type rarg)))] + [(lt) + (case (honu:type-prim-name op-type) + [(int float) + (at stx + `(,(at op-stx '<) + ,(translate-expression tenv arg-type larg) + ,(translate-expression tenv arg-type rarg)))] + [(string) + (at stx + `(,(at op-stx 'string) + ,(translate-expression tenv arg-type larg) + ,(translate-expression tenv arg-type rarg)))] + [(string) + (at stx + `(,(at op-stx 'string>?) + ,(translate-expression tenv arg-type larg) + ,(translate-expression tenv arg-type rarg)))] + [(char) + (at stx + `(,(at op-stx 'char>?) + ,(translate-expression tenv arg-type larg) + ,(translate-expression tenv arg-type rarg)))])] + [(ge) + (case (honu:type-prim-name op-type) + [(int float) + (at stx + `(,(at op-stx '>=) + ,(translate-expression tenv arg-type larg) + ,(translate-expression tenv arg-type rarg)))] + [(string) + (at stx + `(,(at op-stx 'string>=?) + ,(translate-expression tenv arg-type larg) + ,(translate-expression tenv arg-type rarg)))] + [(char) + (at stx + `(,(at op-stx 'char>=?) + ,(translate-expression tenv arg-type larg) + ,(translate-expression tenv arg-type rarg)))])] + [(plus) + (case (honu:type-prim-name op-type) + [(int float) + (at stx + `(,(at op-stx '+) + ,(translate-expression tenv arg-type larg) + ,(translate-expression tenv arg-type rarg)))] + [(string) + (at stx + `(,(at op-stx 'string-append) + ,(translate-expression tenv arg-type larg) + ,(translate-expression tenv arg-type rarg)))])] + [(minus) + (at stx + `(,(at op-stx '-) + ,(translate-expression tenv arg-type larg) + ,(translate-expression tenv arg-type rarg)))] + [(times) + (at stx + `(,(at op-stx '*) + ,(translate-expression tenv arg-type larg) + ,(translate-expression tenv arg-type rarg)))] + [(div) + (case (honu:type-prim-name op-type) + [(int) + (at stx + `(,(at op-stx 'quotient) + ,(translate-expression tenv arg-type larg) + ,(translate-expression tenv arg-type rarg)))] + [(float) + (at stx + `(,(at op-stx '/) + ,(translate-expression tenv arg-type larg) + ,(translate-expression tenv arg-type rarg)))])] + [(mod) + (at stx + `(,(at op-stx 'remainder) + ,(translate-expression tenv arg-type larg) + ,(translate-expression tenv arg-type rarg)))] + [else (raise-read-error-with-stx + "Haven't translated binary operator yet." + op-stx)])] + [(struct honu:return (stx body)) + (at stx + `(last-k ,(translate-expression tenv arg-type body)))] + [(struct honu:let (stx bindings body)) + (at stx + `(let*-values ,(map (lambda (b) + (let-values ([(bound-names body) + (translate-binding-clause (honu:binding-names b) + (translate-expression tenv arg-type (honu:binding-value b)))]) + `(,bound-names ,body))) + bindings) + ,(translate-expression tenv arg-type body)))] + [(struct honu:seq (stx effects value)) + (at stx + `(begin ,@(map (lambda (e) + (translate-expression tenv arg-type e)) + effects) + ,(translate-expression tenv arg-type value)))] + [(struct honu:while (stx test body)) + (at stx + `(let loop () + (if ,(translate-expression tenv arg-type test) + (begin ,(translate-expression tenv arg-type body) (loop)) + ,void-value)))] + [(struct honu:assn (stx lhs rhs)) + (match lhs + [(struct honu:var (_ _)) + (at stx `(begin (set! ,(translate-expression tenv arg-type lhs) + ,(translate-expression tenv arg-type rhs)) + ,void-value))] + [(struct honu:member (mstx 'my _ name method?)) + (if method? + (raise-read-error-with-stx + "Left-hand side of assignment cannot be a method name" + mstx) + (at stx (translate-static-field-setter tenv arg-type name + (translate-expression tenv arg-type rhs))))] + [(struct honu:member (mstx obj elab name method?)) + (if method? + (raise-read-error-with-stx + "Left-hand side of assignment cannot be a method name" + mstx) + (at stx `(send ,(translate-expression tenv arg-type obj) + ,(translate-field-setter-name elab name) + ,(translate-expression tenv arg-type rhs))))] + [else + (raise-read-error-with-stx + "Left-hand side of assignment is invalid" + stx)])] + [(struct honu:member (stx 'my _ name method?)) + (if method? + (at stx (translate-static-method tenv arg-type name)) + (at stx (translate-static-field-getter tenv arg-type name)))] + [(struct honu:member (stx obj elab name method?)) + (if method? + (at stx `(lambda (args) + (send ,(translate-expression tenv arg-type obj) + ,(translate-method-name elab name) + args))) + (at stx `(send ,(translate-expression tenv arg-type obj) + ,(translate-field-getter-name elab name) + (list))))] + [(struct honu:new (stx class _ args)) + (at stx `(new ,(translate-class-name class) + ,@(map (lambda (a) + `(,(honu:name-arg-name a) + ,(translate-expression tenv arg-type (honu:name-arg-value a)))) + args)))] + [(struct honu:cast (stx obj type)) + (at stx `(let ([cast-obj ,(translate-expression tenv arg-type obj)]) + (if (is-a? cast-obj ,(translate-iface-name type)) + cast-obj + (let*-values ([(class dc-1) (object-info cast-obj)] + [(class-name dc-1 dc-2 dc-3 dc-4 dc-5 dc-6) (class-info class)]) + (error (format "Class ~a does not implement ~a" + class-name + (quote ,(translate-iface-name type))))))))] + [(struct honu:isa (stx obj type)) + (at stx `(let ([cast-obj ,(translate-expression tenv arg-type obj)]) + (is-a? cast-obj ,(translate-iface-name type))))] + [(struct honu:this (stx)) + (at stx 'this)] + [else (raise-read-error-with-stx + "Haven't translated that type of expression yet." + (honu:ast-stx expr))])) + + ) diff --git a/collects/honu/private/compiler/translate-utils.ss b/collects/honu/private/compiler/translate-utils.ss new file mode 100644 index 0000000000..a0c4f1fb5a --- /dev/null +++ b/collects/honu/private/compiler/translate-utils.ss @@ -0,0 +1,138 @@ +(module translate-utils mzscheme + + (require (all-except (lib "list.ss" "srfi" "1") any) + (lib "contract.ss") + "../../ast.ss" + "../../tenv.ss") + + (provide current-compile-context) + (define current-compile-context (make-parameter #f)) + + (define stx-for-original-property (read-syntax #f (open-input-string "original"))) + + (provide/contract [at ((union (syntax/c any/c) false/c) + any/c + . -> . + (syntax/c any/c))] + [at-ctxt ((syntax/c any/c) . -> . (syntax/c any/c))]) + (define (at stx expr) + (datum->syntax-object (current-compile-context) expr stx stx-for-original-property)) + (define (at-ctxt stx) + (datum->syntax-object (current-compile-context) (syntax-e stx) stx stx-for-original-property)) + + (provide void-value) + (define void-value '()) + + (provide translate-function) + (define (translate-function stx name args body) + (define (wrapping-syntax arg body) + (if name + (at stx `(define (,(at-ctxt name) ,arg) + (let/ec last-k ,body))) + (at stx `(lambda (,arg) + (let/ec last-k ,body))))) + (if (= (length args) 1) + (wrapping-syntax (at-ctxt (honu:formal-name (car args))) + body) + (wrapping-syntax (at #f 'arg-tuple) + `(let-values ([,(map (lambda (a) + (at-ctxt (honu:formal-name a))) + args) + (apply values ,(at #f 'arg-tuple))]) + ,body)))) + + (provide translate-binding-clause) + (define (translate-binding-clause names value) + (define (grab-indices names) + (let loop ([names names] + [n 0] + [ret '()]) + (cond + [(null? names) + (reverse ret)] + [(car names) + (loop (cdr names) + (+ n 1) + (cons `(list-ref arg-tuple ,n) ret))] + [else + (loop (cdr names) + (+ n 1) + ret)]))) + (values (filter (lambda (n) n) names) + `(let ([arg-tuple ,(if (= (length names) 1) + `(list ,value) + value)]) + ,(cons values (grab-indices names))))) + + (provide translate-iface-name translate-class-name translate-method-name + translate-field-getter-name translate-field-setter-name) + (define (translate-iface-name type) + (let ([name (if (honu:type-iface-top? type) + (datum->syntax-object #f 'Any #f) + (honu:type-iface-name type))]) + (at name (string->symbol (string-append (symbol->string (syntax-e name)) "<%>"))))) + + (define (translate-class-name class) + (at class (string->symbol (string-append (symbol->string (syntax-e class)) "%")))) + + (define (translate-method-name type name) + (at name (string->symbol (string-append (symbol->string (syntax-e (translate-iface-name type))) + "-" + (symbol->string (syntax-e name)))))) + + (define (translate-field-getter-name type name) + (at name (string->symbol (string-append (symbol->string (syntax-e (translate-iface-name type))) + "-" + (symbol->string (syntax-e name)) + "-get")))) + + (define (translate-field-setter-name type name) + (at name (string->symbol (string-append (symbol->string (syntax-e (translate-iface-name type))) + "-" + (symbol->string (syntax-e name)) + "-set!")))) + + (provide translate-static-method translate-static-field-getter translate-static-field-setter) + (define (translate-static-method tenv arg-type name arg) + (if arg-type + (let ([type-entry (get-type-entry tenv arg-type)]) + (if (s:member name + (map tenv:member-name (append (tenv:type-members type-entry) + (tenv:type-inherited type-entry))) + tenv-key=?) + (if arg + `(super ,(translate-method-name arg-type name) ,arg) + `(lambda (arg) + (super ,(translate-method-name arg-type name) arg))) + (if arg + `(,(at-ctxt name) ,arg) + (at-ctxt name)))) + (if arg + `(,(at-ctxt name) ,arg) + (at-ctxt name)))) + + (define (translate-static-field-getter tenv arg-type name) + (if arg-type + (let ([type-entry (get-type-entry tenv arg-type)]) + (if (s:member name + (map tenv:member-name (append (tenv:type-members type-entry) + (tenv:type-inherited type-entry))) + tenv-key=?) + `(super ,(translate-field-getter-name arg-type name) (list)) + (at-ctxt name))) + (at-ctxt name))) + + (define (translate-static-field-setter tenv arg-type name arg) + (if arg-type + (let ([type-entry (get-type-entry tenv arg-type)]) + (if (s:member name + (map tenv:member-name (append (tenv:type-members type-entry) + (tenv:type-inherited type-entry))) + tenv-key=?) + `(super ,(translate-field-setter-name arg-type name) ,arg) + `(begin (set! ,(at-ctxt name) ,arg) + ,void-value))) + `(begin (set! ,(at-ctxt name) ,arg) + ,void-value))) + + ) diff --git a/collects/honu/private/compiler/translate.ss b/collects/honu/private/compiler/translate.ss new file mode 100644 index 0000000000..0070de70dd --- /dev/null +++ b/collects/honu/private/compiler/translate.ss @@ -0,0 +1,97 @@ +(module translate mzscheme + + (require (all-except (lib "list.ss" "srfi" "1") any) + (lib "contract.ss") + (lib "plt-match.ss") + "../../ast.ss" + "../../readerr.ss" + "../../tenv.ss" + "../typechecker/type-utils.ss" + "translate-class-utils.ss" + "translate-expression.ss" + "translate-utils.ss") + + (provide/contract [translate (tenv? (listof honu:defn?) + . -> . + (listof (syntax/c any/c)))] + [translate-defn (tenv? honu:defn? + . -> . + (syntax/c any/c))]) + (define (translate tenv defns) + (let loop ([defns-to-go defns] + [syntaxes '()]) + (cond + [(null? defns-to-go) (reverse syntaxes)] + [(honu:mixin? (car defns-to-go)) + (loop (cdr defns-to-go) syntaxes)] + [(honu:subclass? (car defns-to-go)) + (let ([mixin (find (lambda (d) + (and (honu:mixin? d) + (tenv-key=? (honu:mixin-name d) + (honu:subclass-mixin (car defns-to-go))))) + defns)]) + (loop (cdr defns-to-go) (cons (translate-subclass tenv mixin (car defns-to-go)) syntaxes)))] + [else + (loop (cdr defns-to-go) (cons (translate-defn tenv (car defns-to-go)) syntaxes))]))) + + (define (translate-member-names tenv name) + (let* ([iface (make-iface-type name name)] + [type-entry (get-type-entry tenv iface)]) + (let loop ([members (append (tenv:type-members type-entry) (tenv:type-inherited type-entry))] + [names '()]) + (if (null? members) + (reverse names) + (if (honu:type-disp? (tenv:member-type (car members))) + (loop (cdr members) + (cons (translate-method-name iface (tenv:member-name (car members))) + names)) + (loop (cdr members) + (cons (translate-field-setter-name iface (tenv:member-name (car members))) + (cons (translate-field-getter-name iface (tenv:member-name (car members))) + names)))))))) + + (define (translate-defn tenv defn) + (match defn + [(struct honu:bind-top (stx names _ value)) + (let-values ([(bound-names body) (translate-binding-clause names (translate-expression tenv #f value))]) + (at stx `(define-values ,bound-names ,body)))] + [(struct honu:function (stx name _ args body)) + (translate-function stx name args (translate-expression tenv #f body))] + [(struct honu:iface (stx name supers members)) + (at stx `(define ,(translate-iface-name (make-iface-type name name)) + (interface ,(if (null? supers) + (list (translate-iface-name (make-any-type #f))) + (map translate-iface-name supers)) + ,@(translate-member-names tenv name))))] + [(struct honu:class (stx name _ _ impls inits members exports)) + (at stx `(define ,(translate-class-name name) + (class* object% ,(map translate-iface-name impls) + (inspect #f) + ,(translate-inits inits) + ,@(map (lambda (m) + (translate-member tenv #f m)) members) + ,@(translate-class-exports tenv exports) + (super-new))))] + [else (raise-read-error-with-stx + "Haven't translated that type of definition yet." + (honu:ast-stx defn))])) + + (define (translate-subclass tenv mixin-defn defn) + (match (list mixin-defn defn) + [(list (struct honu:mixin (mstx mname _ arg-type _ impls inits _ super-new members-before members-after exports)) + (struct honu:subclass (stx name base mixin))) + (let* ([base-entry (get-class-entry tenv base)] + [base-types (cons (tenv:class-sub-type base-entry) + (tenv:class-impls base-entry))]) + (at stx `(define ,(translate-class-name name) + (class* ,(translate-class-name base) ,(map translate-iface-name impls) + (inspect #f) + ,(translate-inits inits) + ,@(map (lambda (m) + (translate-member tenv arg-type m)) members-before) + ,(translate-super-new tenv arg-type super-new) + ,@(map (lambda (m) + (translate-member tenv arg-type m)) members-after) + ,@(translate-subclass-exports tenv base-types arg-type exports)))))])) + + ) diff --git a/collects/honu/private/typechecker/honu-convert-static.ss b/collects/honu/private/typechecker/honu-convert-static.ss deleted file mode 100644 index 3a0770809a..0000000000 --- a/collects/honu/private/typechecker/honu-convert-static.ss +++ /dev/null @@ -1,204 +0,0 @@ -(module honu-convert-static mzscheme - - (require (lib "list.ss" "srfi" "1") - (lib "struct.ss") - "../../ast.ss" - "../../tenv.ss" - "honu-type-utils.ss" - "../../read-error-with-stx.ss") - - (define (tenv-filter-map tenv p) - (filter values (tenv-map tenv p))) - - (define (default-bindings tenv) - (append '(printStr printLine error readChar readLine strToInt strToFloat - intToStr floatToStr charToStr strLen substr charAt) - (tenv-filter-map tenv - (lambda (k v) - (if (tenv-func? v) (printable-key k) #f))))) - - (define default-class-bindings '()) - - (define (get-static-bindings defn) - (define (get-slotdefn-name d) - (cond - [(honu-field? d) (printable-key (honu-field-name d))] - [(honu-method? d) (printable-key (honu-method-name d))] - [(honu-init-field? d) (printable-key (honu-init-field-name d))])) - (cond - [(honu-class? defn) - (append default-class-bindings - (map printable-key (honu-class-init-names defn)) - (filter-map get-slotdefn-name (honu-class-defns defn)))] - [(honu-mixin? defn) - (append default-class-bindings - (map printable-key (honu-mixin-init-names defn)) - (filter-map get-slotdefn-name - (append (honu-mixin-defns-before defn) - (honu-mixin-defns-after defn))))] - [else '()])) - - (provide honu-convert-static) - (define (honu-convert-static tenv pgm) - (let* ((env (default-bindings tenv)) - (defns (map (lambda (defn) - (honu-convert-defn tenv env defn)) - (honu-program-defns pgm)))) - (copy-struct honu-program pgm - (honu-program-defns defns)))) - - (define (honu-convert-defn tenv env defn) - (cond - [(honu-class? defn) - (let* ((cenv (get-static-bindings defn)) - (new-mdidefns (map (lambda (d) - (honu-convert-mdidefn d env cenv)) (honu-class-defns defn)))) - (copy-struct honu-class defn - (honu-class-defns new-mdidefns)))] - [(honu-mixin? defn) - (let* ((cenv (append (get-static-bindings defn) - ;; get-fields-and-methods returns (name . type) pairs, so map car - (map (lambda (p) - (printable-key (car p))) - (get-fields-and-methods tenv (honu-mixin-arg-type defn))))) - (new-befores (map (lambda (d) - (honu-convert-mdidefn d env cenv)) - (honu-mixin-defns-before defn))) - (new-super-new (honu-convert-super-new (honu-mixin-super-new defn) env cenv)) - (new-afters (map (lambda (d) - (honu-convert-mdidefn d env cenv)) - (honu-mixin-defns-after defn)))) - (copy-struct honu-mixin defn - (honu-mixin-defns-before new-befores) - (honu-mixin-super-new new-super-new) - (honu-mixin-defns-after new-afters)))] - [else defn])) - - (define (honu-convert-mdidefn defn env cenv) - (cond - [(honu-init-field? defn) - (if (not (honu-init-field-value defn)) - (copy-struct honu-init-field defn - (honu-init-field-value (honu-convert-exp (honu-init-field-value defn) - env cenv))) - defn)] - [(honu-field? defn) - (copy-struct honu-field defn - (honu-field-value (honu-convert-exp (honu-field-value defn) env cenv)))] - [(honu-method? defn) - (copy-struct honu-method defn - (honu-method-body (honu-convert-exp (honu-method-body defn) - (append (map printable-key (honu-method-arg-names defn)) - env) - cenv)))])) - - (define (honu-convert-super-new defn env cenv) - (let ((new-vals (map (lambda (e) - (honu-convert-exp e env cenv)) - (honu-super-new-arg-vals defn)))) - (copy-struct honu-super-new defn - (honu-super-new-arg-vals new-vals)))) - - ;; I should consider changing this to allowing through all names that aren't bound in the - ;; cenv (those should be converted to my.foo). The typechecker will already give appropriate - ;; error messages for unbound variables. - (define (honu-convert-exp exp bound-vars cenv) - (cond - [(honu-var? exp) - (cond - [(member (printable-key (honu-var-name exp)) bound-vars) exp] - [(member (printable-key (honu-var-name exp)) cenv) - (make-honu-facc (honu-ast-src-stx exp) - 'my #f (honu-var-name exp))] - [else (raise-read-error-with-stx - (format "Unbound variable name ~a" (printable-key (honu-var-name exp))) - (honu-var-name exp))])] - [(honu-assn? exp) - (let ((new-rhs (honu-convert-exp (honu-assn-rhs exp) bound-vars cenv))) - (cond - [(member (printable-key (honu-assn-name exp)) bound-vars) - (copy-struct honu-assn exp (honu-assn-rhs new-rhs))] - [(member (printable-key (honu-assn-name exp)) cenv) - (make-honu-fassn (honu-ast-src-stx exp) - 'my #f (honu-assn-name exp) new-rhs)] - [else (raise-read-error-with-stx - (format "Unbound variable name ~a" (printable-key (honu-assn-name exp))) - (honu-assn-name exp))]))] - - [(honu-call? exp) - (let ((new-args (map (lambda (e) - (honu-convert-exp e bound-vars cenv)) - (honu-call-args exp)))) - (cond - [(member (printable-key (honu-call-name exp)) bound-vars) - (copy-struct honu-call exp (honu-call-args new-args))] - [(member (printable-key (honu-call-name exp)) cenv) - (make-honu-mcall (honu-ast-src-stx exp) - 'my #f (honu-call-name exp) new-args)] - [else (raise-read-error-with-stx - (format "Unbound function name ~a" (printable-key (honu-call-name exp))) - (honu-call-name exp))]))] - [(honu-prim? exp) - (copy-struct honu-prim exp - (honu-prim-left (honu-convert-exp (honu-prim-left exp) bound-vars cenv)) - (honu-prim-right (honu-convert-exp (honu-prim-right exp) bound-vars cenv)))] - [(honu-facc? exp) - (if (eqv? (honu-facc-obj exp) 'my) - exp - (copy-struct honu-facc exp - (honu-facc-obj (honu-convert-exp (honu-facc-obj exp) bound-vars cenv))))] - [(honu-fassn? exp) - (copy-struct honu-fassn exp - (honu-fassn-obj (if (eqv? (honu-fassn-obj exp) 'my) 'my - (honu-convert-exp (honu-fassn-obj exp) bound-vars cenv))) - (honu-fassn-rhs (honu-convert-exp (honu-fassn-rhs exp) bound-vars cenv)))] - [(honu-mcall? exp) - (copy-struct honu-mcall exp - (honu-mcall-obj (if (eqv? (honu-mcall-obj exp) 'my) 'my - (honu-convert-exp (honu-mcall-obj exp) bound-vars cenv))) - (honu-mcall-args (map (lambda (e) - (honu-convert-exp e bound-vars cenv)) - (honu-mcall-args exp))))] - [(honu-cast? exp) - (copy-struct honu-cast exp - (honu-cast-obj (honu-convert-exp (honu-cast-obj exp) bound-vars cenv)))] - [(honu-isa? exp) - (copy-struct honu-isa exp - (honu-isa-obj (honu-convert-exp (honu-isa-obj exp) bound-vars cenv)))] - [(honu-if? exp) - (copy-struct honu-if exp - (honu-if-cond (honu-convert-exp (honu-if-cond exp) bound-vars cenv)) - (honu-if-true (honu-convert-exp (honu-if-true exp) bound-vars cenv)) - (honu-if-false (honu-convert-exp (honu-if-false exp) bound-vars cenv)))] - [(honu-new? exp) - (copy-struct honu-new exp - (honu-new-arg-vals (map (lambda (e) - (honu-convert-exp e bound-vars cenv)) - (honu-new-arg-vals exp))))] - [(honu-lambda? exp) - (copy-struct honu-lambda exp - (honu-lambda-body (honu-convert-exp (honu-lambda-body exp) - (append (map printable-key (honu-lambda-arg-names exp)) - bound-vars) - cenv)))] - [(honu-block? exp) - (let loop ((binds (honu-block-binds exp)) - (new-binds null) - (bound-vars bound-vars)) - (if (null? binds) - (copy-struct honu-block exp - (honu-block-binds (reverse new-binds)) - (honu-block-exps (map (lambda (e) - (honu-convert-exp e bound-vars cenv)) - (honu-block-exps exp)))) - (let ((bind (car binds))) - (loop (cdr binds) - (cons (copy-struct honu-binding bind - (honu-binding-rhs (honu-convert-exp (honu-binding-rhs bind) bound-vars cenv))) - new-binds) - (cons (printable-key (honu-binding-name bind)) bound-vars)))))] - [(honu-return? exp) - (copy-struct honu-return exp - (honu-return-body (honu-convert-exp (honu-return-body exp) bound-vars cenv)))] - [else exp])) - ) diff --git a/collects/honu/private/typechecker/honu-type-utils.ss b/collects/honu/private/typechecker/honu-type-utils.ss deleted file mode 100644 index abe55351cd..0000000000 --- a/collects/honu/private/typechecker/honu-type-utils.ss +++ /dev/null @@ -1,399 +0,0 @@ -(module honu-type-utils mzscheme - - (require (all-except (lib "list.ss" "srfi" "1") any) - (lib "plt-match.ss") - (lib "contract.ss") - "../../ast.ss" - "../../tenv.ss" - "../../read-error-with-stx.ss") - - (provide honu-bool-type honu-str-type honu-int-type honu-float-type - honu-char-type - honu-null-type honu-error-type honu-any-type honu-void-type - honu-func-type-from-exp) - - (define (honu-error-type exp) - (if (syntax? exp) - (make-honu-bottom-type exp) - (make-honu-bottom-type (honu-ast-src-stx exp)))) - - (define (honu-func-type-from-exp args return exp) - (if (syntax? exp) - (make-honu-func-type exp args return) - (make-honu-func-type (honu-ast-src-stx exp) - args return))) - - (define (honu-dispatch-type-from-exp dispatches args return exp) - (if (syntax? exp) - (make-honu-dispatch-type exp dispatches args return) - (make-honu-dispatch-type (honu-ast-src-stx exp) - dispatches args return))) - - (define (honu-null-type exp) - (if (syntax? exp) - (make-honu-iface-bottom-type exp) - (make-honu-iface-bottom-type (honu-ast-src-stx exp)))) - - (define (honu-any-type exp) - (if (syntax? exp) - (make-honu-iface-top-type exp) - (make-honu-iface-top-type (honu-ast-src-stx exp)))) - - (define (honu-void-type exp) - (if (syntax? exp) - (make-honu-top-type exp) - (make-honu-top-type (honu-ast-src-stx exp)))) - - (define (honu-int-type exp) - (create-honu-prim-type exp 'int)) - (define (honu-bool-type exp) - (create-honu-prim-type exp 'bool)) - (define (honu-str-type exp) - (create-honu-prim-type exp 'str)) - (define (honu-float-type exp) - (create-honu-prim-type exp 'float)) - (define (honu-char-type exp) - (create-honu-prim-type exp 'char)) - - (define (create-honu-prim-type exp name) - (if (syntax? exp) - (make-honu-prim-type exp name) - (make-honu-prim-type (honu-ast-src-stx exp) name))) - - (provide printable-type) - (define (printable-type typ) - (match typ - [(struct honu-bottom-type (stx)) ""] - [(struct honu-top-type (stx)) "void"] - [(struct honu-iface-bottom-type (stx)) ""] - [(struct honu-iface-top-type (stx)) "Any"] - [(struct honu-iface-type (stx name)) (symbol->string (printable-key name))] - [(struct honu-prim-type (stx name)) (symbol->string name)] - [(struct honu-func-type (stx args ret)) - (if (null? args) - (string-append "[]->" (printable-type ret)) - (string-append "[" (fold-right (lambda (t s) - (string-append s ", " (printable-type t))) - (printable-type (car args)) - (cdr args)) - "]->" (printable-type ret)))] - [(struct honu-dispatch-type (stx dispatches args ret)) - (string-append "[" (fold-right (lambda (t s) - (string-append s ", " (printable-type t))) - (string-append "(" - (fold-right (lambda (t s) - (string-append s ", " (printable-type t))) - (printable-type (car dispatches)) - (cdr dispatches)) - ")") - args) - "]->" (printable-type ret))])) - - (provide/contract [raise-type-error-with-stx (honu-type? honu-type? any/c . -> . any)]) - (define (raise-type-error-with-stx t1 t2 stx) - (raise-read-error-with-stx - (format "Expected type ~a, got type ~a" - (printable-type t1) - (printable-type t2)) - stx)) - - (provide honu-type-equal? honu-iface-type-in-tenv? honu-type-in-tenv?) - - (define (honu-type-equal? t1 t2) - (cond - [(and (honu-bottom-type? t1) - (honu-bottom-type? t2)) #t] - [(and (honu-top-type? t1) - (honu-top-type? t2)) #t] - [(and (honu-iface-bottom-type? t1) - (honu-iface-bottom-type? t2)) #t] - [(and (honu-iface-top-type? t1) - (honu-iface-top-type? t2)) #t] -; [(and (honu-void-type? t1) -; (honu-void-type? t2)) #t] - [(and (honu-prim-type? t1) - (honu-prim-type? t2)) - (eqv? (honu-prim-type-name t1) - (honu-prim-type-name t2))] - [(and (honu-iface-type? t1) - (honu-iface-type? t2)) - (eq? (printable-key (honu-iface-type-name t1)) - (printable-key (honu-iface-type-name t2)))] - [(and (honu-func-type? t1) - (honu-func-type? t2)) - (and (honu-type-equal? (honu-func-type-return t1) - (honu-func-type-return t2)) - (equal? (length (honu-func-type-args t1)) - (length (honu-func-type-args t2))) - (andmap honu-type-equal? - (honu-func-type-args t1) - (honu-func-type-args t2)))] - [(and (honu-dispatch-type? t1) - (honu-dispatch-type? t2)) - (and (honu-type-equal? (honu-dispatch-type-return t1) - (honu-dispatch-type-return t2)) - (equal? (length (honu-dispatch-type-dispatches t1)) - (length (honu-dispatch-type-dispatches t2))) - (andmap honu-type-equal? - (honu-dispatch-type-dispatches t1) - (honu-dispatch-type-dispatches t2)) - (equal? (length (honu-dispatch-type-args t1)) - (length (honu-dispatch-type-args t2))) - (andmap honu-type-equal? - (honu-dispatch-type-args t1) - (honu-dispatch-type-args t2)))] - [else #f])) - - (define (honu-iface-type-in-tenv? tenv t) - (or (honu-iface-top-type? t) - (and (honu-iface-type? t) - (get-type-entry (honu-iface-type-name t) tenv)))) - - (define (honu-prim-type-in-honu? t) - (member (honu-prim-type-name t) '(int bool str float char))) - - (define (honu-func-type-in-tenv? tenv t) - (and (or (honu-top-type? (honu-func-type-return t)) ;; take care of void here - (honu-type-in-tenv? tenv (honu-func-type-return t))) - (andmap (lambda (t) - (honu-type-in-tenv? tenv t)) - (honu-func-type-args t)))) - - (define (honu-dispatch-type-in-tenv? tenv t) - (and (or (honu-top-type? (honu-dispatch-type-return t)) ;; take care of void here - (honu-type-in-tenv? tenv (honu-dispatch-type-return t))) - (andmap (lambda (t) - (honu-type-in-tenv? tenv t)) - (honu-dispatch-type-dispatches t)) - (andmap (lambda (t) - (honu-type-in-tenv? tenv t)) - (honu-dispatch-type-args t)))) - - (define (honu-type-in-tenv? tenv t) - (cond - [(honu-dispatch-type? t) (honu-dispatch-type-in-tenv? tenv t)] - [(honu-func-type? t) (honu-func-type-in-tenv? tenv t)] - [(honu-prim-type? t) (honu-prim-type-in-honu? t)] - [else (honu-iface-type-in-tenv? tenv t)])) - - (provide get-field-type get-method-type) - - (define (get-field-type tenv typ fd) - (if (honu-iface-top-type? typ) - (raise-read-error-with-stx - "The Any type has no fields." - fd)) - (if (not (honu-iface-type? typ)) - (raise-read-error-with-stx - "Attempt to get field of a type that is not an interface type." - fd)) - (let* ([type-def (get-type-entry (honu-iface-type-name typ) tenv)] - [field-decl (find (lambda (d) - (and (honu-field-decl? d) - (tenv-key=? (honu-field-decl-name d) fd))) - (tenv-type-members type-def))]) - (if field-decl - (honu-field-decl-type field-decl) - (let loop ([supers (tenv-type-supers type-def)]) - (cond - ((null? supers) #f) - ((get-field-type tenv (car supers) fd) => values) - (else (loop (cdr supers)))))))) - - (define (get-method-type tenv typ md) - (if (honu-iface-top-type? typ) - (raise-read-error-with-stx - "The Any type has no methods." - md)) - (if (not (honu-iface-type? typ)) - (raise-read-error-with-stx - "Attempt to get method of a type that is not an interface type." - md)) - (let* ([type-def (get-type-entry (honu-iface-type-name typ) tenv)] - [method-decl (find (lambda (d) - (and (honu-method-decl? d) - (tenv-key=? (honu-method-decl-name d) md))) - (tenv-type-members type-def))]) - (if method-decl - (honu-dispatch-type-from-exp - (list typ) - (honu-method-decl-arg-types method-decl) - (honu-method-decl-type method-decl) - method-decl) - (let loop ([supers (tenv-type-supers type-def)]) - (cond - ((null? supers) #f) - ((get-method-type tenv (car supers) md) => values) - (else (loop (cdr supers)))))))) - - (provide <:_P Implements_P) - - (define (Subtype_P tenv t1 t2) - (if (and (honu-iface-type? t1) - (honu-iface-type? t2)) - (let ([t1-def (get-type-entry (honu-iface-type-name t1) tenv)]) - (ormap (lambda (t) - (honu-type-equal? t t2)) - (tenv-type-supers t1-def))) - #f)) - - (define (<:_P tenv t1 t2) - (cond - [(honu-type-equal? t1 t2) #t] ; Reflexive - [(honu-bottom-type? t1) #t] ; bottom is a subtype of all - [(honu-top-type? t2) #t] ; top is a supertype of all - [(and (honu-iface-bottom-type? t1) - (or (honu-iface-top-type? t2) - (honu-iface-type? t2))) #t] ; iface bottom type <: any iface type - [(and (honu-iface-top-type? t2) - (or (honu-iface-bottom-type? t1) - (honu-iface-type? t1))) #t] ; any iface type <: iface top type - [(Subtype_P tenv t1 t2) #t] ; Direct subtype is <: - [(and (honu-iface-type? t1) - (honu-iface-type? t2)) - (let ([t1-def (get-type-entry (honu-iface-type-name t1) tenv)]) - (ormap (lambda (t) - (<:_P tenv t t2)) - (tenv-type-supers t1-def)))] - [(and (honu-func-type? t1) - (honu-func-type? t2)) - (and (<:_P tenv - (honu-func-type-return t1) - (honu-func-type-return t2)) - (equal? (length (honu-func-type-args t1)) - (length (honu-func-type-args t2))) - (andmap (lambda (at bt) - (<:_P tenv bt at)) - (honu-func-type-args t1) - (honu-func-type-args t2)))] - [(and (honu-dispatch-type? t1) - (honu-dispatch-type? t2)) - (and (<:_P tenv ;; return covariant - (honu-dispatch-type-return t1) - (honu-dispatch-type-return t2)) - (equal? (length (honu-dispatch-type-dispatches t1)) - (length (honu-dispatch-type-dispatches t2))) - (andmap (lambda (at bt) ;; dispatched args covariant - (<:_P tenv at bt)) - (honu-dispatch-type-dispatches t1) - (honu-dispatch-type-dispatches t2)) - (equal? (length (honu-dispatch-type-args t1)) - (length (honu-dispatch-type-args t2))) - (andmap (lambda (at bt) ;; non-dispatched args contravariant - (<:_P tenv bt at)) - (honu-dispatch-type-args t1) - (honu-dispatch-type-args t2)))] - [else #f])) - - (define (Implements_P tenv c t) - (let ([defn (get-class-entry c tenv)]) - (ormap (lambda (t1) - (<:_P tenv t1 t)) - (tenv-class-impls defn)))) - - (provide get-init-names-and-types) - (define (get-init-names-and-types tenv c) - (let ((defn (get-class-entry c tenv))) - (tenv-class-inits defn))) - - (provide check-init-type-for-name) - (define (check-init-type-for-name tenv inits name type) - (if (null? inits) - (raise-read-error-with-stx - "Initialization argument name not found in list of initialization field names." - name) - (let ((current (car inits))) - (if (eq? (printable-key (tenv-init-name current)) (printable-key name)) - ;; The name matches, so check the types. - (if (<:_P tenv type (tenv-init-type current)) - ;; The types matched, so we're good so far. Return the unused init args. - (cdr inits) - ;; The types didn't match, so we need to do some further checking. - (if (tenv-init-optional? current) - ;; This field had to be initialized, so this is a type error. - (raise-read-error-with-stx - "Type for initialization value does not match declared type." - name) - ;; It doesn't have to be initialized, so we assume that it was left - ;; out and continue with the rest of the list, dropping it. - (check-init-type-for-name tenv (cdr inits) name type))) - ;; The current initialization argument doesn't match, so keep checking as they - ;; can be ordered differently. - (cons current (check-init-type-for-name tenv (cdr inits) name type)))))) - - (provide get-field-names-for-type) - (define (get-field-names-for-type tenv t) - (if (honu-iface-top-type? t) '() - (let ([type-defn (get-type-entry (honu-iface-type-name t) tenv)]) - (apply append (cons (filter-map (lambda (d) - (cond - [(honu-field-decl? d) (honu-field-decl-name d)] - [else #f])) - (tenv-type-members type-defn)) - (map (lambda (t) - (get-field-names-for-type tenv t)) - (tenv-type-supers type-defn))))))) - - (provide get-method-names-for-type) - (define (get-method-names-for-type tenv t) - (if (honu-iface-top-type? t) '() - (let ([type-defn (get-type-entry (honu-iface-type-name t) tenv)]) - (apply append (cons (filter-map (lambda (d) - (cond - [(honu-method-decl? d) (honu-method-decl-name d)] - [else #f])) - (tenv-type-members type-defn)) - (map (lambda (t) - (get-method-names-for-type tenv t)) - (tenv-type-supers type-defn))))))) - - (provide get-fields-and-methods) - (define (get-fields-and-methods tenv t) - (if (honu-iface-top-type? t) '() ; Any has no inherent fields or methods. - (let ([type-defn (get-type-entry (honu-iface-type-name t) tenv)]) - (apply append - (cons (append (map (lambda (d) - (cons (honu-field-decl-name d) - (honu-field-decl-type d))) - (filter honu-field-decl? - (tenv-type-members type-defn))) - (map (lambda (d) - (cons (honu-method-decl-name d) - (honu-dispatch-type-from-exp - (list t) - (honu-method-decl-arg-types d) - (honu-method-decl-type d) - d))) - (filter honu-method-decl? - (tenv-type-members type-defn)))) - (map (lambda (t) - (get-fields-and-methods tenv t)) - (tenv-type-supers type-defn))))))) - - (define (get-function-names tenv) - (filter values - (tenv-map tenv (lambda (k v) - (if (tenv-func? v) k #f))))) - - (provide get-initial-env) - (define (get-initial-env tenv) - (let ([function-names (get-function-names tenv)]) - (fold (lambda (f e) - (let ([func-entry (get-func-entry f tenv)]) - (extend-env e - f - (honu-func-type-from-exp (tenv-func-arg-types func-entry) - (tenv-func-return-type func-entry) - (tenv-entry-src-stx func-entry))))) - (empty-env) - function-names))) - - (provide empty-env extend-env) - - (define (empty-env) (lambda (id) #f)) - - (define (extend-env env name val) - (lambda (id) - (if (eqv? (printable-key name) (printable-key id)) val (env id)))) - - ) diff --git a/collects/honu/private/typechecker/honu-typecheck-class-utils.ss b/collects/honu/private/typechecker/honu-typecheck-class-utils.ss deleted file mode 100644 index 97354ebb8d..0000000000 --- a/collects/honu/private/typechecker/honu-typecheck-class-utils.ss +++ /dev/null @@ -1,236 +0,0 @@ -(module honu-typecheck-class-utils mzscheme - - (require (lib "struct.ss") - (lib "plt-match.ss") - (lib "list.ss" "srfi" "1") - (prefix list: (lib "list.ss"))) - - (require "../../ast.ss") - (require "../../utils.ss") - (require "../../tenv.ss") - (require "honu-type-utils.ss") - (require "honu-typecheck-exp.ss") - - (require "../../read-error-with-stx.ss") - - (provide honu-typecheck-slotdefns) - (define (honu-typecheck-slotdefns tenv env cenv init-cenv defns) - (honu-typecheck-slotdefns-helper tenv env cenv init-cenv defns (list))) - - (define (honu-typecheck-slotdefns-helper tenv env cenv init-cenv defns new-defns) - (cond - [(null? defns) (values (reverse new-defns) env cenv init-cenv)] - [(honu-init-field? (car defns)) - (let-values (((new-defn new-env new-cenv new-init-cenv) - (honu-typecheck-init-field tenv env cenv init-cenv (car defns)))) - (honu-typecheck-slotdefns-helper tenv new-env new-cenv - new-init-cenv (cdr defns) (cons new-defn new-defns)))] - [(honu-field? (car defns)) - (let-values (((new-defn new-env new-cenv new-init-cenv) - (honu-typecheck-field tenv env cenv init-cenv (car defns)))) - (honu-typecheck-slotdefns-helper tenv new-env new-cenv - new-init-cenv (cdr defns) (cons new-defn new-defns)))] - [(honu-method? (car defns)) - (let loop ((mdefns (list (car defns))) - (rest-defns (cdr defns))) - (if (or (null? rest-defns) - (not (honu-method? (car rest-defns)))) - (let-values (((new-mdefns new-env new-cenv new-init-cenv) - (honu-typecheck-methods tenv env cenv init-cenv mdefns))) - (honu-typecheck-slotdefns-helper tenv new-env new-cenv new-init-cenv rest-defns - (append (reverse new-mdefns) new-defns))) - (loop (cons (car rest-defns) mdefns) (cdr rest-defns))))] - [else (raise-read-error-with-stx - "Unexpected type of slotdefn." - (honu-ast-src-stx (car defns)))])) - - (define (honu-typecheck-init-field tenv env cenv init-cenv defn) - (match-let ([(struct honu-init-field (stx name type value)) defn]) - (if (honu-type-in-tenv? tenv type) - (if value - (let-values ([(e1 t1) ((honu-typecheck-exp tenv env init-cenv) - value type)]) - (values (copy-struct honu-init-field defn - (honu-init-field-value e1)) - env - (extend-env cenv name type) - (extend-env init-cenv name type))) - (values defn env - (extend-env cenv name type) - (extend-env init-cenv name type))) - (raise-read-error-with-stx - "Type of init field not found in program." - (honu-ast-src-stx type))))) - - (define (honu-typecheck-field tenv env cenv init-cenv defn) - (match-let ([(struct honu-field (stx name type value)) defn]) - (if (honu-type-in-tenv? tenv (honu-field-type defn)) - (let-values ([(e1 t1) ((honu-typecheck-exp tenv env init-cenv) - value type)]) - (values (copy-struct honu-field defn - (honu-field-value e1)) - env - (extend-env cenv name type) - (extend-env init-cenv name type))) - (raise-read-error-with-stx - "Type of field not found in program." - (honu-ast-src-stx type))))) - - (define (honu-typecheck-methods tenv env cenv init-cenv mdefns) - (let* ((new-cenv (fold (lambda (d i) - (extend-env i (honu-method-name d) - (make-honu-dispatch-type (honu-ast-src-stx d) - (list (env #'this)) - (honu-method-arg-types d) - (honu-method-type d)))) - cenv mdefns)) - (new-init-cenv (fold (lambda (d i) - (extend-env i (honu-method-name d) - (make-honu-dispatch-type (honu-ast-src-stx d) - (list (env #'this)) - (honu-method-arg-types d) - (honu-method-type d)))) - init-cenv mdefns)) - (new-mdefns (map (lambda (d) - (honu-typecheck-method tenv env new-cenv d)) - mdefns))) - (values new-mdefns env new-cenv new-init-cenv))) - - (define (honu-typecheck-method tenv env cenv defn) - (match-let ([(struct honu-method (stx name type arg-names arg-types body)) defn]) - (if (or (honu-top-type? type) ;; we allow void only in method return types - (honu-type-in-tenv? tenv type)) - (let ([new-env (fold (lambda (n t env) - (extend-env env n t)) - env arg-names arg-types)]) - (check-arg-types tenv arg-types) ;; will raise exception if one fails - (let-values (((e1 t1) ((honu-typecheck-exp tenv new-env cenv) body (if (honu-top-type? type) #f type)))) - (if (<:_P tenv t1 type) - (copy-struct honu-method defn - (honu-method-body e1)) - (raise-read-error-with-stx - "Body of method's type does not match declared return type" - (honu-ast-src-stx body))))) - (raise-read-error-with-stx - "Return type of method does not exist in program." - (honu-ast-src-stx type))))) - - (define (check-arg-types tenv types) - (cond - [(null? types) #t] - [(not (honu-type-in-tenv? tenv (car types))) - (raise-read-error-with-stx - "Argument type of method does not exist in program." - (honu-ast-src-stx (car types)))] - [else (check-arg-types tenv (cdr types))])) - - (provide check-init-slots) - (define (check-init-slots tenv names types) - (cond - [(null? types) #t] - [(not (honu-type-in-tenv? tenv (car types))) - (raise-read-error-with-stx - (format "Type for init slot ~a does not exist in program." - (printable-key (car names))) - (honu-ast-src-stx (car types)))] - [else (check-init-slots tenv (cdr names) (cdr types))])) - - (provide check-impl-types) - (define (check-impl-types tenv types) - (cond - [(null? types) #t] - [(not (honu-iface-type-in-tenv? tenv (car types))) - (raise-read-error-with-stx - "Type in implements list does not exist in program." - (honu-ast-src-stx (car types)))] - [else (check-impl-types tenv (cdr types))])) - - (provide honu-typecheck-export) - (define (honu-typecheck-export tenv cenv expdec) - (define (check-export-name old new) - (let ((old-type (cenv old))) - (if old-type - (let ((new-type - (cond - [(honu-prim-type? old-type) - (get-field-type tenv (honu-export-type expdec) new)] - [(honu-iface-type? old-type) - (get-field-type tenv (honu-export-type expdec) new)] - [(honu-func-type? old-type) - (get-field-type tenv (honu-export-type expdec) new)] - [(honu-dispatch-type? old-type) - (get-method-type tenv (honu-export-type expdec) new)] - [else (raise-read-error-with-stx - "Unexpected class of type in check-export-name." - (honu-ast-src-stx old-type))]))) - (cond - [(not new-type) - (raise-read-error-with-stx - "Public name to be exported to not found in class/mixin type." - new)] - [(and (honu-dispatch-type? old-type) - (not (<:_P tenv old-type new-type))) - (raise-read-error-with-stx - "Method to be exported is not a subtype of the public type." - old)] - [(and (not (honu-dispatch-type? old-type)) - (not (honu-type-equal? old-type new-type))) - (raise-read-error-with-stx - "Field to be exported is not an exact type match for the public type." - old)] - [else (void)])) ; The current one checks, we won't have to alter anything. - (raise-read-error-with-stx - "Local name to be exported not found in class/mixin." - old)))) - ;; yes, in the check to make sure they're all exported, I convert to symbols and - ;; then run the sorting thing, then just use equal?. I really should make a - ;; version that tells you _WHICH_ wasn't exported. - (let ([sorted-type-fields-and-methods - (sort-names (map (lambda (p) (printable-key (car p))) - (get-fields-and-methods tenv (honu-export-type expdec))))] - [sorted-new-names (sort-names (map printable-key - (honu-export-new-names expdec)))]) - (if (not (equal? sorted-type-fields-and-methods sorted-new-names)) - (raise-read-error-with-stx - "Not all fields and methods in export type exported." - (honu-ast-src-stx expdec)))) - (for-each check-export-name - (honu-export-old-names expdec) - (honu-export-new-names expdec))) - - ;; symbol list -> symbol list (sorted) - (define (sort-names list) - (list:quicksort list - (lambda (a b) - (stringstring a) - (symbol->string b))))) - - (provide check-impls-and-exports) - (define (check-impls-and-exports tenv cenv sub-type impl-types exports) - (for-each (lambda (i) - (if (ormap (lambda (t) - (honu-type-equal? t i)) - (map honu-export-type exports)) - (void) - (raise-read-error-with-stx - "No export statement for implemented type." - (honu-ast-src-stx i)))) - impl-types) - (if (ormap (lambda (t) - (honu-type-equal? t sub-type)) - (map honu-export-type exports)) - (void) - (raise-read-error-with-stx - "No export statement for type of this." - (honu-ast-src-stx sub-type))) - (for-each (lambda (e) - (if (or (ormap (lambda (t) - (honu-type-equal? t (honu-export-type e))) - impl-types) - (honu-type-equal? sub-type (honu-export-type e))) - (honu-typecheck-export tenv cenv e) - (raise-read-error-with-stx - "Export statement for type that is not implemented or type of this." - (honu-ast-src-stx e)))) - exports)) - ) diff --git a/collects/honu/private/typechecker/honu-typecheck-class.ss b/collects/honu/private/typechecker/honu-typecheck-class.ss deleted file mode 100644 index 168288bc6e..0000000000 --- a/collects/honu/private/typechecker/honu-typecheck-class.ss +++ /dev/null @@ -1,31 +0,0 @@ -(module honu-typecheck-class mzscheme - - (require (lib "list.ss" "srfi" "1")) - (require (lib "struct.ss")) - - (require "../../ast.ss") - (require "../../utils.ss") - (require "honu-type-utils.ss") - (require "honu-typecheck-class-utils.ss") - - (provide honu-typecheck-class) - (define (honu-typecheck-class tenv cls) - (check-impl-types tenv (honu-class-impls cls)) - (check-init-slots tenv (honu-class-init-names cls) (honu-class-init-types cls)) - (let-values (((new-defns new-env new-cenv new-init-cenv) - (honu-typecheck-slotdefns tenv - (extend-env (get-initial-env tenv) #'this (honu-class-type cls)) - (empty-env) - (fold (lambda (n t e) - (extend-env e n t)) - (empty-env) - (honu-class-init-names cls) - (honu-class-init-types cls)) - (honu-class-defns cls)))) - (check-impls-and-exports tenv new-cenv - (honu-class-type cls) - (honu-class-impls cls) - (honu-class-exports cls)) - (copy-struct honu-class cls - (honu-class-defns new-defns)))) - ) diff --git a/collects/honu/private/typechecker/honu-typecheck-exp.ss b/collects/honu/private/typechecker/honu-typecheck-exp.ss deleted file mode 100644 index 4cb84b4ebe..0000000000 --- a/collects/honu/private/typechecker/honu-typecheck-exp.ss +++ /dev/null @@ -1,930 +0,0 @@ -(module honu-typecheck-exp mzscheme - - (require (lib "struct.ss") - (lib "contract.ss") - (lib "plt-match.ss") - (all-except (lib "list.ss" "srfi" "1") any)) - - (require "../../ast.ss") - (require "../../utils.ss") - (require "../../tenv.ss") - (require "honu-type-utils.ss") - (require "../../read-error-with-stx.ss") - - ;; expects a symbol syntax, returns a type for that builtin - (define (get-builtin-type stx) - (case (printable-key stx) - [(printStr) - (honu-func-type-from-exp - (list (honu-str-type stx)) - (honu-void-type stx) - stx)] - [(printLine) - (honu-func-type-from-exp - (list (honu-str-type stx)) - (honu-void-type stx) - stx)] - [(error) - (honu-func-type-from-exp - (list (honu-str-type stx)) - (honu-error-type stx) - stx)] - [(readChar) - (honu-func-type-from-exp - (list) - (honu-char-type stx) - stx)] - [(readLine) - (honu-func-type-from-exp - (list) - (honu-str-type stx) - stx)] - [(strToInt) - (honu-func-type-from-exp - (list (honu-str-type stx)) - (honu-int-type stx) - stx)] - [(strToFloat) - (honu-func-type-from-exp - (list (honu-str-type stx)) - (honu-float-type stx) - stx)] - [(intToStr) - (honu-func-type-from-exp - (list (honu-int-type stx)) - (honu-str-type stx) - stx)] - [(floatToStr) - (honu-func-type-from-exp - (list (honu-float-type stx)) - (honu-str-type stx) - stx)] - [(charToStr) - (honu-func-type-from-exp - (list (honu-char-type stx)) - (honu-str-type stx) - stx)] - [(strLen) - (honu-func-type-from-exp - (list (honu-str-type stx)) - (honu-int-type stx) - stx)] - [(substr) - (honu-func-type-from-exp - (list (honu-str-type stx) - (honu-int-type stx) - (honu-int-type stx)) - (honu-str-type stx) - stx)] - [(charAt) - (honu-func-type-from-exp - (list (honu-str-type stx) - (honu-int-type stx)) - (honu-char-type stx) - stx)] - [else #f])) - - (define (check-prim-type exp typ type-func) - (let* ([stx (honu-ast-src-stx exp)] - [new-typ (type-func stx)]) - (if (and typ (not (honu-type-equal? typ new-typ))) - (raise-type-error-with-stx typ new-typ stx) - (values exp new-typ)))) - - ;; honu-typecheck-exp : HPgm * Env * CEnv -> HExp * Typ -> HExp * Typ - ;; - ;; honu-typecheck-exp typechecks a honu expression given the honu - ;; program in which it appears along with the current local - ;; environment and class environment. Now it also takes an expected - ;; type (if one is known), so we can do some minor type inference in - ;; the case of new statements, plus give better error messages. - ;; - ;; Note that we curry the expression out to the right -- we do this - ;; because for most expressions, nothing will change except for - ;; running the typechecker recursively on subexpressions. - ;; - ;; We could likewise curry the program out to the left similarly - ;; since the program will never change for a given program (haha), - ;; but there would be better ways of handling that in either a - ;; functional and imperative style such as either having a - ;; global/parameterized "current-program" variable or by currying - ;; out to the left and then writing one function that given a - ;; program, applies the curried functions to it once, returning the - ;; partially applied functions. I should get things working before - ;; getting that silly though. -; (provide honu-typecheck-exp) - (provide/contract [honu-typecheck-exp - (tenv? - any/c - any/c - . -> . - ((honu-exp? (union false/c honu-type?)) - . ->* . - (honu-exp? honu-type?)))]) - (define (honu-typecheck-exp tenv env cenv) - (define (f exp typ) - (match exp - ;; P |- t - ;; ---------------------------- - ;; P, G, D |- null |=> null : t - ;; - ;; Since there's no easy way to do the above in this style of - ;; typechecker, we'll create a "null" type that for every - ;; type t such that P |- t, null <: t. - [(struct honu-null (stx)) - (if typ - (if (<:_P tenv (honu-null-type stx) typ) - (values exp typ) - (raise-read-error-with-stx - "Attempt to use null in a non-interface type context." - stx)) - (values exp (honu-null-type stx)))] - ;; P, G, D |- n |=> n : int - [(struct honu-int (stx n)) - (check-prim-type exp typ honu-int-type)] - ;; P, G, D |- f |=> f : float - [(struct honu-float (stx f)) - (check-prim-type exp typ honu-float-type)] - ;; P, G, D |- b |=> b : bool - [(struct honu-bool (stx b)) - (check-prim-type exp typ honu-bool-type)] - ;; P, G, D |- s |=> s : str - [(struct honu-str (stx s)) - (check-prim-type exp typ honu-str-type)] - ;; P, G, D |- c |=> c : char - [(struct honu-char (stx c)) - (check-prim-type exp typ honu-char-type)] - [(struct honu-uprim (stx op op-stx op-type body)) - (case op - [(minus) - (let-values (((e1 t1) (f body #f))) - (cond - [(honu-type-equal? t1 (honu-int-type (honu-uprim-body exp))) - (values (copy-struct honu-uprim exp - (honu-uprim-op-type t1) - (honu-uprim-body e1)) - (honu-int-type exp))] - [(honu-type-equal? t1 (honu-float-type (honu-uprim-body exp))) - (values (copy-struct honu-uprim exp - (honu-uprim-op-type t1) - (honu-uprim-body e1)) - (honu-float-type exp))] - [else - (raise-read-error-with-stx - "Unary minus takes an integer or floating point argument." - (honu-ast-src-stx (honu-uprim-body exp)))]))] - [(not) - (let-values (((e1 t1) (f body (honu-bool-type body)))) - (values (copy-struct honu-uprim exp - (honu-uprim-op-type t1) - (honu-uprim-body e1)) - (honu-bool-type exp)))] - [else (raise-read-error-with-stx - "Unknown unary primitive operation." - (honu-uprim-op-stx exp))])] - [(struct honu-prim (stx op op-stx op-type left right)) - (case (honu-prim-op exp) - ;; +, -, *, /, and % are int * int -> int operators. - ;; - ;; P, G, D |- e1 |=> e1' : int P, G, D |- e2 |=> e2' : int - ;; -------------------------------------------------------- - ;; P, G, D |- e1 op e2 |=> e1' op e2' : int - [(plus) - ;; we can just pass typ to the two sides (if it's an appropriate type) - ;; because it's always the case that + returns the same type as its - ;; operands. Similar for minus, times, divide. - (if typ - (cond - ;; this should work because we should never be passing a - ;; void type as typ (#f should be passed instead). - [(not (honu-prim-type? typ)) - (raise-read-error-with-stx - "Cannot use primitive operators in a object context." - stx)] - [(not (member (honu-prim-type-name typ) '(int float str))) - (raise-read-error-with-stx - "The result of + must be used as either an int, float, or str." - stx)])) - (let-values (((e1 t1) (f left typ)) - ((e2 t2) (f right typ))) - (cond - [typ ;; if we knew the correct context, then checking has already been done. - (values (copy-struct honu-prim exp - (honu-prim-op-type t1) - (honu-prim-left e1) - (honu-prim-right e2)) - typ)] - [(and (honu-type-equal? t1 (honu-int-type left)) - (honu-type-equal? t2 (honu-int-type right))) - (values (copy-struct honu-prim exp - (honu-prim-op-type t1) - (honu-prim-left e1) - (honu-prim-right e2)) - (honu-int-type exp))] - [(and (honu-type-equal? t1 (honu-float-type left)) - (honu-type-equal? t2 (honu-float-type right))) - (values (copy-struct honu-prim exp - (honu-prim-op-type t1) - (honu-prim-left e1) - (honu-prim-right e2)) - (honu-float-type exp))] - [(and (honu-type-equal? t1 (honu-str-type left)) - (honu-type-equal? t2 (honu-str-type right))) - (values (copy-struct honu-prim exp - (honu-prim-op-type t1) - (honu-prim-left e1) - (honu-prim-right e2)) - (honu-str-type exp))] - [else - (raise-read-error-with-stx - "Operands are of different types or an incompatible type." - stx)]))] - [(minus times div) - (if typ - (cond - [(not (honu-prim-type? typ)) - (raise-read-error-with-stx - "Cannot use primitive operators in a object context." - stx)] - [(not (member (honu-prim-type-name typ) '(int float))) - (raise-read-error-with-stx - (format "~a must be used in either an int or float context." - (case op [(minus) '-] [(times) '*] [(div) '/])) - stx)])) - (let-values (((e1 t1) (f left typ)) - ((e2 t2) (f right typ))) - (cond - [typ - (values (copy-struct honu-prim exp - (honu-prim-op-type t1) - (honu-prim-left e1) - (honu-prim-right e2)) - typ)] - [(and (honu-type-equal? t1 (honu-int-type left)) - (honu-type-equal? t2 (honu-int-type right))) - (values (copy-struct honu-prim exp - (honu-prim-op-type t1) - (honu-prim-left e1) - (honu-prim-right e2)) - (honu-int-type exp))] - [(and (honu-type-equal? t1 (honu-float-type left)) - (honu-type-equal? t2 (honu-float-type right))) - (values (copy-struct honu-prim exp - (honu-prim-op-type t1) - (honu-prim-left e1) - (honu-prim-right e2)) - (honu-float-type exp))] - [else - (raise-read-error-with-stx - "Operands are of different types or an incompatible type." - stx)]))] - [(mod) - ;; mod is only defined on ints, so check left and right side appropriately. - (let-values (((e1 t1) (f left (honu-int-type left))) - ((e2 t2) (f right (honu-int-type right)))) - ;; if we made it here, both must have been ints - (values (copy-struct honu-prim exp - (honu-prim-op-type t1) - (honu-prim-left e1) - (honu-prim-right e2)) - (honu-int-type exp)))] - [(lt le gt ge) - ;; relational operators don't tell us about their operands, so must use #f - (let-values (((e1 t1) (f left #f)) - ((e2 t2) (f right #f))) - (cond - [(and (honu-type-equal? t1 (honu-int-type left)) - (honu-type-equal? t2 (honu-int-type right))) - (values (copy-struct honu-prim exp - (honu-prim-op-type t1) - (honu-prim-left e1) - (honu-prim-right e2)) - (honu-bool-type exp))] - [(and (honu-type-equal? t1 (honu-float-type left)) - (honu-type-equal? t2 (honu-float-type right))) - (values (copy-struct honu-prim exp - (honu-prim-op-type t1) - (honu-prim-left e1) - (honu-prim-right e2)) - (honu-bool-type exp))] - [(and (honu-type-equal? t1 (honu-str-type left)) - (honu-type-equal? t2 (honu-str-type right))) - (values (copy-struct honu-prim exp - (honu-prim-op-type t1) - (honu-prim-left e1) - (honu-prim-right e2)) - (honu-bool-type exp))] - [(and (honu-type-equal? t1 (honu-char-type left)) - (honu-type-equal? t2 (honu-char-type right))) - (values (copy-struct honu-prim exp - (honu-prim-op-type t1) - (honu-prim-left e1) - (honu-prim-right e2)) - (honu-bool-type exp))] - [else - (raise-read-error-with-stx - "Types of operands do not match or are not of appropriate types." - (honu-ast-src-stx exp))]))] - ;; && and || are bool * bool -> bool operators. - ;; - ;; P, G, D |- e1 |=> e1' : bool P, G, D |- e2 |=> e2' : bool - ;; ---------------------------------------------------------- - ;; P, G, D |- e1 op e2 |=> e1' op e2' : bool - [(and or) - (if (and typ (not (honu-type-equal? typ (honu-bool-type stx)))) - (raise-type-error-with-stx typ (honu-bool-type stx) stx)) - (let-values (((e1 t1) (f left (honu-bool-type left))) - ((e2 t2) (f right (honu-bool-type right)))) - (values (copy-struct honu-prim exp - (honu-prim-op-type t1) - (honu-prim-left e1) - (honu-prim-right e2)) - (honu-bool-type exp)))] - ;; For now we just have that the operands to an equality - ;; operator can be of any type and that the types of the - ;; operands do not need to be equal. Might it be the - ;; case that we want to check if we're comparing two - ;; primitives and reject if they're not the same type? - ;; - ;; Yes, and so we do below. - ;; - ;; (old type rule) - ;; == is a 'a * 'b -> bool operator. - ;; - ;; P, G, D |- e1 |=> e1' : t1 P, G, D |- e2 |=> e2' : t2 - ;; -------------------------------------------------------- - ;; P, G, D |- e1 == e2 |=> e1' == e2' : bool - [(neq equal) - (if (and typ (not (honu-type-equal? typ (honu-bool-type stx)))) - (raise-type-error-with-stx typ (honu-bool-type stx) stx)) - ;; there's no telling what the operands should be here. - (let-values (((e1 t1) (f left #f)) - ((e2 t2) (f right #f))) - (cond - [(and (<:_P tenv t1 (honu-any-type left)) - (<:_P tenv t2 (honu-any-type right))) - (values (copy-struct honu-prim exp - (honu-prim-op-type (honu-any-type left)) - (honu-prim-left e1) - (honu-prim-right e2)) - (honu-bool-type exp))] - [(honu-type-equal? t1 t2) - (values (copy-struct honu-prim exp - (honu-prim-op-type t1) - (honu-prim-left e1) - (honu-prim-right e2)) - (honu-bool-type exp))] - [else (raise-read-error-with-stx - "Attempt to check two unrelated types for (in)equality." - stx)]))] - [(clseq) - (if (and typ (not (honu-type-equal? typ (honu-bool-type stx)))) - (raise-type-error-with-stx typ (honu-bool-type stx) stx)) - ;; here at least we know they should be class types. - (let-values (((e1 t1) (f left (honu-any-type left))) - ((e2 t2) (f right (honu-any-type right)))) - (values (copy-struct honu-prim exp - (honu-prim-op-type (honu-any-type left)) - (honu-prim-left e1) - (honu-prim-right e2)) - (honu-bool-type exp)))] - [else (raise-read-error-with-stx - "Unknown binary primitive operation." - op-stx)])] - [(struct honu-lambda (stx arg-names arg-types body)) - (cond - [(not typ) - (let ([env (fold (lambda (n t e) - (extend-env e n t)) - env arg-names arg-types)]) - (let-values (((e1 t1) ((honu-typecheck-exp tenv env cenv) body #f))) - (values (copy-struct honu-lambda exp - (honu-lambda-body e1)) - (honu-func-type-from-exp (honu-lambda-arg-types exp) t1 exp))))] - ;; if typ is not #f, then it should be a func type, and the return - ;; type of the func should be the same as the lambda body. - [else - (if (and typ (not (honu-func-type? typ))) - (raise-read-error-with-stx - "Found lambda in non-function type context." - stx)) - (let ([typ-args (honu-func-type-args typ)] - [typ-ret (honu-func-type-return typ)]) - (if (not (= (length typ-args) - (length arg-types))) - (raise-read-error-with-stx - "Number of arguments in lambda do not match number of arguments expected." - stx)) - ;; for a function to be a subtype, its arguments must be - ;; supertypes - (for-each (lambda (t1 t2) - (if (not (<:_P tenv t2 t1)) - (raise-read-error-with-stx - (format "Type ~a is not a supertype of ~a" - (printable-type t1) - (printable-type t2)) - (honu-ast-src-stx t1)))) - arg-types typ-args) - (let ([env (fold (lambda (n t e) - (extend-env e n t)) - env arg-names arg-types)]) - ;; we'll use typ-ret as the expected type for the body - (let-values (((e1 t1) ((honu-typecheck-exp tenv env cenv) body typ-ret))) - (values (copy-struct honu-lambda exp - (honu-lambda-body e1)) - (honu-func-type-from-exp arg-types t1 exp)))))])] - [(struct honu-facc (stx obj elab field)) - (if (eqv? obj 'my) - ;; D(fd) = t - ;; ------------------------------ - ;; P, G, D |- my.fd |=> my.fd : t - (let ([cenv-typ (cenv field)]) - (if cenv-typ - (if (and typ (not (<:_P tenv cenv-typ typ))) - (raise-type-error-with-stx typ cenv-typ stx) - (values exp cenv-typ)) - (if (env #'this) - ;; We're inside a class or mixin, so this is just an invalid name. - ;; We do also have the extra case that if we're inside a method, this - ;; may have been an init field's name (which are not contained in the - ;; class environment passed to honu-typecheck-exp for method bodies). - (raise-read-error-with-stx - "No local field with this name or attempt to use init field in method." - field) - (raise-read-error-with-stx - "Attempt to use static field access outside of class or mixin body." - stx)))) - ;; P, G, D |- e |=> e' : t' in t' - ;; --------------------------------------- - ;; P, G, D |- e.fd |=> e'.fd : t - (let-values (((e1 t1) (f obj (honu-any-type obj)))) - (let ((field-type (get-field-type tenv t1 field))) - (if field-type - (if (and typ (not (<:_P tenv field-type typ))) - (raise-type-error-with-stx typ field-type stx) - (values (copy-struct honu-facc exp - ;; Make sure to elaborate the type - (honu-facc-elab t1) - (honu-facc-obj e1)) - field-type)) - (raise-read-error-with-stx - "Field not found in type of object." - (honu-facc-field exp))))))] - [(struct honu-fassn (stx obj elab field rhs)) - (if (and typ (not (honu-type-equal? typ (honu-void-type stx)))) - (raise-read-error-with-stx - "Assignment used in non-void context." - stx)) - (if (eqv? obj 'my) - ;; D(fd) = t P, G, D |- e |=> e' : t' t' <: t - ;; -------------------------------------------- - ;; P, G, D |- my.fd = e |=> my.fd = e' : void - (let ([cenv-typ (cenv field)]) - (if cenv-typ - (let-values (((e2 t2) (f rhs cenv-typ))) - (values (copy-struct honu-fassn exp - (honu-fassn-rhs e2)) - (honu-void-type exp))) - (if (env #'this) - ;; We're inside a class or mixin, so this is just an invalid name. - ;; We do also have the extra case that if we're inside a method, this - ;; may have been an init field's name (which are not contained in the - ;; class environment passed to honu-typecheck-exp for method bodies). - (raise-read-error-with-stx - "No local field with this name or attempt to use init field in method." - field) - (raise-read-error-with-stx - "Attempt to use static field assignment outside of class or mixin body." - stx)))) - ;; P, G, D |- e1 |=> e1' : t' in t' - ;; P, G, D |- e2 |=> e2' : t'' t'' <: t - ;; ----------------------------------------------- - ;; P, G, D |- e1.fd = e2 |=> e1'.fd = e2' : void - (let-values (((e1 t1) (f obj (honu-any-type obj)))) - (let ((field-type (get-field-type tenv t1 field))) - (if field-type - (let-values (((e2 t2) (f rhs field-type))) - (values (copy-struct honu-fassn exp - (honu-fassn-obj e1) - ;; Make sure to elaborate the type - (honu-fassn-elab t1) - (honu-fassn-rhs e2)) - (honu-void-type exp))) - (raise-read-error-with-stx - "Field not found in type of object." - field)))))] - [(struct honu-mcall (stx obj elab method args)) - ;; FIXME : need to change to use typ appropriately! - - ;; We need the arg elaborations and types no matter what, so... - (let-values ([(new-args new-types) - ;; obviously eventually we'll want to use the - ;; real method arg types instead of the map below. - (map-two-values f args (map (lambda (_) #f) args))]) - (if (eqv? (honu-mcall-obj exp) 'my) - ;; D(md) = t_1 ... t_n -> t - ;; P, G, D |- e_i |=> e_i' : t_i' t_i' <: t_i (NOT t_i <: t_i') - ;; -------------------------------------------- - ;; P, G, D |- my.md(e_1, ..., e_n) |=> - ;; my'.md(e_1', ..., e_n') : t - (if (cenv (honu-mcall-method exp)) - (let ((method-type (cenv (honu-mcall-method exp)))) - (if method-type - (let loop ((n 0) - (dec-types (honu-dispatch-type-args method-type)) - (calc-types new-types)) - (cond - ((null? dec-types) - (if (null? calc-types) - ;; We reached the end of both lists, so return - ;; the new expression and the return type. - (values (copy-struct honu-mcall exp - (honu-mcall-args new-args)) - (honu-dispatch-type-return method-type)) - ;; calc-types isn't null, so too many arguments - ;; were given in the mcall expression. - (raise-read-error-with-stx - "Too many arguments for method." - (honu-ast-src-stx exp)))) - ;; dec-types isn't null, so we have too few arguments. - ((null? calc-types) - (raise-read-error-with-stx - "Not enough arguments for method." - (honu-ast-src-stx exp))) - ;; t_i' <: t_i, so check the next one. - ((<:_P tenv (car calc-types) (car dec-types)) - (loop (+ n 1) (cdr dec-types) (cdr calc-types))) - ;; t_i was _not_ <: t_i', so blame the appropriate - ;; expression. - (else - (raise-read-error-with-stx - "Argument type is not subtype of declared type." - (honu-ast-src-stx (list-ref (honu-mcall-args exp) n)))))) - ;; method-type was #f, so it couldn't be found in D. - (raise-read-error-with-stx - "Method not found in current class or mixin." - (honu-mcall-method exp)))) - (if (env 'this) - (raise-read-error-with-stx - "No local method with this name." - (honu-mcall-method exp)) - (raise-read-error-with-stx - "Attempt to use static method call outside of class or mixin body." - (honu-ast-src-stx exp)))) - ;; P, G, D |- e |=> e' : t' t> in t' - ;; P, G, D |- e_i |=> e_i' : t_i' t_i' <: t_i (NOT t_i <: t_i') - ;; ------------------------------------------------------ - ;; P, G, D |- e.md(e_1, ..., e_n) |=> - ;; e'.md(e_1', ..., e_n') : t - (let-values (((e0 t0) (f obj (honu-any-type obj)))) - (let ((method-type (get-method-type tenv t0 - (honu-mcall-method exp)))) - (if method-type - (let loop ((n 0) - (dec-types (honu-dispatch-type-args method-type)) - (calc-types new-types)) - (cond - ((null? dec-types) - (if (null? calc-types) - ;; We reached the end of both lists, so return - ;; the new expression and the return type. - (values (copy-struct honu-mcall exp - (honu-mcall-obj e0) - (honu-mcall-elab t0) - (honu-mcall-args new-args)) - (honu-dispatch-type-return method-type)) - ;; calc-types isn't null, so too many arguments - ;; were given in the mcall expression. - (raise-read-error-with-stx - "Too many arguments for method." - (honu-ast-src-stx exp)))) - ;; dec-types isn't null, so we have too few arguments. - ((null? calc-types) - (raise-read-error-with-stx - "Not enough arguments for method." - (honu-ast-src-stx exp))) - ;; t_i' <: t_i, so check the next one. - ((<:_P tenv (car calc-types) (car dec-types)) - (loop (+ n 1) (cdr dec-types) (cdr calc-types))) - ;; t_i was _not_ <: t_i', so blame the appropriate - ;; expression. - (else - (raise-read-error-with-stx - "Argument type is not subtype of declared type." - (honu-ast-src-stx (list-ref (honu-mcall-args exp) n)))))) - ;; method-type was #f, so it couldn't be found in t1. - (raise-read-error-with-stx - "Method not found in type of object." - (honu-mcall-method exp)))))))] - ;; P, G, D |- id |=> id : G(id) - [(struct honu-var (stx name builtin?)) - (cond - [(env name) - => - (lambda (t) - (if (and typ (not (<:_P tenv t typ))) - (raise-type-error-with-stx typ t stx) - (values exp t)))] - [(get-builtin-type name) - => - (lambda (t) - (if (and typ (not (<:_P tenv t typ))) - (raise-type-error-with-stx typ t stx) - (values (copy-struct honu-var exp - (honu-var-builtin? #t)) - t)))] - [else (raise-read-error-with-stx - "Variable not bound in local environment." - name)])] - ;; E(id) = t P, G, D |- e |=> e' : t' t' <: t - ;; ---------------------------------------------- - ;; P, G, D |- id = e |=> id = e' : void - [(struct honu-assn (stx name rhs)) - (if (and typ (not (honu-type-equal? typ (honu-void-type stx)))) - (raise-read-error-with-stx - "Assignment found in non-void context." - stx)) - (let ((var-type (env (honu-assn-name exp)))) - (if (not var-type) - (raise-read-error-with-stx - "Variable not bound in local environment." - name) - (let-values (((e1 t1) (f rhs var-type))) - (values (copy-struct honu-assn exp - (honu-assn-rhs e1)) - (honu-void-type exp)))))] - [(struct honu-call (stx name args builtin?)) - (cond - [(env name) - => - (lambda (t) - (honu-typecheck-call tenv f exp t typ #f))] - [(get-builtin-type name) - => - (lambda (t) - (honu-typecheck-call tenv f exp t typ #t))] - [else - (raise-read-error-with-stx - (format "Function ~a not found" (printable-key name)) - name)])] - ;; P, G, D |- this |=> this : G(this) - [(struct honu-this (stx)) - (let ([this-type (env #'this)]) - (if this-type - (if (and typ (not (<:_P tenv this-type typ))) - (raise-type-error-with-stx typ this-type stx) - (values exp this-type)) - (raise-read-error-with-stx - "Use of this outside of a class or mixin body." - stx)))] - ;; P, G, D |- e1 |=> e1' : t' P |- t - ;; --------------------------------------- - ;; P, G, D |- cast e1 t |=> cast e1' t : t - ;; - ;; Note that we don't check for primitive types (fuller - ;; explanation under isa below), and also we don't do any - ;; checking of how t' relates to t -- that's not the point - ;; of a cast. At runtime it will be checked that the object - ;; that e1 results in is of a class that implements t. - [(struct honu-cast (stx obj type)) - ;; since we're casting, object can be of any (interface) type - (let-values (((e1 t1) (f obj (honu-any-type obj)))) - (if (honu-iface-type-in-tenv? tenv type) - (values (copy-struct honu-cast exp - (honu-cast-obj e1)) - (honu-cast-type exp)) - (raise-read-error-with-stx - "Attempt to cast to invalid type." - (honu-ast-src-stx type))))] - ;; P, G, D |- e1 |=> e1' : t' P |- t - ;; ---------------------------------------- - ;; P, G, D |- e1 isa t |=> e1' isa t : bool - ;; - ;; Note that we don't check to see if e1's type is a primitive - ;; type and fail with an appropriate message if so. How - ;; primitive do we want to treat primitives? Might they stay - ;; "primitives", or might they eventually be changed into - ;; classes? - [(struct honu-isa (stx obj type)) - ;; since we're checking isa, the object can be any (interface) stype - (let-values (((e1 t1) (f obj (honu-any-type obj)))) - (if (honu-iface-type-in-tenv? tenv type) - (values (copy-struct honu-isa exp - (honu-isa-obj e1)) - (honu-bool-type exp)) - (raise-read-error-with-stx - "Attempt to check isa against invalid type." - (honu-ast-src-stx type))))] - ;; P, G, D |- e0 |=> e0' : bool P, G, D |- e1 |=> e1' : t - ;; P, G, D |- e2 |=> e2' : t - ;; ------------------------------------------------------- - ;; P, G, D |- if e0 then e1 else e2 |=> - ;; if e0' then e1' else e2' : t - ;; - ;; We can make this a weaker rule by only requiring either - ;; a) t1 <: t2; or - ;; b) t2 <: t1 - ;; and returning the supertype as the type of the if expression. - ;; Would this cause any problems (other than complicating the - ;; type rule/code)? - [(struct honu-if (stx test true false)) - (let-values (((e0 t0) (f test (honu-bool-type test))) - ((e1 t1) (f true typ)) - ((e2 t2) (f false typ))) - (cond - [(<:_P tenv t1 t2) - (values (copy-struct honu-if exp - (honu-if-cond e0) - (honu-if-true e1) - (honu-if-false e2)) - t2)] - [(<:_P tenv t2 t1) - (values (copy-struct honu-if exp - (honu-if-cond e0) - (honu-if-true e1) - (honu-if-false e2)) - t1)] - [else - (raise-read-error-with-stx - "Branches of if expression are of unrelated types." - stx)]))] - [(struct honu-while (stx cond body)) - (let-values (((e1 t1) (f cond (honu-bool-type cond))) - ((e2 t2) (f body #f))) - (values (copy-struct honu-while exp - (honu-while-cond e1) - (honu-while-body e2)) - (honu-void-type exp)))] - ;; P, G, D |- e_i |=> e_i' : t_i c [= t - ;; each init arg corresponding to id_i has type t_i' where - ;; t_i <: t_i' - ;; -------------------------------------------------------- - ;; P, G, D |- new c : t (id_1 = e_1, ..., id_n = e_n) |=> - ;; new c : t (id_1 = e_1', ..., id_n = e_n') : t - ;; - [(struct honu-new (stx class type arg-names arg-vals)) - (cond - [(and typ type (not (<:_P tenv type typ))) - (raise-type-error-with-stx typ type stx)] - [(not (get-class-entry class tenv)) - (raise-read-error-with-stx - "Undefined class" - class)] - [(and type (not (honu-iface-type-in-tenv? tenv type))) - (raise-read-error-with-stx - "Undefined type or non-interface type" - (honu-ast-src-stx type))] - [(and (not type) (not typ)) - (raise-read-error-with-stx - "Type to create in new statement needs to be explicitly stated." - stx)] - ;; if there was no explicit type given... - [(not type) - (if (Implements_P tenv class typ) - (let-values ([(new-args new-types) - (map-two-values f arg-vals (map (lambda (_) #f) arg-vals))]) - (let ((remainder (fold (lambda (n t i) - (check-init-type-for-name tenv i n t)) - (get-init-names-and-types tenv class) - (honu-new-arg-names exp) - new-types))) - (if (or (null? remainder) - (not (ormap tenv-init-optional? remainder))) ; checks to see if all optional - (values (copy-struct honu-new exp - (honu-new-type typ) - (honu-new-arg-vals new-args)) - typ) - (raise-read-error-with-stx - "Too few initialization arguments in new expression." - stx)))) - (raise-read-error-with-stx - (format "Class for new expression does not implement type ~a." - (printable-type typ)) - stx))] - ;; FIXME: still need to do appropriate things with typ in here - [type - (if (Implements_P tenv class type) - (let-values ([(new-args new-types) - (map-two-values f arg-vals (map (lambda (_) #f) arg-vals))]) - (let ((remainder (fold (lambda (n t i) - (check-init-type-for-name tenv i n t)) - (get-init-names-and-types tenv class) - (honu-new-arg-names exp) - new-types))) - (if (or (null? remainder) - (not (ormap tenv-init-optional? remainder))) ; checks to see if all optional - (values (copy-struct honu-new exp - (honu-new-arg-vals new-args)) - (honu-new-type exp)) - (raise-read-error-with-stx - "Too few initialization arguments in new expression." - stx)))) - (raise-read-error-with-stx - "Class for new expression does not implement type in new expression." - stx))])] - ;; P, G_i, D |- tid_i id_i = rhs_i |=> tid_i id_i = rhs_i', G_(i+1) - ;; P, G_(m+1), D |- e_i |=> e_i' : t_i - ;; ---------------------------------------------------------------- - ;; P, G_0, D |- { tid_0 id_0 = rhs_0; ...; tid_m id_m = rhs_m; - ;; e_0; ...; e_n; } |=> - ;; { tid_0 id_0 = rhs_0'; ...; tid_m id_m = rhs_m'; - ;; e_0'; ...; e_n'; } : t_n - [(struct honu-block (stx binds exps)) - (let*-values ([(new-bind-f) (honu-typecheck-binding tenv cenv)] - [(new-binds new-env) - (map-and-fold new-bind-f env binds)] - [(new-f) (honu-typecheck-exp tenv new-env cenv)] - [(new-exps last-type) - (let loop ([exps exps] - [new-exps '()] - [new-types '()]) - ;; we know we must have at least one expression, - ;; so here's our base case. - (if (null? (cdr exps)) - ;; type of last expression should fit block context. - (let-values ([(e1 t1) (new-f (car exps) typ)]) - (values (reverse (cons e1 new-exps)) - ;; just need the last expression's type - t1)) - ;; since we don't care about the types of any but the - ;; last expression in a block, just pass in #f - (let-values ([(e1 t1) (new-f (car exps) #f)]) - (loop (cdr exps) - (cons e1 new-exps) - (cons t1 new-types)))))]) - (values (copy-struct honu-block exp - (honu-block-binds new-binds) - (honu-block-exps new-exps)) - last-type))] - ;; P, G, D |- e |=> e' : t - ;; ------------------------------------- - ;; P, G, D |- return e |=> return e' : t - [(struct honu-return (stx body)) - (if body - (let-values ([(e1 t1) (f body typ)]) - (values (copy-struct honu-return exp - (honu-return-body e1)) - t1)) - (if typ - (raise-read-error-with-stx - "Found void return in non-void context" - stx) - (values exp (honu-void-type exp))))] - [else - (raise-read-error-with-stx - "Unexpected type of Honu expression." - (honu-ast-src-stx exp))])) - f) - - ;; P, G, D |- rhs |=> rhs' : t' t' <: t - ;; -------------------------------------------------- - ;; P, G, D |- t id = rhs |=> t id = rhs', G[id |-> t] -; (provide honu-typecheck-binding) - (provide/contract [honu-typecheck-binding - (tenv? - any/c - . -> . - ((honu-binding? any/c) - . ->* . - (honu-binding? any/c)))]) - (define (honu-typecheck-binding tenv cenv) - (lambda (bind env) - (match-let ([(struct honu-binding (ast name type rhs)) bind]) - (let-values (((e1 t1) ((honu-typecheck-exp tenv env cenv) rhs type))) - (values (copy-struct honu-binding bind - (honu-binding-rhs e1)) - (extend-env env name type)))))) - - (define (honu-typecheck-call tenv f exp t typ builtin?) - (match-let ([(struct honu-call (stx name args builtin?)) exp]) - (if (not (honu-func-type? t)) - (raise-read-error-with-stx - "Expression is not a function." - name)) - (if (and typ (not (<:_P tenv (honu-func-type-return t) typ))) - (raise-type-error-with-stx typ (honu-func-type-return t) stx)) - (let-values ([(arg-exps arg-types) - (map-two-values (lambda (e t) (f e t)) - args (honu-func-type-args t))]) - (let ([formals-length (length (honu-func-type-args t))] - [actuals-length (length arg-types)]) - (cond - [(< formals-length actuals-length) - (raise-read-error-with-stx - (format "~a function got ~a more argument~a than expected" - (if builtin? "Built-in" "Declared") - (- actuals-length formals-length) - (if (= (- actuals-length formals-length) 1) "" "s")) - stx)] - [(> formals-length actuals-length) - (raise-read-error-with-stx - (format "~a function got ~a fewer argument~a than expected" - (if builtin? "Built-in" "Declared") - (- formals-length actuals-length) - (if (= (- formals-length actuals-length) 1) "" "s")) - stx)] - [else (values (copy-struct honu-call exp - (honu-call-args arg-exps) - (honu-call-builtin? builtin?)) - (honu-func-type-return t))]))))) - ) diff --git a/collects/honu/private/typechecker/honu-typecheck-function.ss b/collects/honu/private/typechecker/honu-typecheck-function.ss deleted file mode 100644 index 7bd8a97937..0000000000 --- a/collects/honu/private/typechecker/honu-typecheck-function.ss +++ /dev/null @@ -1,26 +0,0 @@ -(module honu-typecheck-function mzscheme - (require (lib "struct.ss") - (lib "plt-match.ss") - (lib "list.ss" "srfi" "1")) - - (require "../../ast.ss") - (require "honu-type-utils.ss") - (require "honu-typecheck-exp.ss") - (require "../../read-error-with-stx.ss") - - (provide honu-typecheck-function) - (define (honu-typecheck-function tenv defn) - (match-let ([(struct honu-function (stx name type arg-names arg-types body)) defn]) - (let ((env (fold (lambda (n t e) - (extend-env e n t)) - (get-initial-env tenv) - arg-names - arg-types))) - (let-values ([(e1 t1) ((honu-typecheck-exp tenv env (empty-env)) body (if (honu-top-type? type) #f type))]) - (if (<:_P tenv t1 type) - (copy-struct honu-function defn - (honu-function-body e1)) - (raise-read-error-with-stx - "Body of function's type does not match declared return type" - (honu-ast-src-stx body))))))) - ) diff --git a/collects/honu/private/typechecker/honu-typecheck-mixin.ss b/collects/honu/private/typechecker/honu-typecheck-mixin.ss deleted file mode 100644 index f601daa1e3..0000000000 --- a/collects/honu/private/typechecker/honu-typecheck-mixin.ss +++ /dev/null @@ -1,98 +0,0 @@ -(module honu-typecheck-mixin mzscheme - - (require (lib "list.ss" "srfi" "1") - (prefix list: (lib "list.ss")) - (lib "struct.ss")) - - (require "../../ast.ss") - (require "../../utils.ss") - (require "../../tenv.ss") - (require "honu-type-utils.ss") - (require "honu-typecheck-class-utils.ss") - (require "honu-typecheck-exp.ss") - - (require "../../read-error-with-stx.ss") - - (provide honu-typecheck-mixin) - (define (honu-typecheck-mixin tenv mixin) - (if (not (honu-iface-type-in-tenv? tenv (honu-mixin-type mixin))) - (raise-read-error-with-stx - "Type of this within mixin not defined in program." - (honu-ast-src-stx (honu-mixin-type mixin)))) - (if (not (honu-iface-type-in-tenv? tenv (honu-mixin-arg-type mixin))) - (raise-read-error-with-stx - "Type mixin takes as argument not defined in program." - (honu-ast-src-stx (honu-mixin-type mixin)))) - (if (not (<:_P tenv (honu-mixin-type mixin) (honu-mixin-arg-type mixin))) - (raise-read-error-with-stx - "Type of this within mixin not subtype of argument class." - (honu-ast-src-stx (honu-mixin-type mixin)))) - (check-impl-types tenv (honu-mixin-impls mixin)) - (check-init-slots tenv (honu-mixin-init-names mixin) (honu-mixin-init-types mixin)) - (let*-values (((new-befores new-env new-cenv new-init-cenv) - (honu-typecheck-slotdefns tenv - (extend-env (get-initial-env tenv) #'this (honu-mixin-type mixin)) - (empty-env) - (fold (lambda (n t e) - (extend-env e n t)) - (empty-env) - (honu-mixin-init-names mixin) - (honu-mixin-init-types mixin)) - (honu-mixin-defns-before mixin))) - ((new-super-new) - (honu-typecheck-super-new tenv new-env new-cenv new-init-cenv - (honu-mixin-super-new mixin) - (honu-mixin-with-names mixin) - (honu-mixin-with-types mixin))) - ((new-cenv new-init-cenv) - (extend-cenvs new-cenv new-init-cenv - (get-fields-and-methods tenv (honu-mixin-arg-type mixin)))) - ((new-afters new-env new-cenv new-init-cenv) - (honu-typecheck-slotdefns tenv new-env new-cenv new-init-cenv - (honu-mixin-defns-after mixin)))) - (check-impls-and-exports tenv new-cenv - (honu-mixin-type mixin) - (honu-mixin-impls mixin) - (honu-mixin-exports mixin)) - (copy-struct honu-mixin mixin - (honu-mixin-defns-before new-befores) - (honu-mixin-super-new new-super-new) - (honu-mixin-defns-after new-afters)))) - - (define (sort-by-names names vals) - (let ((sorted (list:quicksort (map cons names vals) - (lambda (a b) - (stringstring (printable-key (car a))) - (symbol->string (printable-key (car b)))))))) - (values (map car sorted) (map cdr sorted)))) - - (define (honu-typecheck-super-new tenv env cenv init-cenv snew with-names with-types) - (let-values (((arg-names arg-vals) - (sort-by-names (honu-super-new-arg-names snew) - (honu-super-new-arg-vals snew))) - ((with-names with-types) - (sort-by-names with-names with-types))) - (begin - (if (not (andmap tenv-key=? arg-names with-names)) - (raise-read-error-with-stx - "Arguments to super_new do not match declared names in with clause." - (honu-ast-src-stx snew))) - (copy-struct honu-super-new snew - (honu-super-new-arg-vals - (map (lambda (dec-type val) - (let-values (((e1 t1) - ((honu-typecheck-exp tenv env init-cenv) val))) - (if (<:_P tenv t1 dec-type) - e1 - (raise-read-error-with-stx - "Argument to super_new does not match declared type for name." - (honu-ast-src-stx val))))) - with-types arg-vals)))))) - - (define (extend-cenvs cenv init-cenv new-stuff) - (if (null? new-stuff) - (values cenv init-cenv) - (extend-cenvs (extend-env cenv (caar new-stuff) (cdar new-stuff)) - (extend-env init-cenv (caar new-stuff) (cdar new-stuff)) - (cdr new-stuff)))) - ) diff --git a/collects/honu/private/typechecker/honu-typecheck-postchecks.ss b/collects/honu/private/typechecker/honu-typecheck-postchecks.ss deleted file mode 100644 index 4c2dbcfed0..0000000000 --- a/collects/honu/private/typechecker/honu-typecheck-postchecks.ss +++ /dev/null @@ -1,93 +0,0 @@ -(module honu-typecheck-postchecks mzscheme - - (require "../../ast.ss") - (require "honu-type-utils.ss") - (require "../../read-error-with-stx.ss") - - (provide check-type-elaborations) - (define (check-type-elaborations ast) - (cond - [(honu-program? ast) - (for-each check-type-elaborations (honu-program-defns ast))] - - [(honu-type-defn? ast) (void)] - [(honu-class? ast) - (for-each check-type-elaborations (honu-class-defns ast))] - [(honu-mixin? ast) - (for-each check-type-elaborations (honu-mixin-defns-before ast)) - (check-type-elaborations (honu-mixin-super-new ast)) - (for-each check-type-elaborations (honu-mixin-defns-after ast))] - [(honu-subclass? ast) (void)] - - [(honu-init-field? ast) - (if (honu-init-field-value ast) - (check-type-elaborations (honu-init-field-value ast)))] - [(honu-field? ast) - (check-type-elaborations (honu-field-value ast))] - [(honu-method? ast) - (check-type-elaborations (honu-method-body ast))] - - [(honu-super-new? ast) - (for-each check-type-elaborations (honu-super-new-arg-vals ast))] - - [(honu-null? ast) (void)] - [(honu-int? ast) (void)] - [(honu-float? ast) (void)] - [(honu-bool? ast) (void)] - [(honu-char? ast) (void)] - [(honu-str? ast) (void)] - [(honu-prim? ast) - (check-type-elaborations (honu-prim-left ast)) - (check-type-elaborations (honu-prim-right ast))] - [(honu-facc? ast) - (if (not (eqv? (honu-facc-obj ast) 'my)) - (begin - (check-type-elaborations (honu-facc-obj ast)) - (if (not (honu-iface-type? (honu-facc-elab ast))) - (raise-read-error-with-stx - "Found a non-static field access without a type elaboration." - (honu-ast-src-stx ast)))))] - [(honu-fassn? ast) - (if (not (eqv? (honu-fassn-obj ast) 'my)) - (begin - (check-type-elaborations (honu-fassn-obj ast)) - (if (not (honu-iface-type? (honu-fassn-elab ast))) - (raise-read-error-with-stx - "Found a non-static field assignment without a type elaboration." - (honu-ast-src-stx ast))))) - (check-type-elaborations (honu-fassn-rhs ast))] - [(honu-mcall? ast) - (if (not (eqv? (honu-mcall-obj ast) 'my)) - (begin - (check-type-elaborations (honu-mcall-obj ast)) - (if (not (honu-iface-type? (honu-mcall-elab ast))) - (raise-read-error-with-stx - "Found non-static method call without a type elaboration." - (honu-ast-src-stx ast))))) - (for-each check-type-elaborations (honu-mcall-args ast))] - [(honu-var? ast) (void)] - [(honu-assn? ast) - (check-type-elaborations (honu-assn-rhs ast))] - [(honu-call? ast) - (for-each check-type-elaborations (honu-call-args ast))] - [(honu-this? ast) (void)] - [(honu-cast? ast) - (check-type-elaborations (honu-cast-obj ast))] - [(honu-isa? ast) - (check-type-elaborations (honu-isa-obj ast))] - [(honu-if? ast) - (check-type-elaborations (honu-if-cond ast)) - (check-type-elaborations (honu-if-true ast)) - (check-type-elaborations (honu-if-false ast))] - [(honu-new? ast) - (for-each check-type-elaborations (honu-new-arg-vals ast))] - [(honu-block? ast) - (for-each check-type-elaborations (honu-block-binds ast)) - (for-each check-type-elaborations (honu-block-exps ast))] - [(honu-return? ast) - (check-type-elaborations (honu-return-body ast))] - - [(honu-binding? ast) - (check-type-elaborations (honu-binding-rhs ast))])) - - ) diff --git a/collects/honu/private/typechecker/honu-typecheck-prechecks.ss b/collects/honu/private/typechecker/honu-typecheck-prechecks.ss deleted file mode 100644 index 0abd9b465e..0000000000 --- a/collects/honu/private/typechecker/honu-typecheck-prechecks.ss +++ /dev/null @@ -1,88 +0,0 @@ -(module honu-typecheck-prechecks mzscheme - - (require (lib "list.ss" "srfi" "1")) - (require "../../ast.ss") - (require "../../read-error-with-stx.ss") - - (provide check-uses-of-this) - (define (check-uses-of-this ast) - (cond - [(honu-program? ast) - (for-each check-uses-of-this (honu-program-defns ast))] - - [(honu-type-defn? ast) (void)] - [(honu-class? ast) - (for-each check-uses-of-this (honu-class-defns ast))] - [(honu-mixin? ast) - (for-each check-uses-of-this (honu-mixin-defns-before ast)) - (check-uses-of-this (honu-mixin-super-new ast)) - (for-each check-uses-of-this (honu-mixin-defns-after ast))] - [(honu-subclass? ast) (void)] - - [(honu-init-field? ast) - (if (honu-init-field-value ast) - (check-uses-of-this (honu-init-field-value ast)))] - [(honu-field? ast) - (check-uses-of-this (honu-field-value ast))] - [(honu-method? ast) - (check-uses-of-this (honu-method-body ast))] - - [(honu-super-new? ast) - (for-each check-uses-of-this (honu-super-new-arg-vals ast))] - - [(honu-null? ast) (void)] - [(honu-int? ast) (void)] - [(honu-float? ast) (void)] - [(honu-bool? ast) (void)] - [(honu-char? ast) (void)] - [(honu-str? ast) (void)] - [(honu-prim? ast) - (check-uses-of-this (honu-prim-left ast)) - (check-uses-of-this (honu-prim-right ast))] - [(honu-facc? ast) - (if (and (not (eqv? (honu-facc-obj ast) 'my)) - (not (honu-this? (honu-facc-obj ast)))) ; this on the left side of a dot is okay - (check-uses-of-this (honu-facc-obj ast)))] - [(honu-fassn? ast) - (if (and (not (eqv? (honu-fassn-obj ast) 'my)) - (not (honu-this? (honu-fassn-obj ast)))) ; this on the left side of a dot is okay - (check-uses-of-this (honu-fassn-obj ast))) - (check-uses-of-this (honu-fassn-rhs ast))] - [(honu-mcall? ast) - (if (and (not (eqv? (honu-mcall-obj ast) 'my)) - (not (honu-this? (honu-mcall-obj ast)))) ; this on the left side of a dot is okay - (check-uses-of-this (honu-mcall-obj ast))) - (for-each check-uses-of-this (honu-mcall-args ast))] - [(honu-var? ast) (void)] - [(honu-assn? ast) - (check-uses-of-this (honu-assn-rhs ast))] - [(honu-call? ast) - (for-each check-uses-of-this (honu-call-args ast))] - [(honu-this? ast) - ;; we reached a case where this is not okay, so we throw an exception - (raise-read-error-with-stx - "Unprotected use of this in possible client context." - (honu-ast-src-stx ast))] - [(honu-cast? ast) - (if (not (honu-this? (honu-cast-obj ast))) ; this in a cast is okay. - (check-uses-of-this (honu-cast-obj ast)))] - [(honu-isa? ast) - (if (not (honu-this? (honu-isa-obj ast))) ; this in an isa is okay. - (check-uses-of-this (honu-isa-obj ast)))] - [(honu-if? ast) - (check-uses-of-this (honu-if-cond ast)) - (check-uses-of-this (honu-if-true ast)) - (check-uses-of-this (honu-if-false ast))] - [(honu-new? ast) - (for-each check-uses-of-this (honu-new-arg-vals ast))] - [(honu-block? ast) - (for-each check-uses-of-this (honu-block-binds ast)) - (for-each check-uses-of-this (honu-block-exps ast))] - [(honu-return? ast) - (check-uses-of-this (honu-return-body ast))] - - [(honu-binding? ast) - (check-uses-of-this (honu-binding-rhs ast))])) - - - ) diff --git a/collects/honu/private/typechecker/honu-typecheck-type-defn.ss b/collects/honu/private/typechecker/honu-typecheck-type-defn.ss deleted file mode 100644 index 98300513d2..0000000000 --- a/collects/honu/private/typechecker/honu-typecheck-type-defn.ss +++ /dev/null @@ -1,73 +0,0 @@ -(module honu-typecheck-type-defn mzscheme - - (require (lib "list.ss" "srfi" "1")) - - (require "../../ast.ss") - (require "../../utils.ss") - (require "honu-type-utils.ss") - (require "../../read-error-with-stx.ss") - - (provide honu-typecheck-type-defn) - - ;; P |- t_i P |- t'_i P |- mdec_i - ;; ------------------------------------ - ;; P, J |- type t <: t_1 ... t_m { - ;; t'_1 fd_1; ...; t'_k fd_k; - ;; mdec_1; ...; mdec_n; - ;; } - ;; |=> type t <: t_1 ... t_m - ;; t'_1 fd_1; ...; t'_k fd_k; - ;; mdec_1; ...; mdec_n; - ;; }, J - ;; - ;; Neither the type definition nor the init-arg environment - ;; are modified by the type definition typechecker. - (define (honu-typecheck-type-defn tenv defn) - (begin (check-supers tenv (honu-type-defn-supers defn)) - (check-field-decls tenv (filter (lambda (d) - (honu-field-decl? d)) - (honu-type-defn-decls defn))) - (check-method-decls tenv (filter (lambda (d) - (honu-method-decl? d)) - (honu-type-defn-decls defn))) - defn)) - - (define (check-supers tenv super-list) - (cond - [(null? super-list) #t] - [(not (honu-iface-type-in-tenv? tenv (car super-list))) - (raise-read-error-with-stx - "Type declared as supertype not found in program." - (honu-ast-src-stx (car super-list)))] - [else (check-supers tenv (cdr super-list))])) - - (define (check-field-decls tenv field-list) - (cond - [(null? field-list) #t] - [(not (honu-type-in-tenv? tenv (honu-field-decl-type (car field-list)))) - (raise-read-error-with-stx - "Type of field not found in program." - (honu-ast-src-stx (honu-field-decl-type (car field-list))))] - [else (check-field-decls tenv (cdr field-list))])) - - ;; P |- t P |- t_i - ;; ------------------------ - ;; P |- t md(t_1, ..., t_n) - (define (check-method-decls tenv method-list) - (cond - [(null? method-list) #t] - [(not (or (honu-top-type? (honu-method-decl-type (car method-list))) ; allow void for return type of method - (honu-type-in-tenv? tenv (honu-method-decl-type (car method-list))))) - (raise-read-error-with-stx - "Return type of method not found in program." - (honu-ast-src-stx (honu-method-decl-type (car method-list))))] - [else (let loop ((arg-types (honu-method-decl-arg-types (car method-list)))) - (cond - [(null? arg-types) - (check-method-decls tenv (cdr method-list))] - [(not (honu-type-in-tenv? tenv (car arg-types))) - (raise-read-error-with-stx - "Type of argument for method not found in program." - (honu-ast-src-stx (car arg-types)))] - [else (loop (cdr arg-types))]))])) - ) diff --git a/collects/honu/private/typechecker/honu-typecheck.ss b/collects/honu/private/typechecker/honu-typecheck.ss deleted file mode 100644 index a3774c9f18..0000000000 --- a/collects/honu/private/typechecker/honu-typecheck.ss +++ /dev/null @@ -1,51 +0,0 @@ -(module honu-typecheck mzscheme - (require (lib "struct.ss") - (lib "contract.ss")) - - (require "../../ast.ss") - (require "../../tenv.ss") - (require "honu-type-utils.ss") - (require "honu-convert-static.ss") - (require "honu-typecheck-function.ss") - (require "honu-typecheck-type-defn.ss") - (require "honu-typecheck-class.ss") - (require "honu-typecheck-mixin.ss") - (require "honu-typecheck-prechecks.ss") - (require "../../read-error-with-stx.ss") - -; (provide honu-typecheck-program) - (provide/contract [honu-typecheck-program - (tenv? - honu-program? - . -> . - honu-program?)]) - (define (honu-typecheck-program tenv pgm) - (let ((pgm (honu-convert-static tenv pgm))) - (check-uses-of-this pgm) - (let-values (((new-defns) - (map (lambda (d) - (honu-typecheck-defn tenv d)) - (honu-program-defns pgm)))) - (let ((new-pgm (copy-struct honu-program pgm - (honu-program-defns new-defns)))) - new-pgm)))) - - (define (honu-typecheck-defn tenv defn) - (cond - [(honu-function? defn) - (honu-typecheck-function tenv defn)] - [(honu-type-defn? defn) - (honu-typecheck-type-defn tenv defn)] - [(honu-subclass? defn) - ;; we don't need to check this anymore, because it's checked in add-defns-to-tenv - ; (honu-typecheck-subclass pgm defn)] - defn] - [(honu-mixin? defn) - (honu-typecheck-mixin tenv defn)] - [(honu-class? defn) - (honu-typecheck-class tenv defn)] - [else - (raise-read-error-with-stx - "Unknown type of top-level definition." - (honu-ast-src-stx defn))])) - ) diff --git a/collects/honu/private/typechecker/type-utils.ss b/collects/honu/private/typechecker/type-utils.ss new file mode 100644 index 0000000000..68698b1812 --- /dev/null +++ b/collects/honu/private/typechecker/type-utils.ss @@ -0,0 +1,265 @@ +(module type-utils mzscheme + (require (lib "list.ss" "srfi" "1") + (lib "plt-match.ss") + "../../ast.ss" + "../../readerr.ss" + "../../tenv.ss") + + (provide make-null-type make-any-type make-void-type make-error-type make-top-type make-bottom-type + make-int-type make-string-type make-char-type make-bool-type make-float-type + make-tuple-type make-func-type make-method-type make-iface-type) + (define (make-null-type stx) + (make-honu:type-iface-bot stx)) + (define (make-any-type stx) + (make-honu:type-iface-top stx)) + ;; if you want non-strict void context method bodies, change this to + ;; (make-honu:type-top stx) + ;; if you want to make sure that a value of "void" type is returned, do + ;; (make-honu:type-tuple stx '()) + (define (make-void-type stx) + (make-honu:type-tuple stx (list))) + (define (make-error-type stx) + (make-honu:type-bot stx)) + (define (make-top-type stx) + (make-honu:type-top stx)) + (define (make-bottom-type stx) + (make-honu:type-bot stx)) + (define (make-tuple-type stx args) + (if (and (not (null? args)) + (null? (cdr args))) + (car args) ;; just return the type if there's only one. + (make-honu:type-tuple stx args))) + (define (make-func-type stx arg ret) + (make-honu:type-func stx arg ret)) + (define (make-method-type stx disp arg ret) + (make-honu:type-disp stx disp arg ret)) + (define (make-iface-type stx name) + (make-honu:type-iface stx name)) + (define (make-int-type stx) + (make-honu:type-prim stx 'int)) + (define (make-string-type stx) + (make-honu:type-prim stx 'string)) + (define (make-char-type stx) + (make-honu:type-prim stx 'char)) + (define (make-bool-type stx) + (make-honu:type-prim stx 'bool)) + (define (make-float-type stx) + (make-honu:type-prim stx 'float)) + + (provide printable-type) + (define (printable-type t) + (match t + [(struct honu:type-top (_)) + "(no info)"] + [(struct honu:type-bot (_)) + "'a"] + [(struct honu:type-prim (_ name)) + (symbol->string name)] + [(struct honu:type-tuple (_ args)) + (if (null? args) + "<>" + (string-append "<" + (fold (lambda (t i) + (string-append i ", " (printable-type t))) + (printable-type (car args)) + (cdr args)) + ">"))] + [(struct honu:type-select (_ slot type)) + (format "tuple of size >= ~a where the type in slot ~a is ~a" + slot slot (printable-type type))] + [(struct honu:type-func (_ arg ret)) + (if (honu:type-func? arg) + (string-append "<" (printable-type arg) "> -> " (printable-type ret)) + (string-append (printable-type arg) " -> " (printable-type ret)))] + [(struct honu:type-disp (_ disp arg ret)) + (string-append "[" (printable-type disp) "] " + (printable-type arg) " -> " (printable-type ret))] + [(struct honu:type-iface (_ name)) + (symbol->string (syntax-e name))] + [(struct honu:type-iface-top (_)) + "Any"] + [(struct honu:type-iface-bot (_)) + "null"])) + + (provide type-valid?) + (define (type-valid? tenv t) + (match t + [(struct honu:type-iface-top (_)) #t] + [(struct honu:type-prim (stx name)) + (case name + [(int float char string bool) #t] + [else (raise-read-error-with-stx + (format "Unexpected primitive type ~a" name) + stx)])] + [(struct honu:type-iface (stx name)) + (let ([tentry (get-tenv-entry tenv name)]) + (and tentry (tenv:type? tentry)))] + [(struct honu:type-tuple (_ args)) + (andmap (lambda (t) + (type-valid? tenv t)) + args)] + [(struct honu:type-func (_ arg ret)) + (and (type-valid? tenv arg) + (type-valid? tenv ret))] + [(struct honu:type-disp (_ disp arg ret)) + (and (type-valid? tenv disp) + (type-valid? tenv arg) + (type-valid? tenv ret))])) + + (provide type-equal?) + (define (type-equal? tenv t1 t2) + (cond + ;; first all the easy ones + [(and (honu:type-top? t1) + (honu:type-top? t2)) + #t] + [(and (honu:type-bot? t1) + (honu:type-bot? t2)) + #t] + [(and (honu:type-iface-top? t1) + (honu:type-iface-top? t2)) + #t] + [(and (honu:type-iface-bot? t1) + (honu:type-iface-bot? t2)) + #t] + ;; primitive types are equal if their names are equal. + [(and (honu:type-prim? t1) + (honu:type-prim? t2)) + (eqv? (honu:type-prim-name t1) + (honu:type-prim-name t2))] + ;; same for ifaces + [(and (honu:type-iface? t1) + (honu:type-iface? t2)) + (tenv-key=? (honu:type-iface-name t1) + (honu:type-iface-name t2))] + ;; function, dispatch types are equal if their component types are. + [(and (honu:type-func? t1) + (honu:type-func? t2)) + (and (type-equal? tenv (honu:type-func-arg t1) (honu:type-func-arg t2)) + (type-equal? tenv (honu:type-func-ret t1) (honu:type-func-ret t2)))] + [(and (honu:type-disp? t1) + (honu:type-disp? t2)) + (and (type-equal? tenv (honu:type-disp-disp t1) (honu:type-disp-disp t2)) + (type-equal? tenv (honu:type-disp-arg t1) (honu:type-disp-arg t2)) + (type-equal? tenv (honu:type-disp-ret t1) (honu:type-disp-ret t2)))] + ;; tuple types are equal if they have the same number of components and + ;; their components are pairwise equal + [(and (honu:type-tuple? t1) + (honu:type-tuple? t2)) + (let ([t1-args (honu:type-tuple-args t1)] + [t2-args (honu:type-tuple-args t2)]) + (and (= (length t1-args) (length t2-args)) + (andmap (lambda (t1 t2) + (type-equal? tenv t1 t2)) + t1-args t2-args)))] + ;; for select types, they must be the same type on the same slot + ;; (should we even get here?) + [(and (honu:type-select? t1) + (honu:type-select? t2)) + (and (= (honu:type-select-slot t1) (honu:type-select-slot t2)) + (type-equal? (honu:type-select-type t1) (honu:type-select-type t2)))] + [else #f])) + + ;; assumes either Any or some type identifier + (define (get-type-name t) + (cond + [(honu:type-iface? t) + (honu:type-iface-name t)] + [(honu:type-iface-top? t) + #'Any])) + + ;; is t1 a _direct_ subtype of t2? + (define (Subtype_P tenv t1 t2) + (let ([type-entry (get-type-entry tenv t1)]) + (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=?))]))) + + ;; is t1 a (ref-trans-closed) subtype of t2? + (provide <:_P) + (define (<:_P tenv t1 t2) + (cond + ;; if t1 = t2, t1 <:_P t2 + [(type-equal? tenv t1 t2) + #t] + ;; if t1 is the bottom of the type lattice, then it trivially holds + [(honu:type-bot? t1) + #t] + ;; if t2 is the top of the type lattice, then it trivially holds + [(honu:type-top? t2) + #t] + ;; if t1 =/= t2 and they're both primitives, then they cannot be equal. + [(and (honu:type-prim? t1) + (honu:type-prim? t2)) + #f] + ;; for function types... + [(and (honu:type-func? t1) + (honu:type-func? t2)) + ;; the arg is contravariant and the ret is covariant + (and (<:_P tenv (honu:type-func-arg t2) (honu:type-func-arg t1)) + (<:_P tenv (honu:type-func-ret t1) (honu:type-func-ret t2)))] + ;; for dispatch types... + [(and (honu:type-disp? t1) + (honu:type-disp? t2)) + ;; dispatch args must be co-, regular args contra-, and ret co- + (and (<:_P tenv (honu:type-disp-disp t1) (honu:type-disp-disp t2)) + (<:_P tenv (honu:type-disp-arg t2) (honu:type-disp-arg t1)) + (<:_P tenv (honu:type-disp-ret t1) (honu:type-disp-ret t2)))] + ;; for tuple types... + [(and (honu:type-tuple? t1) + (honu:type-tuple? t2)) + (let ([t1-args (honu:type-tuple-args t1)] + [t2-args (honu:type-tuple-args t2)]) + ;; the lengths must be equal... + (and (= (length t1-args) (length t2-args)) + ;; and each component must be a subtype (covariantly) + (andmap (lambda (t1 t2) + (<:_P tenv t1 t2)) + t1-args t2-args)))] + ;; for a select statement (s, t), we have that a tuple type (t_1 ... t_n) is <:_P t if + ;; if t_s <:_P t. + [(and (honu:type-tuple? t1) + (honu:type-select? t2)) + (let ([t2-slot (honu:type-select-slot t2)] + [t1-args (honu:type-tuple-args t1)]) + (and (<= t2-slot (length t1-args)) + ;; we have to subtract one from t2-slot because list-ref is zero-based + (<:_P tenv (list-ref t1-args (- t2-slot 1)) (honu:type-select-type t2))))] + ;; not sure if this is necessary. Hmm. + [(and (honu:type-select? t1) + (honu:type-select? t2)) + (and (= (honu:type-select-slot t1) (honu:type-select-slot t2)) + (<:_P tenv (honu:type-select-type t1) (honu:type-select-type t2)))] + ;; the bottom of the iface lattice is <:_P either the iface-top or + ;; any iface + [(and (honu:type-iface-bot? t1) + (or (honu:type-iface? t2) + (honu:type-iface-top? t2))) + #t] + ;; any iface type is <:_P the iface-top (iface-bot already caught above) + [(and (honu:type-iface? t1) + (honu:type-iface-top? t2)) + #t] + ;; if two (non-equal) iface types... + [(and (honu:type-iface? t1) + (honu:type-iface? t2)) + (if (Subtype_P tenv t1 t2) + ;; return true if it's a direct subtype relation + #t + (let ([type-entry (get-type-entry tenv t1)]) + ;; if any of the direct supertypes of t1 is a subtype of t2, + ;; then t1 is also + (ormap (lambda (t) + (<:_P tenv t t2)) + (tenv:type-supers type-entry))))] + [else #f])) + + (provide raise-honu-type-error) + (define (raise-honu-type-error stx expected received) + (raise-read-error-with-stx + (format "Expected type ~a, got type ~a" + (printable-type expected) + (printable-type received)) + stx)) + ) diff --git a/collects/honu/private/typechecker/typecheck-class-utils.ss b/collects/honu/private/typechecker/typecheck-class-utils.ss new file mode 100644 index 0000000000..1c7aba9abf --- /dev/null +++ b/collects/honu/private/typechecker/typecheck-class-utils.ss @@ -0,0 +1,283 @@ +(module typecheck-class-utils mzscheme + + (require (lib "list.ss" "srfi" "1") + (lib "plt-match.ss") + (lib "struct.ss") + "../../ast.ss" + "../../readerr.ss" + "../../tenv.ss" + "../../utils.ss" + "typecheck-expression.ss" + "type-utils.ss") + + (provide extend-cenv-with-type-members typecheck-members typecheck-supernew typecheck-exports) + (define (typecheck-exports tenv cenv selftype init-impls exports) + (let loop ([impls init-impls] + [exports exports]) + (cond + [(and (null? exports) + (null? impls)) + (if (not (s:member selftype init-impls (lambda (t1 t2) (type-equal? tenv t1 t2)))) + (raise-read-error-with-stx + (format "No export statement for self type ~a" + (printable-type selftype)) + (honu:ast-stx selftype)) + ;; the selftype was already covered by one of the implemented types, so + ;; we can just stop. + (void))] + [(null? exports) + (raise-read-error-with-stx + (format "No export statement for implemented type ~a" + (printable-type (car impls))) + (honu:ast-stx (car impls)))] + [(null? impls) + (if (s:member selftype init-impls (lambda (t1 t2) (type-equal? tenv t1 t2))) + (raise-read-error-with-stx + (format "Extra export statement for unimplemented type ~a" + (printable-type (honu:export-type (car exports)))) + (honu:ast-stx (car exports))) + (let-values ([(matched non-matches) (partition-first (lambda (e) + (type-equal? tenv (honu:export-type e) selftype)) + exports)]) + (if (not matched) + (raise-read-error-with-stx + (format "No export statement for self type ~a" + (printable-type selftype)) + (honu:ast-stx selftype)) + (let ([type-entry (get-type-entry tenv selftype)]) + (typecheck-export tenv cenv type-entry matched) + (if (not (null? non-matches)) + (raise-read-error-with-stx + (format "Extra export statement for unimplemented type ~a" + (printable-type (honu:export-type (car exports)))) + (honu:ast-stx (car exports))) + (void))))))] + [else + (let-values ([(matched non-matches) (partition-first (lambda (t) + (type-equal? tenv (honu:export-type (car exports)) t)) + impls)]) + (if (not matched) + (raise-read-error-with-stx + (format "Extra export statement for unimplemented type ~a" + (honu:export-type (car exports))) + (honu:ast-stx (car exports))) + (let* ([type-entry (get-type-entry tenv matched)] + [export (car exports)]) + (typecheck-export tenv cenv type-entry export) + (loop non-matches (cdr exports)))))]))) + + (define (typecheck-export tenv cenv 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)]) + (cond + [(and (null? type-members) + (null? export-binds)) + (void)] + [(null? type-members) + (raise-read-error-with-stx + (format "No member named ~a in type ~a" + (printable-key (honu:exp-bind-new (car export-binds))) + (printable-type (honu:export-type export))) + (honu:exp-bind-new (car export-binds)))] + [(null? export-binds) + (raise-read-error-with-stx + (format "Member ~a of type ~a was not exported" + (printable-key (tenv:member-name (car type-members))) + (printable-type (honu:export-type export))) + (honu:ast-stx export))] + [else + (let-values ([(matched non-matches) (partition-first (lambda (m) + (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)))]) + (cond + [(not cenv-entry) + (raise-read-error-with-stx + (format "No static member named ~a" + (printable-key (honu:exp-bind-old (car export-binds)))) + (honu:exp-bind-old (car export-binds)))] + [(not matched) + (raise-read-error-with-stx + (format "No member named ~a in type ~a" + (printable-key (honu:exp-bind-new (car export-binds))) + (printable-type (honu:export-type export))) + (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 tenv cenv-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-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? tenv cenv-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-key (tenv:member-name matched)) + (printable-type (tenv:member-type matched))) + (honu:exp-bind-old (car export-binds))))]))]))) + + + + (define (extend-cenv-with-type-members tenv cenv type) + (let ([type-entry (get-type-entry tenv type)]) + (fold (lambda (m e) + (extend-fenv (tenv:member-name m) + (tenv:member-type m) + e)) + cenv + (tenv:type-members type-entry)))) + + (define (typecheck-supernew tenv cenv lenv withs supernew) + (let loop ([withs withs] + [args (honu:super-new-args supernew)] + [checked-args '()]) + (cond + [(and (null? withs) + (null? args)) + (copy-struct honu:super-new supernew + [honu:super-new-args (reverse checked-args)])] + [(null? withs) + (raise-read-error-with-stx + (format "No expected init slot declaration for super arg ~a" + (printable-key (honu:name-arg-name (car args)))) + (honu:name-arg-name (car args)))] + [(null? args) + (raise-read-error-with-stx + (format "Expected init slot ~a not used as super arg" + (printable-key (honu:formal-name (car withs)))) + (honu:formal-name (car withs)))] + [else + (let-values ([(matched non-matches) (partition-first (lambda (w) + (tenv-key=? (honu:formal-name w) + (honu:name-arg-name (car args)))) + withs)]) + (if (not matched) + (raise-read-error-with-stx + (format "No expected init slot declaration for super arg ~a" + (printable-key (honu:name-arg-name (car args)))) + (honu:name-arg-name (car args))) + (let ([first-arg (car args)]) + (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv + (honu:formal-type matched) + (honu:formal-type matched) + (honu:name-arg-value first-arg))]) + (loop non-matches + (cdr args) + (cons (copy-struct honu:name-arg first-arg + [honu:name-arg-value e1]) + checked-args))))))]))) + + + (define (typecheck-members tenv cenv lenv selftype members) + (let loop ([members members] + [cenv cenv] + [ret '()]) + (cond + [(null? members) + (values (reverse ret) cenv)] + [(or (honu:init-field? (car members)) + (honu:field? (car members))) + (let ([member (typecheck-member tenv cenv lenv selftype (car members))]) + (loop (cdr members) + (extend-fenv (get-class-member-name (car members)) + (get-class-member-type selftype (car members)) + cenv) + (cons member ret)))] + [(honu:method? (car members)) + (let-values ([(methods remainder) (get-murec-methods members)]) + (let ([cenv (fold (lambda (m cenv) + (extend-fenv (get-class-member-name m) + (get-class-member-type selftype m) + cenv)) + cenv + methods)]) + (loop remainder + cenv + ;; I only through the reverse in to keep the order the same. + ;; it doesn't really matter. + (append (reverse (map (lambda (m) + (typecheck-member tenv cenv lenv selftype m)) + methods)) + ret))))]))) + + (define (get-murec-methods members) + (let loop ([members members] + [ret '()]) + (cond + [(null? members) (values (reverse ret) members)] + [(or (honu:init-field? (car members)) + (honu:field? (car members))) + (values (reverse ret) members)] + [(honu:method? (car members)) + (loop (cdr members) (cons (car members) ret))]))) + + (define (typecheck-member tenv cenv lenv selftype member) + (match member + [(struct honu:init-field (stx name type value)) + (if (not (type-valid? tenv type)) + (raise-read-error-with-stx + "Type of init field is undefined" + (honu:ast-stx type))) + (if value + (let-values ([(e1 t1) (typecheck-expression tenv cenv (extend-fenv #'this selftype lenv) type #f value)]) + (copy-struct honu:init-field member + [honu:init-field-value e1])) + member)] + [(struct honu:field (stx name type value)) + (if (not (type-valid? tenv type)) + (raise-read-error-with-stx + "Type of field is undefined" + (honu:ast-stx type))) + (let-values ([(e1 t1) (typecheck-expression tenv cenv (extend-fenv #'this selftype lenv) type #f value)]) + (copy-struct honu:field member + [honu:field-value e1]))] + [(struct honu:method (stx name type args body)) + (if (not (type-valid? tenv type)) + (raise-read-error-with-stx + "Return type of method is undefined" + (honu:ast-stx type))) + (for-each (lambda (t) + (if (not (type-valid? tenv t)) + (raise-read-error-with-stx + "Type of method argument is undefined" + (honu:ast-stx t)))) + (map honu:formal-type args)) + (let-values ([(e1 t1) (typecheck-expression tenv cenv (fold (lambda (arg fenv) + (extend-fenv (honu:formal-name arg) + (honu:formal-type arg) + fenv)) + (extend-fenv #'this selftype lenv) + args) + type type body)]) + (copy-struct honu:method member + [honu:method-body e1]))])) + + (define (get-class-member-name member) + (match member + [(struct honu:init-field (stx name type value)) name] + [(struct honu:field (stx name type value)) name] + [(struct honu:method (stx name type args body)) name])) + + (define (get-class-member-type exptype member) + (match member + [(struct honu:init-field (stx name type value)) + type] + [(struct honu:field (stx name type value)) + type] + [(struct honu:method (stx name type args body)) + (make-method-type stx exptype + (make-tuple-type stx (map honu:formal-type args)) + type)])) + + ) \ No newline at end of file diff --git a/collects/honu/private/typechecker/typecheck-expression.ss b/collects/honu/private/typechecker/typecheck-expression.ss new file mode 100644 index 0000000000..1aa486cef1 --- /dev/null +++ b/collects/honu/private/typechecker/typecheck-expression.ss @@ -0,0 +1,634 @@ +(module typecheck-expression mzscheme + + (require (all-except (lib "list.ss" "srfi" "1") any) + (lib "contract.ss") + (lib "plt-match.ss") + (lib "struct.ss") + "../../ast.ss" + "../../readerr.ss" + "../../tenv.ss" + "../../utils.ss" + "type-utils.ss") + + (provide/contract [typecheck-expression ((tenv? + ((syntax/c symbol?) . -> . (union honu:type? false/c)) + ((syntax/c symbol?) . -> . (union honu:type? false/c)) + (union honu:type? false/c) + (union honu:type? false/c) + honu:expr?) + . ->* . + (honu:expr? + honu:type?))]) + + ;; tenv : tenv? + ;; interface/class/mixin environment + ;; cenv : ((syntax/c symbol?) . -> . (union honu:type false/c)) + ;; static environment inside of a class or mixin definition + ;; (i.e. for my.) + ;; lenv : ((syntax/c symbol?) . -> . (union honu:type false/c)) + ;; lexical environment (includes top-level bindings and + ;; binding for #'this if inside class or mixin) + ;; ctype : (union honu:type? false/c) + ;; type of context for expression + ;; rtype : (union honu:type? false/c) + ;; return type for method/function + ;; expr : honu:expr? + ;; expression to typecheck + + (define (typecheck-expression tenv cenv lenv ctype rtype expr) + (match expr + [(struct honu:this (stx)) + (cond + [(lenv #'this) => (lambda (t) + (if (<:_P tenv t ctype) + (values expr t) + (raise-honu-type-error stx ctype t)))] + [else (raise-read-error-with-stx + "Found use of 'this' outside of class or mixin" + stx)])] + [(struct honu:select (stx slot arg)) + ;; changed to have a special "select" type that does the following: + ;; (type-select n t) <:_P (type-tuple args) if + ;; a) (>= (length args) n) + ;; b) (type-equal? (list-ref args (- n 1)) t) + ;; c) (list-ref args m) <:_P (type-top) for all m =/= n (vacuously true) + (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-honu:type-select stx slot ctype) rtype arg)]) + (if (not (honu:type-tuple? t1)) + (raise-read-error-with-stx "Tried to use select with non-tuple expression" stx)) + (let ([etype (list-ref (honu:type-tuple-args t1) (- slot 1))]) + (values (copy-struct honu:select expr + [honu:select-arg e1]) + etype)))] + [(struct honu:var (stx name)) + (cond + [(lenv name) => (lambda (t) + (if (<:_P tenv t ctype) + (values expr t) + (raise-honu-type-error stx ctype t)))] + [else (raise-read-error-with-stx + (format "Unbound variable ~a" (syntax-e name)) + stx)])] + [(struct honu:assn (stx lhs rhs)) + ;; the context type for the lhs is a vacuous one. + (let*-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-top-type (honu:ast-stx lhs)) rtype lhs)] + [(e2 t2) (typecheck-expression tenv cenv lenv t1 rtype rhs)]) + (let ([void-type (make-void-type stx)]) + (if (<:_P tenv void-type ctype) + (values (copy-struct honu:assn expr + [honu:assn-lhs e1] + [honu:assn-rhs e2]) + void-type) + (raise-honu-type-error stx ctype void-type))))] + [(struct honu:call (stx func arg)) + (let*-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-func-type (honu:ast-stx func) + (make-bottom-type (honu:ast-stx func)) + ctype) rtype func)] + [(e2 t2) (typecheck-expression tenv cenv lenv (honu:type-func-arg t1) rtype arg)]) + (let ([ret-type (honu:type-func-ret t1)]) + (if (<:_P tenv ret-type ctype) + (values (copy-struct honu:call expr + [honu:call-func e1] + [honu:call-arg e2]) + ret-type) + (raise-honu-type-error stx ctype ret-type))))] + [(struct honu:lit (stx type value)) + (if (<:_P tenv type ctype) + (values expr type) + (raise-honu-type-error stx ctype type))] + [(struct honu:un-op (stx op op-stx _ arg)) + (case op + [(not) + (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-bool-type (honu:ast-stx arg)) rtype arg)]) + (let ([ret-type (make-bool-type stx)]) + (if (<:_P tenv ret-type ctype) + (values (copy-struct honu:un-op expr + [honu:un-op-op-type t1] + [honu:un-op-arg e1]) + ret-type) + (raise-honu-type-error stx ctype ret-type))))] + [(minus) + (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-top-type (honu:ast-stx arg)) rtype arg)]) + (if (not (honu:type-prim? t1)) + (raise-read-error-with-stx + "Invalid type for argument to unary minus" + (honu:ast-stx arg)) + (let ([ret-type (case (honu:type-prim-name t1) + [(int) (make-int-type (honu:ast-stx arg))] + [(float) (make-float-type (honu:ast-stx arg))] + [else (raise-read-error-with-stx + (format "Argument to unary minus must be int or float type, got ~a" + (printable-type t1)) + (honu:ast-stx arg))])]) + (if (<:_P tenv ret-type ctype) + (values (copy-struct honu:un-op expr + [honu:un-op-op-type t1] + [honu:un-op-arg e1]) + ret-type) + (raise-honu-type-error stx ctype ret-type)))))] + [else + (raise-read-error-with-stx + "Unknown operator" + op-stx)])] + [(struct honu:bin-op (stx op op-stx _ larg rarg)) + (case op + ;; binary boolean operators + [(or and) + (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-bool-type (honu:ast-stx larg)) rtype larg)] + [(e2 t2) (typecheck-expression tenv cenv lenv (make-bool-type (honu:ast-stx rarg)) rtype rarg)]) + (let ([ret-type (make-bool-type stx)]) + (if (<:_P tenv ret-type ctype) + (values (copy-struct honu:bin-op expr + [honu:bin-op-op-type (make-bool-type (honu:ast-stx larg))] + [honu:bin-op-larg e1] + [honu:bin-op-rarg e2]) + ret-type) + (raise-honu-type-error stx ctype ret-type))))] + [(clseq) + (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-any-type (honu:ast-stx larg)) rtype larg)] + [(e2 t2) (typecheck-expression tenv cenv lenv (make-any-type (honu:ast-stx rarg)) rtype rarg)]) + (let ([ret-type (make-bool-type stx)]) + (if (<:_P tenv ret-type ctype) + (values (copy-struct honu:bin-op expr + [honu:bin-op-op-type (make-any-type (honu:ast-stx larg))] + [honu:bin-op-larg e1] + [honu:bin-op-rarg e2]) + ret-type) + (raise-honu-type-error stx ctype ret-type))))] + [(equal neq) + (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-top-type (honu:ast-stx larg)) rtype larg)] + [(e2 t2) (typecheck-expression tenv cenv lenv (make-top-type (honu:ast-stx rarg)) rtype rarg)]) + (let ([ret-type (make-bool-type stx)] + [arg-type (cond + [(and (<:_P tenv t1 (make-any-type (honu:ast-stx larg))) + (<:_P tenv t2 (make-any-type (honu:ast-stx rarg)))) + (make-any-type (honu:ast-stx larg))] + [(check-prim-types-for-binop stx tenv t1 t2) => (lambda (t) t)])]) + (if (<:_P tenv ret-type ctype) + (values (copy-struct honu:bin-op expr + [honu:bin-op-op-type arg-type] + [honu:bin-op-larg e1] + [honu:bin-op-rarg e2]) + ret-type) + (raise-honu-type-error stx ctype ret-type))))] + [(le lt ge gt) + (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-top-type (honu:ast-stx larg)) rtype larg)] + [(e2 t2) (typecheck-expression tenv cenv lenv (make-top-type (honu:ast-stx rarg)) rtype rarg)]) + (let ([ret-type (make-bool-type stx)] + [arg-type (check-prim-types-for-binop stx tenv t1 t2)]) + (if (<:_P tenv ret-type ctype) + (values (copy-struct honu:bin-op expr + [honu:bin-op-op-type arg-type] + [honu:bin-op-larg e1] + [honu:bin-op-rarg e2]) + ret-type) + (raise-honu-type-error stx ctype ret-type))))] + [(plus) + (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-top-type (honu:ast-stx larg)) rtype larg)] + [(e2 t2) (typecheck-expression tenv cenv lenv (make-top-type (honu:ast-stx rarg)) rtype rarg)]) + (let ([arg-type (check-prim-types-for-binop stx tenv t1 t2)]) + (case (honu:type-prim-name arg-type) + [(int float string) + (if (<:_P tenv arg-type ctype) + (values (copy-struct honu:bin-op expr + [honu:bin-op-op-type arg-type] + [honu:bin-op-larg e1] + [honu:bin-op-rarg e2]) + arg-type) + (raise-honu-type-error stx ctype arg-type))] + [else (raise-read-error-with-stx + "The plus operator requires both arguments to be of type int, type float, or type string" + stx)])))] + [(minus times div) + (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-top-type (honu:ast-stx larg)) rtype larg)] + [(e2 t2) (typecheck-expression tenv cenv lenv (make-top-type (honu:ast-stx rarg)) rtype rarg)]) + (let ([arg-type (check-prim-types-for-binop stx tenv t1 t2)]) + (case (honu:type-prim-name arg-type) + [(int float) + (if (<:_P tenv arg-type ctype) + (values (copy-struct honu:bin-op expr + [honu:bin-op-op-type arg-type] + [honu:bin-op-larg e1] + [honu:bin-op-rarg e2]) + arg-type) + (raise-honu-type-error stx ctype arg-type))] + [else (raise-read-error-with-stx + "Arithmetic operator requires both arguments to be of type int or type float" + stx)])))] + [(mod) + (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-int-type (honu:ast-stx larg)) rtype larg)] + [(e2 t2) (typecheck-expression tenv cenv lenv (make-int-type (honu:ast-stx rarg)) rtype rarg)]) + (let ([ret-type (make-int-type stx)]) + (if (<:_P tenv ret-type ctype) + (values (copy-struct honu:bin-op expr + [honu:bin-op-op-type (make-int-type (honu:ast-stx larg))] + [honu:bin-op-larg e1] + [honu:bin-op-rarg e2]) + ret-type) + (raise-honu-type-error stx ctype ret-type))))] + [else + (raise-read-error-with-stx + "Unknown operator" + op-stx)])] + [(struct honu:lambda (stx ret-type args body)) + ;; since we have explicit return type annotations now, we use them for the body's ctype and rtype. + (let ([body-lenv (fold (lambda (f e) + (extend-fenv (honu:formal-name f) + (honu:formal-type f) + e)) + lenv args)]) + (let-values ([(body _) (typecheck-expression tenv cenv body-lenv ret-type ret-type body)]) + ;; we also have the lambda's return type be what was explicitly annotated instead of what we got back + (let ([lam-type (make-func-type stx (make-tuple-type stx (map honu:formal-type args)) ret-type)]) + (if (<:_P tenv lam-type ctype) + (values (copy-struct honu:lambda expr + [honu:lambda-body body]) + lam-type) + (raise-honu-type-error stx ctype lam-type)))))] + [(struct honu:if (stx test then else)) + (if else + (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-bool-type (honu:ast-stx test)) rtype test)] + [(e2 t2) (typecheck-expression tenv cenv lenv ctype rtype then)] + [(e3 t3) (typecheck-expression tenv cenv lenv ctype rtype else)]) + ;; this should work, but I get the following: + ;; -- context expected 1 value, received 2 values: # # + ;; with the arrow going from values -> cond, so I'm going to rewrite as a nested-if for now. + (cond + ;; if we had a context type and got to this point, then both t2 and t3 must be related to it (either equal + ;; or subtypes), so use it as the type of the entire if expression. + ;; + ;; No, we can't do this. Think about the fact where we use an if expression on the left-hand side of a + ;; member access -- we need to get the most specific type back as the result, not the (vacuous) context + ;; type. If the branches are of unrelated types, then having a context type doesn't help us all the time. + ;; [ctype + ;; (values (copy-struct honu:if expr + ;; [honu:if-cond e1] + ;; [honu:if-then e2] + ;; [honu:if-else e3]) + ;; ctype)] + ;; if there was no ctype, then we require either t2 <: t3 or t3 <: t2, and we'll pick the supertype. + [(<:_P tenv t2 t3) + (values (copy-struct honu:if expr + [honu:if-cond e1] + [honu:if-then e2] + [honu:if-else e3]) + t3)] + [(<:_P tenv t3 t2) + (values (copy-struct honu:if expr + [honu:if-cond e1] + [honu:if-then e2] + [honu:if-else e3]) + t2)] + ;; if we got to here, then there's no good type to use as the type of the entire if expression, so + ;; raise an error. + [else (raise-read-error-with-stx + "Branches of if statement are of unrelated types" + stx)])) + ;; if else is #f, there was no else branch, so the then branch must be of void type. + (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-bool-type (honu:ast-stx test)) rtype test)] + [(e2 t2) (typecheck-expression tenv cenv lenv (make-void-type (honu:ast-stx then)) rtype then)]) + (let ([ret-type (make-void-type stx)]) + (if (<:_P tenv ret-type ctype) + (values (copy-struct honu:if expr + [honu:if-cond e1] + [honu:if-then e2]) + ret-type) + (raise-read-error-with-stx + "Found if expression without else branch in non-void context" + stx)))))] + [(struct honu:cast (stx obj type)) + (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-any-type (honu:ast-stx obj)) rtype obj)]) + (if (<:_P tenv type ctype) + (values (copy-struct honu:cast expr + [honu:cast-obj e1]) + type) + (raise-honu-type-error stx ctype type)))] + [(struct honu:isa (stx obj _)) + (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-any-type (honu:ast-stx obj)) rtype obj)]) + (let ([ret-type (make-bool-type stx)]) + (if (<:_P tenv ret-type ctype) + (values (copy-struct honu:isa expr + [honu:isa-obj e1]) + ret-type) + (raise-honu-type-error stx ctype ret-type))))] + [(struct honu:member (stx 'my _ name _)) + (cond + [(cenv name) => (lambda (t) + (if (honu:type-disp? t) + (let ([fun-type (make-func-type (honu:type-disp-arg t) (honu:type-disp-ret t))]) + (if (<:_P tenv fun-type ctype) + (values (copy-struct honu:member expr + [honu:member-method? #t]) + fun-type) + (raise-honu-type-error stx ctype fun-type))) + (if (<:_P tenv t ctype) + (values expr t) + (raise-honu-type-error stx ctype t))))] + [else (raise-read-error-with-stx + (format "Static member ~a not found" (syntax-e name)) + stx)])] + [(struct honu:member (stx obj _ name _)) + (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-any-type (honu:ast-stx obj)) rtype obj)]) + (let ([t (get-member-type tenv t1 name)]) + (cond + [(honu:type-disp? t) + (let ([fun-type (make-func-type (honu:ast-stx t) (honu:type-disp-arg t) (honu:type-disp-ret t))]) + (if (<:_P tenv fun-type ctype) + (values (copy-struct honu:member expr + [honu:member-obj e1] + [honu:member-elab t1] + [honu:member-method? #t]) + fun-type) + (raise-honu-type-error stx ctype fun-type)))] + [t + (if (<:_P tenv t ctype) + (values (copy-struct honu:member expr + [honu:member-obj e1] + [honu:member-elab t1]) + t) + (raise-honu-type-error stx ctype t))] + [else (raise-read-error-with-stx + (format "Member ~a not found in type ~a" (syntax-e name) (printable-type t1)) + stx)])))] + [(struct honu:new (stx class type args)) + (let ([class-entry (get-class-entry tenv class)] + [new-type (if type type ctype)]) + ;; the following two checks can only be triggered if there is no type annotation + (if (honu:type-top? new-type) + (raise-read-error-with-stx + "type of instantiation must be explicitly annotated" + stx)) + (if (not (<:_P tenv new-type (make-any-type stx))) + (raise-read-error-with-stx + (format "new statement appears in context of non-interface type ~a" + (printable-type new-type)) + stx)) + ;; the class must implement a subtype of the type we're instantiating it at + (if (not (ormap (lambda (t) + (<:_P tenv t new-type)) + (tenv:class-impls class-entry))) + (raise-read-error-with-stx + (format "class ~a does not implement a subtype of type ~a" + (printable-key class) + (printable-type new-type)) + stx)) + (let ([args (check-inits tenv stx (lambda (e t) + (typecheck-expression tenv cenv lenv t rtype e)) + (tenv:class-inits class-entry) args)]) + (if (<:_P tenv new-type ctype) + (values (copy-struct honu:new expr + [honu:new-type new-type] + [honu:new-args args]) + new-type) + (raise-honu-type-error stx ctype new-type))))] + [(struct honu:while (stx cond body)) + (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-bool-type (honu:ast-stx cond)) rtype cond)] + [(e2 t2) (typecheck-expression tenv cenv lenv (make-void-type (honu:ast-stx body)) rtype body)]) + (let ([ret-type (make-void-type stx)]) + (if (<:_P tenv ret-type ctype) + (values (copy-struct honu:while expr + [honu:while-cond e1] + [honu:while-body e2]) + ret-type) + (raise-honu-type-error stx ctype ret-type))))] + [(struct honu:cond (stx clauses else)) + (if else + (let-values ([(clauses types) (map-two-values (lambda (c) + (typecheck-cond-clause tenv cenv lenv ctype rtype c)) + clauses)] + [(else etype) (typecheck-expression tenv cenv lenv ctype rtype else)]) + (cond + ;; if ctype exists, just use it + ;; + ;; can't do this, see if for reasoning + ;; [ctype + ;; (values (copy-struct honu:cond expr + ;; [honu:cond-clauses clauses]) + ;; ctype)] + ;; otherwise find the most super type of all the branches + [(pick-super-type-from-list tenv (cons etype types)) + => + (lambda (t) + (values (copy-struct honu:cond expr + [honu:cond-clauses clauses] + [honu:cond-else else]) + t))] + ;; otherwise we're hosed for determining a type -- throw an error + [else + (raise-read-error-with-stx + "At least two branches of the cond statement have unrelated types" + stx)])) + ;; if else is #f, there was no else branch, so the cond clauses must be of void type. + (let-values ([(clauses types) (map-two-values (lambda (c) + (typecheck-cond-clause tenv cenv lenv + (make-void-type (honu:ast-stx c)) rtype c)) + clauses)]) + (let ([ret-type (make-void-type stx)]) + (if (<:_P tenv ret-type ctype) + (values (copy-struct honu:cond expr + [honu:cond-clauses clauses]) + ret-type) + (raise-read-error-with-stx + "Cond expression without an else branch found in non-void context" + stx)))))] + [(struct honu:return (stx body)) + ;; returns don't return to their context, but to the context of the method or function call in which + ;; they were invoked. Because of this a) rtype must not be #f (else we're not in a method or function + ;; body) and b) the type of a return statement is the bottom type (same as error). + (if rtype + ;; we use rtype as the context type here, since that's the type that needs to be returned. + (let-values ([(e1 _) (typecheck-expression tenv cenv lenv rtype rtype body)]) + ;; we don't need to check (bottom-type) <:_P ctype, because that's vacuously true. + (values (copy-struct honu:return expr + [honu:return-body e1]) + (make-bottom-type stx))) + (raise-read-error-with-stx + "Return statement found outside body of method or function" + stx))] + [(struct honu:tuple (stx vals)) + (cond + [(honu:type-tuple? ctype) + ;; we have a tuple context type, so use its contents, but make + ;; sure it's the right length. + (if (not (= (length vals) (length (honu:type-tuple-args ctype)))) + (raise-read-error-with-stx + (format "Expected tuple of length ~a, got tuple of length ~a" + (length vals) + (length (honu:type-tuple-args ctype))) + stx)) + (let-values ([(vals types) (map-two-values (lambda (e t) + (typecheck-expression tenv cenv lenv t rtype e)) + vals (honu:type-tuple-args ctype))]) + (values (copy-struct honu:tuple expr + [honu:tuple-vals vals]) + (make-tuple-type stx types)))] + ;; we must be in hte context of a select expression, so + [(honu:type-select? ctype) + (if (not (<= (honu:type-select-slot ctype) (length vals))) + (raise-read-error-with-stx + (format "Expected tuple of length at least ~a, got tuple of length ~a" + (honu:type-select-slot ctype) + (length vals)) + stx)) + (let-values ([(vals types) (map-two-values (lambda (e t) + (typecheck-expression tenv cenv lenv t rtype e)) + vals (gen-top-except-for (length vals) + (honu:type-select-slot ctype) + (honu:type-select-type ctype)))]) + (values (copy-struct honu:tuple expr + [honu:tuple-vals vals]) + (make-tuple-type stx types)))] + ;; if we have the top type here, then we either a) don't care about the type or + ;; b) are going to check it after we return, so just do the simple thing -- since + ;; we have no knowledge about what's wanted, we just check each component with ctype. + [(honu:type-top? ctype) + (let-values ([(vals types) (map-two-values (lambda (e) + (typecheck-expression tenv cenv lenv + (make-top-type (honu:ast-stx e)) rtype e)) + vals)]) + (values (copy-struct honu:tuple expr + [honu:tuple-vals vals]) + (make-tuple-type stx types)))] + [else (raise-read-error-with-stx + "Expected non-tuple expression (or tuple of length 1) here" + stx)])] + [(struct honu:let (_ bindings body)) + (let*-values ([(bindings lenv) (map-and-fold (lambda (bind lenv) + (typecheck-binding tenv cenv lenv rtype bind)) + lenv + bindings)] + [(e1 t1) (typecheck-expression tenv cenv lenv ctype rtype body)]) + (values (copy-struct honu:let expr + [honu:let-bindings bindings] + [honu:let-body e1]) + t1))] + [(struct honu:seq (_ effects value)) + (let-values ([(effects _) (map-two-values (lambda (e) + (typecheck-expression tenv cenv lenv (make-void-type (honu:ast-stx e)) rtype e)) + effects)] + [(e1 t1) (typecheck-expression tenv cenv lenv ctype rtype value)]) + (values (copy-struct honu:seq expr + [honu:seq-effects effects] + [honu:seq-value e1]) + t1))])) + + ;; bindings have no ctype because they're always in the void type context + ;; they return the elaborated binding and a new environment extended with the + ;; type of the bound variable. + (define (typecheck-binding tenv cenv lenv rtype binding) + (match binding + [(struct honu:binding (stx names types value)) + (for-each (lambda (n t) + (if (and (not (and (not n) + (honu:type-top? t))) + (not (type-valid? tenv t))) + (raise-read-error-with-stx + "Type of locally bound variable is undefined" + (honu:ast-stx t)))) + names types) + (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-tuple-type (honu:ast-stx value) types) rtype value)]) + (values (copy-struct honu:binding binding + [honu:binding-value e1]) + (fold (lambda (name type lenv) + (if name + (extend-fenv name type lenv) + lenv)) + lenv names types)))])) + + (define (typecheck-cond-clause tenv cenv lenv ctype rtype clause) + (match clause + [(struct honu:cond-clause (stx pred rhs)) + (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-bool-type (honu:ast-stx pred)) rtype pred)] + [(e2 t2) (typecheck-expression tenv cenv lenv ctype rtype rhs)]) + (values (copy-struct honu:cond-clause clause + [honu:cond-clause-pred e1] + [honu:cond-clause-rhs e2]) + t2))])) + + (define (check-prim-types-for-binop stx tenv t1 t2) + (cond + [(and (honu:type-bot? t1) + (honu:type-prim? t2)) + t2] + [(and (honu:type-prim? t1) + (honu:type-bot? t2)) + t1] + [(and (honu:type-prim? t1) + (honu:type-prim? t2) + (type-equal? tenv t1 t2)) + t1] + [else + (raise-read-error-with-stx + (format "Expected primitive types for binary operator, got ~a and ~a" + (printable-type t1) + (printable-type t2)) + stx)])) + + (define (check-inits tenv stx type-fun inits new-args) + (let-values ([(new-args remaining-inits) + (map-and-fold (lambda (arg inits) + (let*-values ([(init remaining-inits) + (find-init inits (honu:name-arg-name arg))] + [(e1 t1) + (type-fun (honu:name-arg-value arg) (tenv:init-type init))]) + (values (copy-struct honu:name-arg arg + [honu:name-arg-value e1]) + remaining-inits))) + inits new-args)]) + (if (andmap tenv:init-optional? remaining-inits) + new-args + (raise-read-error-with-stx + (format "No value assigned for init arg ~a" + (printable-key (tenv:init-name (car remaining-inits)))) + stx)))) + + ;; find-inits takes the name of an init arg to find in a list of inits and + ;; returns both the init (if found) and the list minus that init + (define (find-init inits name) + (let loop ([inits inits] + [passed '()]) + (cond + [(null? inits) + (raise-read-error-with-stx + (format "class does not have an init arg with name ~a" + (printable-key name)) + name)] + [(tenv-key=? name (tenv:init-name (car inits))) + (values (car inits) + (append (reverse passed) (cdr inits)))] + [else + (loop (cdr inits) + (cons (car inits) passed))]))) + + + ;; assumes a non-empty list + (define (pick-super-type-from-list tenv ts) + (define (pick-super-type-with-acc ts t) + (cond + ;; t is a super-type of all the other branches + [(andmap (lambda (t2) + (<:_P tenv t2 t)) + ts) + t] + ;; if there's a type t2 in ts that is not equal to t + ;; but t <:_P t2, then recur with t2 instead. + [(find (lambda (t2) + (and (not (type-equal? tenv t t2)) + (<:_P tenv t t2))) + ts) + => + (lambda (t) + (pick-super-type-with-acc ts t))] + ;; there are no types in ts that are a super-type of t, + ;; but t is not equal to or a super-type of all the types + ;; in ts, we know that not all the types in the list are + ;; related and thus we fail. + [else #f])) + (pick-super-type-with-acc ts (car ts))) + + (define (gen-top-except-for n k t) + (cond + [(= n 0) (list)] + [(= k 1) (cons t (gen-top-except-for (- n 1) (- k 1) t))] + [else (cons (make-top-type #f) (gen-top-except-for (- n 1) (- k 1) t))])) + + ) \ No newline at end of file diff --git a/collects/honu/private/typechecker/typechecker.ss b/collects/honu/private/typechecker/typechecker.ss new file mode 100644 index 0000000000..ca109f5b9a --- /dev/null +++ b/collects/honu/private/typechecker/typechecker.ss @@ -0,0 +1,181 @@ +(module typechecker mzscheme + + (require (lib "contract.ss") + (lib "plt-match.ss") + (lib "struct.ss") + (all-except (lib "list.ss" "srfi" "1") any) + "../../ast.ss" + "../../readerr.ss" + "../../tenv.ss" + "../../utils.ss" + "typecheck-class-utils.ss" + "typecheck-expression.ss" + "type-utils.ss") + + (provide/contract [typecheck (tenv? + tenv? + (listof honu:defn?) + . -> . + (listof honu:defn?))] + [typecheck-defn (tenv? + tenv? + honu:defn? + . -> . + honu:defn?)]) + ;; since lenv is a hashtable and thus will be mutated, we don't need to return it from + ;; typecheck or typecheck-defn. + (define (typecheck tenv lenv defns) + (map (lambda (d) + (typecheck-defn tenv lenv d)) + defns)) + + (define (typecheck-defn tenv lenv defn) + (match defn + [(struct honu:function (stx name type args body)) + (if (not (type-valid? tenv type)) + (raise-read-error-with-stx + "Return type of function is undefined" + (honu:ast-stx type))) + (for-each (lambda (t) + (if (not (type-valid? tenv t)) + (raise-read-error-with-stx + "Type of function argument is undefined" + (honu:ast-stx type)))) + (map honu:formal-type args)) + (let ([func-type (make-func-type stx (make-tuple-type stx (map honu:formal-type args)) type)]) + (extend-tenv name (make-tenv:value stx func-type) lenv) + (let-values ([(e1 t1) (typecheck-expression tenv (lambda (name) #f) + (fold (lambda (a e) + (extend-fenv (honu:formal-name a) + (honu:formal-type a) + e)) + (wrap-as-function lenv) + args) + type type body)]) + (copy-struct honu:function defn + [honu:function-body e1])))] + [(struct honu:bind-top (stx names types value)) + (for-each (lambda (n t) + (if (and (not (and (not n) + (honu:type-top? t))) + (not (type-valid? tenv t))) + (raise-read-error-with-stx + "Type of top-level bound variable is undefined" + (honu:ast-stx t)))) + names types) + (let-values ([(e1 t1) (typecheck-expression tenv (lambda (name) #f) (wrap-as-function lenv) + (make-tuple-type stx types) #f value)]) + (for-each (lambda (n t) + (if n (extend-tenv n (make-tenv:value stx t) lenv))) + names types) + (copy-struct honu:bind-top defn + [honu:bind-top-value e1]))] + [(struct honu:iface (stx name supers members)) + (for-each (lambda (t) + (if (not (type-valid? tenv t)) + (raise-read-error-with-stx + "No definition for supertype" + (honu:ast-stx t)))) + supers) + (for-each (lambda (m) + (typecheck-member-decl tenv m)) + members) + defn] + [(struct honu:class (stx name type final? impls inits members exports)) + (if (not (type-valid? tenv type)) + (raise-read-error-with-stx + "Self-type of class is undefined" + (honu:ast-stx type))) + (for-each (lambda (t) + (if (not (type-valid? tenv t)) + (raise-read-error-with-stx + "Implemented type is undefined" + (honu:ast-stx type)))) + impls) + (for-each (lambda (t) + (if (not (type-valid? tenv t)) + (raise-read-error-with-stx + "Type of init slot is undefined" + (honu:ast-stx type)))) + (map honu:formal-type inits)) + (let ([cenv (fold (lambda (a e) + (extend-fenv (honu:formal-name a) + (honu:formal-type a) + e)) + (lambda (n) #f) + inits)]) + (let-values ([(members cenv) (typecheck-members tenv cenv (wrap-as-function lenv) type members)]) + (typecheck-exports tenv cenv type impls exports) + (copy-struct honu:class defn + [honu:class-members members])))] + [(struct honu:mixin (stx name type arg-type final? impls inits withs + supernew members-before members-after exports)) + (if (not (type-valid? tenv arg-type)) + (raise-read-error-with-stx + "Argument type of mixin is undefined" + (honu:ast-stx arg-type))) + (if (not (type-valid? tenv type)) + (raise-read-error-with-stx + "Result type of mixin is undefined" + (honu:ast-stx type))) + (for-each (lambda (t) + (if (not (type-valid? tenv t)) + (raise-read-error-with-stx + "Implemented type is undefined" + (honu:ast-stx type)))) + impls) + (for-each (lambda (t) + (if (not (type-valid? tenv t)) + (raise-read-error-with-stx + "Type of init slot is undefined" + (honu:ast-stx type)))) + (map honu:formal-type inits)) + (for-each (lambda (t) + (if (not (type-valid? tenv t)) + (raise-read-error-with-stx + "Type of expected init slot is undefined" + (honu:ast-stx type)))) + (map honu:formal-type withs)) + (let ([cenv (fold (lambda (a e) + (extend-fenv (honu:formal-name a) + (honu:formal-type a) + e)) + (lambda (n) #f) + inits)]) + (let*-values ([(members-before cenv) (typecheck-members tenv cenv (wrap-as-function lenv) type members-before)] + [(supernew) (typecheck-supernew tenv cenv (wrap-as-function lenv) withs supernew)] + [(cenv) (extend-cenv-with-type-members tenv cenv arg-type)] + [(members-after cenv) (typecheck-members tenv cenv (wrap-as-function lenv) type members-after)]) + (typecheck-exports tenv cenv type impls exports) + (copy-struct honu:mixin defn + [honu:mixin-members-before members-before] + [honu:mixin-super-new supernew] + [honu:mixin-members-after members-after])))] + ;; we basically do all the checks when we create the tenv entry for the subclass (plus typechecking the base + ;; class and mixin), so no need to check again. + [(struct honu:subclass (_ _ _ _)) + defn] + [else (raise-read-error-with-stx + "Haven't typechecked that type of definition yet." + (honu:ast-stx defn))])) + + (define (typecheck-member-decl tenv member) + (match member + [(struct honu:field-decl (stx name type)) + (if (not (type-valid? tenv type)) + (raise-read-error-with-stx + "Type of field is undefined" + stx))] + [(struct honu:method-decl (stx name type args)) + (if (not (type-valid? tenv type)) + (raise-read-error-with-stx + "Return type of method is undefined" + (honu:ast-stx type))) + (for-each (lambda (t) + (if (not (type-valid? tenv t)) + (raise-read-error-with-stx + "Type of method argument is undefined" + (honu:ast-stx type)))) + args)])) + + ) diff --git a/collects/honu/read-error-with-stx.ss b/collects/honu/readerr.ss similarity index 95% rename from collects/honu/read-error-with-stx.ss rename to collects/honu/readerr.ss index e1efae1af0..6d99c59979 100644 --- a/collects/honu/read-error-with-stx.ss +++ b/collects/honu/readerr.ss @@ -1,4 +1,4 @@ -(module read-error-with-stx mzscheme +(module readerr mzscheme (require (lib "readerr.ss" "syntax")) diff --git a/collects/honu/tenv-utils.ss b/collects/honu/tenv-utils.ss index 53b369acf9..369d4ddc54 100644 --- a/collects/honu/tenv-utils.ss +++ b/collects/honu/tenv-utils.ss @@ -1,118 +1,558 @@ (module tenv-utils mzscheme - (require "read-error-with-stx.ss" + (require "readerr.ss" "ast.ss" "tenv.ss" - "private/typechecker/honu-type-utils.ss" + "private/typechecker/type-utils.ss" (lib "plt-match.ss") + (lib "struct.ss") (lib "list.ss" "srfi" "1")) + (define (make-struct-type-decls inits mfidefns) + (define (convert-to-decl d) + (cond + ;; can come from inits + [(honu:formal? d) + (make-honu:field-decl (honu:ast-stx d) + (honu:formal-name d) + (honu:formal-type d))] + ;; can come from mdidefns + [(honu:init-field? d) + (make-honu:field-decl (honu:ast-stx d) + (honu:init-field-name d) + (honu:init-field-type d))] + [(honu:field? d) + (make-honu:field-decl (honu:ast-stx d) + (honu:field-name d) + (honu:field-type d))] + [(honu:method? d) + (make-honu:method-decl (honu:ast-stx d) + (honu:method-name d) + (honu:method-type d) + (map honu:formal-type (honu:method-formals d)))])) + (map convert-to-decl (append inits mfidefns))) + + (define (make-struct-export typ inits mdidefns members) + (define (grab-name d) + (cond + ;; can come from members + [(tenv:member? d) (tenv:member-name d)] + ;; 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)])) + (let ([binds (map (lambda (m) + (let ([name (grab-name m)]) + (make-honu:exp-bind name name))) (append inits mdidefns members))]) + (make-honu:export #f typ binds))) + + (define (tenv-create-error skipped) + ;; only subclasses and substructs can be skipped, so if the base of one of them + ;; is in the skipped list as well, then we have a cycle. If not, then there's + ;; some missing definition. + ;; + ;; well, this isn't true anymore, so check to see if it's an iface first, which + ;; is the other possibility for skipping. We need to check a similar kind of + ;; thing to see if the type hierarchy is a cycle or there's just something missing. + ;; + ;; FIXME: This function almost certainly does not always give the correct error message + ;; (for example, it may give a cycle error when it turns out that the first thing + ;; in the skipped list just depends on something else which just had stuff missing, + ;; so there should have been a definitions needed missing error. Will revisit later. + (if (honu:iface? (car skipped)) + (let ([supers (honu:iface-supers (car skipped))]) + (if (find (lambda (d) + (cond + [(honu:iface? d) (s:member (honu:iface-name d) supers tenv-key=?)] + [else #f])) + (cdr skipped)) + (raise-read-error-with-stx + (format "Type ~a is involved in a type hierarchy cycle" + (printable-key (honu:iface-name (car skipped)))) + (honu:iface-name (car skipped))) + (raise-read-error-with-stx + (format "At least one supertype of type ~a is missing" + (printable-key (honu:iface-name (car skipped)))) + (honu:iface-name (car skipped))))) + (let ([class-name (cond + [(honu:subclass? (car skipped)) (honu:subclass-name (car skipped))] + [(honu:substruct? (car skipped)) (honu:substruct-name (car skipped))])] + [base-name (cond + [(honu:subclass? (car skipped)) (honu:subclass-base (car skipped))] + [(honu:substruct? (car skipped)) (honu:substruct-base (car skipped))])]) + (if (find (lambda (d) + (cond + [(honu:subclass? d) (tenv-key=? base-name (honu:subclass-name d))] + [(honu:substruct? d) (tenv-key=? base-name (honu:substruct-name d))] + [else #f])) + (cdr skipped)) + (raise-read-error-with-stx + (format "Class ~a is involved in a class hierarchy cycle" (printable-key class-name)) + class-name) + (raise-read-error-with-stx + (format "Definitions needed for definition of class ~a are missing" (printable-key class-name)) + class-name))))) + (provide add-defns-to-tenv add-defn-to-tenv) (define (add-defns-to-tenv defns tenv) - (for-each (lambda (d) - (add-defn-to-tenv d tenv)) - defns)) + (let loop ([defns defns] + [skipped '()] + [changed? #f] + [new-defns '()]) + (cond + ;; we're done, so return the new defns + [(and (null? defns) (null? skipped)) + (reverse new-defns)] + ;; we skipped some, so go back and check those. + [(null? defns) + (if changed? + (loop skipped '() #f new-defns) + ;; we didn't change anything on the last run, + ;; so we must either have a cycle in the class graph + ;; or there are missing definitions. Raise an + ;; appropriate error for the first definition. + (tenv-create-error skipped))] + ;; for functions and top level bindings, we + ;; don't add them here, so just skip them. + [(or (honu:function? (car defns)) + (honu:bind-top? (car defns))) + (loop (cdr defns) skipped #t (cons (car defns) new-defns))] + [(honu:iface? (car defns)) + (let loop2 ([supers (map honu:type-iface-name (honu:iface-supers (car defns)))]) + (cond + ;; if we went through all the supers with them being defined, + ;; then we can add this type as well. + [(null? supers) + (loop (cdr defns) skipped #t (cons (add-defn-to-tenv (car defns) tenv) new-defns))] + ;; if there is an entry, we check to make sure it's a type, and + ;; if it is, then we continue looping in the inner loop + [(get-tenv-entry tenv (car supers)) + => + (lambda (e) + (if (not (tenv:type? e)) + (raise-read-error-with-stx + (format "~a is not a type" (printable-key (car supers))) + (car supers)) + (loop2 (cdr supers))))] + ;; if there is no entry, then we can't add this type yet, so + ;; recur on the outer loop with this type being skipped. + [else + (loop (cdr defns) (cons (car defns) skipped) changed? new-defns)]))] + ;; for classes and mixins, we don't use the tenv to create + ;; their entries, so we just run them through as we hit them. + [(or (honu:class? (car defns)) + (honu:mixin? (car defns))) + (loop (cdr defns) skipped #t (cons (add-defn-to-tenv (car defns) tenv) new-defns))] + ;; for structs, we will get back a list of two things: the new type + ;; and the new class definition, so append those onto new-defns + [(honu:struct? (car defns)) + (match (car defns) + [(struct honu:struct (stx name type final? impls inits members exports)) + (let ([new-iface (make-honu:iface stx (honu:type-iface-name type) (list) + (make-struct-type-decls inits members))] + [new-class (make-honu:class stx name type final? (cons type impls) inits members + (cons (make-struct-export type inits members (list)) exports))]) + (loop (cdr defns) skipped #t (cons (add-defn-to-tenv new-class tenv) + (cons (add-defn-to-tenv new-iface tenv) new-defns))))])] + ;; for subclasses, we check to make sure the base (and its self-type) and + ;; the mixin (and its arg-type) are in the tenv. If not, skip it. + ;; Give appropriate errors for each thing that can go wrong. + [(honu:subclass? (car defns)) + (let* ([base (get-tenv-entry tenv (honu:subclass-base (car defns)))] + [selftype (if (and base (tenv:class? base)) + (get-tenv-entry tenv (honu:type-iface-name (tenv:class-sub-type base))) + #f)] + [mixin (get-tenv-entry tenv (honu:subclass-mixin (car defns)))] + [argtype (if (and mixin (tenv:mixin? mixin)) + (get-tenv-entry tenv (honu:type-iface-name (tenv:mixin-arg-type mixin))) + #f)]) + (cond + [(and base (not (tenv:class? base))) + (raise-read-error-with-stx + "Base class for subclass definition is not a class" + (honu:subclass-base (car defns)))] + [(and selftype (not (tenv:type? selftype))) + (raise-read-error-with-stx + "Selftype for class is not a type" + (honu:ast-stx (tenv:class-sub-type base)))] + [(and mixin (not (tenv:mixin? mixin))) + (raise-read-error-with-stx + "Mixin for subclass definition is not a mixin" + (honu:subclass-mixin (car defns)))] + [(and argtype (not (tenv:type? argtype))) + (raise-read-error-with-stx + "Argument type for mixin is not a type" + (honu:ast-stx (tenv:mixin-arg-type mixin)))] + [(and base selftype mixin argtype) + ;; if the base is final, then we can't extend it. + (if (tenv:class-final? base) + (raise-read-error-with-stx + (format "Cannot apply mixin to final class ~a" + (printable-key base)) + base)) + ;; if the base's selftype does not match the mixin's argtype, + ;; we cannot apply the mixin to the base. + (if (not (<:_P tenv (tenv:class-sub-type base) (tenv:mixin-arg-type mixin))) + (raise-read-error-with-stx + (format "Class ~a (~a) is not of an appropriate type (~a) for mixin ~a" + (printable-key (honu:subclass-base (car defns))) + (printable-type (tenv:class-sub-type base)) + (printable-type (tenv:mixin-arg-type mixin)) + (printable-key (honu:subclass-mixin (car defns)))) + (honu:subclass-base (car defns)))) + (loop (cdr defns) skipped #t (cons (add-defn-to-tenv (car defns) tenv) new-defns))] + ;; if we get here, we cannot yet make the entry for this subclass, + ;; so skip it. + [else + (loop (cdr defns) (cons (car defns) skipped) changed? new-defns)]))] + ;; for substructs, we just deconstruct it and then let the subclass logic catch any problems. + ;; we do a couple of checks, because getting the type right for the substruct requires having + ;; the argtype of the substruct. + [(honu:substruct? (car defns)) + (match (car defns) + [(struct honu:substruct (stx name type base arg-type final? impls inits withs super-new + members-before members-after exports)) + (let ([argtype (get-tenv-entry tenv (honu:type-iface-name arg-type))]) + (cond + [(and argtype (not (tenv:type? argtype))) + (raise-read-error-with-stx + "Type at which we are extending is not a type" + (honu:ast-stx arg-type))] + [argtype + (let* ([new-iface (make-honu:iface stx (honu:type-iface-name type) (list arg-type) + (make-struct-type-decls inits + (append members-before members-after)))] + [mixin-name (datum->syntax-object name (string->symbol + (string-append "$" (symbol->string (printable-key name)))) + name)] + [new-mixin (make-honu:mixin stx mixin-name type arg-type final? (cons type impls) inits withs + super-new members-before members-after + (cons (make-struct-export type + inits + (append members-before members-after) + (tenv:type-members argtype)) + exports))] + [new-sclass (make-honu:subclass stx name base mixin-name)]) + (loop (cons new-sclass (cdr defns)) skipped #t (cons (add-defn-to-tenv new-mixin tenv) + (cons (add-defn-to-tenv new-iface tenv) new-defns))))] + [else + (loop (cdr defns) (cons (car defns) skipped) changed? new-defns)]))])]))) + + (define (check-super-for-members tenv name members super-name) + (match (get-tenv-entry tenv super-name) + [(struct tenv:type (_ _ super-members super-inherited)) + ;; here we make sure to use both defined members and inherited members + (let loop ([super-members (append super-members super-inherited)] + [inherited '()]) + (cond + ;; we've checked all the super members + [(null? super-members) + (reverse inherited)] + ;; if we find a member of the subtype that matches the currently inspected member of + ;; the supertype... + [(find (lambda (m) + (tenv-key=? (tenv:member-name m) + (tenv:member-name (car super-members)))) + members) + => + (lambda (m) + ;; if we eventually allow co-/contra-variance here, this is where + ;; we'd do it. + (if (honu:type-disp? (tenv:member-type (car super-members))) + (if (<:_P tenv (tenv:member-type m) (tenv:member-type (car super-members))) + (loop (cdr super-members) inherited) + (raise-read-error-with-stx + (format "Type ~a defines member ~a with type ~a, is not a subtype of type ~a as defined in supertype ~a" + (printable-key name) + (printable-key (tenv:member-name m)) + (printable-type (tenv:member-type m)) + (printable-type (tenv:member-type (car super-members))) + (printable-key super-name)) + (tenv:member-stx m))) + ;; this handles mutable fields -- we don't have immutable fields yet + (if (type-equal? tenv (tenv:member-type m) (tenv:member-type (car super-members))) + (loop (cdr super-members) inherited) + (raise-read-error-with-stx + (format "Type ~a defines member ~a with type ~a, was defined with type ~a in supertype ~a" + (printable-key name) + (printable-key (tenv:member-name m)) + (printable-type (tenv:member-type m)) + (printable-type (tenv:member-type (car super-members))) + (printable-key super-name)) + (tenv:member-stx m)))))] + ;; if there was no match, then this is one we inherited and for which we did not give + ;; an explicit declaration. + [else + (loop (cdr super-members) (cons (cons super-name (car super-members)) inherited))]))])) + + (define (mangle-disp-type iface member) + (let ([member-type (tenv:member-type member)]) + (if (honu:type-disp? member-type) + (copy-struct tenv:member member + [tenv:member-type (make-method-type (honu:ast-stx member-type) + iface + (honu:type-disp-arg member-type) + (honu:type-disp-ret member-type))]) + member))) + (define (type-equal-modulo-disp? tenv t1 t2) + (let ([t1 (if (honu:type-disp? t1) + (make-func-type (honu:ast-stx t1) + (honu:type-disp-arg t1) + (honu:type-disp-ret t1)) + t1)] + [t2 (if (honu:type-disp? t2) + (make-func-type (honu:ast-stx t2) + (honu:type-disp-arg t2) + (honu:type-disp-ret t2)) + t2)]) + (type-equal? tenv t1 t2))) + + (define (check-and-remove-duplicate-members tenv subtype inherited-members) + (let loop ([inherited-members inherited-members] + [unique-members '()]) + (if (null? inherited-members) + (reverse unique-members) + (let ([current-member (cdr (car inherited-members))]) + (let-values ([(matching-members rest-members) + (partition (lambda (p) + (tenv-key=? (tenv:member-name current-member) + (tenv:member-name (cdr p)))) + (cdr inherited-members))]) + (let loop2 ([matching-members matching-members]) + (cond + [(null? matching-members) + (loop rest-members (cons (mangle-disp-type (make-iface-type subtype subtype) + current-member) + unique-members))] + ;; members coming from supers that are _not_ redefined must be exactly equal + ;; (modulo the dispatch arguments of methods) + ;; + ;; doesn't matter which we keep, so we'll just keep the first one that matched. + [(type-equal-modulo-disp? tenv + (tenv:member-type current-member) + (tenv:member-type (cdr (car matching-members)))) + (loop2 (cdr matching-members))] + [else + (raise-read-error-with-stx + (format "For type ~a, supertype ~a has type ~a for member ~a, whereas supertype ~a has type ~a" + (printable-key subtype) + (printable-key (car (car inherited-members))) + (printable-type (tenv:member-type current-member)) + (printable-key (tenv:member-name current-member)) + (printable-key (car (car matching-members))) + (printable-type (tenv:member-type (cdr (car matching-members))))) + subtype)]))))))) + (define (add-defn-to-tenv defn tenv) (match defn - [(struct honu-function (src-stx name t _ arg-types _)) - (extend-tenv name (make-tenv-func src-stx arg-types t) tenv)] - [(struct honu-type-defn (src-stx name supers decls)) - (extend-tenv name (make-tenv-type src-stx supers decls) tenv)] - [(struct honu-class (src-stx name t f? i-names i-types impls defns _)) - (extend-tenv name (make-tenv-class src-stx t impls - (get-inits i-names i-types defns) - f? #f) tenv)] - [(struct honu-mixin (src-stx name type arg-type final? init-names init-types - impls with-names with-types defns-before _ defns-after _)) - (extend-tenv name (make-tenv-mixin src-stx arg-type type impls - (get-inits init-names init-types + ;; for types, we need to recur over our supertypes, make sure that we don't have any definitions that countermand + ;; those in our super classes (which will also make sure that our superclass definitions are consistent), and + ;; then we will add any member definitions in them that are _not_ declared in this type. + ;; + ;; If we get here, we know that all the supers are in the tenv and are type entries, so we can use + ;; get-type-entry safely. + [(struct honu:iface (src-stx name supers members)) + (let* ([tenv-members (convert-members (make-iface-type name name) members)] + [inherited-decls + (apply append (map (lambda (n) (check-super-for-members tenv name tenv-members n)) + (map honu:type-iface-name supers)))] + [unique-inherited + ;; remove duplicate entries for the same member name, making sure they match. + (check-and-remove-duplicate-members tenv name inherited-decls)]) + (extend-tenv name + (make-tenv:type src-stx supers tenv-members unique-inherited) + tenv) + defn)] + ;; for classes and mixins, just add a new appropriate entry. + [(struct honu:class (src-stx name t f? impls inits defns _)) + (extend-tenv name (make-tenv:class src-stx t impls + (get-inits inits defns) + f? #f) tenv) + defn] + [(struct honu:mixin (src-stx name type arg-type final? impls inits + withs _ defns-before defns-after _)) + (extend-tenv name (make-tenv:mixin src-stx arg-type type impls + (get-inits inits (append defns-before defns-after)) - with-names with-types final?) tenv)] - [(struct honu-subclass (src-stx name mixin base)) - (if (tenv-class-final? (get-class-entry base tenv)) - (raise-read-error-with-stx - (format "Cannot apply mixin to final class ~a" - (printable-key base)) - base)) - (extend-tenv name (generate-subclass-tenv defn tenv) tenv)])) + withs final?) tenv) + defn] + ;; all the heavy lifting of subclasses is in generate-subclass-tenv, + ;; which does things like make sure that the withs of the mixin are satisfied + ;; by the base, collects all the inits needed for the resulting class, etc. + [(struct honu:subclass (src-stx name base mixin)) + (extend-tenv name (generate-subclass-tenv defn tenv) tenv) + defn])) - (define (get-inits init-names init-types defns) + (define (convert-members iface members) + (let loop ([members members] + [converted '()]) + (if (null? members) + (reverse converted) + (match (car members) + [(struct honu:field-decl (stx name type)) + (loop (cdr members) + (cons (make-tenv:member stx name type) converted))] + [(struct honu:method-decl (stx name type arg-types)) + (loop (cdr members) + (cons (make-tenv:member stx name (make-method-type stx + iface + (make-tuple-type stx arg-types) + type)) + converted))])))) + + (define (get-inits inits defns) (let ([init-fields (filter (lambda (d) - (honu-init-field? d)) + (honu:init-field? d)) defns)]) - (append (map (lambda (n t) - (make-tenv-init n t #t)) - init-names init-types) + (append (map (lambda (i) + (make-tenv:init (honu:formal-name i) + (honu:formal-type i) + #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) - #t) - (make-tenv-init (honu-init-field-name d) - (honu-init-field-type d) - #f))) + (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))) init-fields)))) (define (generate-subclass-tenv defn tenv) - (let ([base (get-class-entry (honu-subclass-base defn) tenv)] - [mixin (get-mixin-entry (honu-subclass-mixin defn) tenv)]) - (if (not (<:_P tenv (tenv-class-sub-type base) (tenv-mixin-arg-type mixin))) - (raise-read-error-with-stx - (format "Class ~a is not of an appropriate type for mixin ~a" - (printable-key (honu-subclass-base defn)) - (printable-key (honu-subclass-mixin defn))) - (honu-subclass-base defn))) + (let ([base (get-class-entry tenv (honu:subclass-base defn))] + [mixin (get-mixin-entry tenv (honu:subclass-mixin defn))]) (let ([new-inits (remove-used-inits tenv defn - (tenv-class-inits base) - (tenv-mixin-used-names mixin) - (tenv-mixin-used-types mixin))]) - (make-tenv-class (honu-ast-src-stx defn) - (tenv-mixin-sub-type mixin) - (tenv-mixin-impls mixin) - (append (tenv-mixin-inits mixin) + (tenv:class-inits base) + (tenv:mixin-withs mixin))]) + (make-tenv:class (honu:ast-stx defn) + (tenv:mixin-sub-type mixin) + (tenv:mixin-impls mixin) + (append (tenv:mixin-inits mixin) new-inits) - (tenv-mixin-final? mixin) - (honu-subclass-base defn))))) + (tenv:mixin-final? mixin) + (honu:subclass-base defn))))) - (define (remove-used-inits tenv defn old-inits used-names used-types) + (define (remove-used-inits tenv defn old-inits withs) (let loop ([old-inits old-inits] - [used-names used-names] - [used-types used-types] + [withs withs] [new-inits '()]) (if (null? old-inits) - (if (not (null? used-names)) + (if (not (null? withs)) (raise-read-error-with-stx (format "Class ~a does not have an init arg ~a with the correct type" - (printable-key (honu-subclass-base defn)) - (printable-key (car used-names))) - (honu-subclass-base defn)) + (printable-key (honu:subclass-base defn)) + (printable-key (honu:formal-name (car withs)))) + (honu:subclass-base defn)) (reverse new-inits)) (let* ([curr (car old-inits)] - [index (list-index (lambda (n) - (tenv-key=? n (tenv-init-name curr))) - used-names)]) + [index (list-index (lambda (w) + (tenv-key=? (honu:formal-name w) (tenv:init-name curr))) + withs)]) (if index - (if (<:_P tenv (list-ref used-types index) (tenv-init-type curr)) + (if (<:_P tenv (honu:formal-type (list-ref withs index)) (tenv:init-type curr)) (loop (cdr old-inits) - (append (take used-names index) - (drop used-names (+ index 1))) - (append (take used-types index) - (drop used-types (+ index 1))) + (append (take withs index) + (drop withs (+ index 1))) new-inits) - (if (tenv-init-optional? curr) - (loop (cdr old-inits) - used-names - used-types - (cons curr new-inits)) - (raise-read-error-with-stx - (format "Mixin ~a needs an incompatible type for init arg ~a" - (printable-key (honu-subclass-mixin defn)) - (printable-key (car used-names))) - (honu-subclass-mixin defn)))) + (raise-read-error-with-stx + (format "Mixin ~a needs an incompatible type for init arg ~a" + (printable-key (honu:subclass-mixin defn)) + (printable-key (honu:formal-name (car withs)))) + (honu:subclass-mixin defn))) (loop (cdr old-inits) - used-names - used-types + withs (cons curr new-inits))))))) + + (provide display-lenv display-tenv) + (define (display-lenv lenv) + (tenv-for-each lenv + (lambda (k v) + (display (format "~a = ~a~%" + (printable-key k) + (printable-type (tenv:value-type v))))))) + + (define (display-tenv tenv) + (tenv-for-each tenv + (lambda (k v) + (display (format "~a = " (printable-key k))) + (display-tenv-entry v)))) + + (define (display-tenv-entry entry) + (match entry + [(struct tenv:type (_ supers members inherited)) + (display (format "type {~%")) + (display (format " supers = ")) + (if (null? supers) (display "(none)")) + (for-each (lambda (s) (display (format "~a " (printable-type s)))) supers) + (newline) + (display (format " members = ")) + (if (null? members) (display "(none)")) + (newline) + (for-each (lambda (m) + (match m + [(struct tenv:member (_ name type)) + (display (format " ~a : ~a~%" + (printable-key name) + (printable-type type)))])) + members) + (display (format " inherited members = ")) + (if (null? inherited) (display "(none)")) + (newline) + (for-each (lambda (m) + (match m + [(struct tenv:member (_ name type)) + (display (format " ~a : ~a~%" + (printable-key name) + (printable-type type)))])) + inherited) + (display (format "}~%"))] + [(struct tenv:class (_ sub-type impls inits final? super)) + (display (format "class {~%")) + (display (format " final? = ~a~%" (if final? "yes" "no"))) + (display (format " super = ~a~%" (if super (printable-key super) "(none)"))) + (display (format " sub-type = ~a~%" (printable-type sub-type))) + (display (format " impls = ")) + (for-each (lambda (s) (display (format "~a " (printable-type s)))) impls) + (if (null? impls) (display "(none)")) + (newline) + (display (format " inits = ")) + (if (null? inits) (display "(none)")) + (newline) + (for-each (lambda (i) (display (format " ~a : ~a ~a~%" + (printable-key (tenv:init-name i)) + (printable-type (tenv:init-type i)) + (if (tenv:init-optional? i) "(opt)" "")))) + inits) + (display (format "}~%"))] + [(struct tenv:mixin (_ arg-type sub-type impls inits withs final?)) + (display (format "mixin {~%")) + (display (format " final? = ~a~%" (if final? "yes" "no"))) + (display (format " arg-type = ~a~%" (printable-type arg-type))) + (display (format " sub-type = ~a~%" (printable-type sub-type))) + (display (format " impls = ")) + (for-each (lambda (s) (display (format "~a " (printable-type s)))) impls) + (if (null? impls) (display "(none)")) + (newline) + (display (format " inits = ")) + (if (null? inits) (display "(none)")) + (newline) + (for-each (lambda (i) (display (format " ~a : ~a ~a~%" + (printable-key (tenv:init-name i)) + (printable-type (tenv:init-type i)) + (if (tenv:init-optional? i) "(opt)" "")))) + inits) + (display (format " withs = ")) + (if (null? withs) (display "(none)")) + (newline) + (for-each (lambda (i) (display (format " ~a : ~a ~a~%" + (printable-key (tenv:init-name i)) + (printable-type (tenv:init-type i)) + (if (tenv:init-optional? i) "(opt)" "")))) + withs) + (display (format "}~%"))])) ) diff --git a/collects/honu/tenv.ss b/collects/honu/tenv.ss index 65d805a78a..b10882bf31 100644 --- a/collects/honu/tenv.ss +++ b/collects/honu/tenv.ss @@ -1,119 +1,226 @@ (module tenv mzscheme - (require (lib "boundmap.ss" "syntax") - (lib "contract.ss")) + (require (all-except (lib "list.ss" "srfi" "1") any) + (lib "boundmap.ss" "syntax") + (lib "contract.ss") + "ast.ss" + "readerr.ss") - (require "ast.ss") - (require "read-error-with-stx.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))) - (provide (struct tenv-entry (src-stx)) - (struct tenv-init (name type optional?)) - (struct tenv-type (supers members)) - (struct tenv-class (sub-type impls inits final? super)) - (struct tenv-mixin (arg-type sub-type impls inits - used-names used-types final?)) - (struct tenv-func (arg-types return-type))) - - (define-struct tenv-entry (src-stx)) + (define-struct tenv:entry (stx) #f) - (define-struct tenv-init (name type optional?)) + (define-struct tenv:init (name type optional?) #f) + + (define-struct tenv:member (stx name type) #f) + + ;; members will be a hashtable from member names to types -- if I ever get around to it + (define-struct (tenv:type tenv:entry) (supers members inherited) #f) + (define-struct (tenv:class tenv:entry) (sub-type impls inits final? super) #f) + (define-struct (tenv:mixin tenv:entry) (arg-type sub-type impls inits + withs final?) #f) + ;; this is for top-level function and value bindings + (define-struct (tenv:value tenv:entry) (type) #f) + + (define builtin-list + (list (cons #'error (make-honu:type-func #f + (make-honu:type-prim #f 'string) + (make-honu:type-bot #f))) + (cons #'printString (make-honu:type-func #f + (make-honu:type-prim #f 'string) + (make-honu:type-tuple #f '()))) + (cons #'printLine (make-honu:type-func #f + (make-honu:type-prim #f 'string) + (make-honu:type-tuple #f '()))) + (cons #'readChar (make-honu:type-func #f + (make-honu:type-tuple #f '()) + (make-honu:type-prim #f 'char))) + (cons #'readLine (make-honu:type-func #f + (make-honu:type-tuple #f '()) + (make-honu:type-prim #f 'string))) + (cons #'intToString (make-honu:type-func #f + (make-honu:type-prim #f 'int) + (make-honu:type-prim #f 'string))) + (cons #'floatToString (make-honu:type-func #f + (make-honu:type-prim #f 'float) + (make-honu:type-prim #f 'string))) + (cons #'charToString (make-honu:type-func #f + (make-honu:type-prim #f 'char) + (make-honu:type-prim #f 'string))) + (cons #'stringToInt (make-honu:type-func #f + (make-honu:type-prim #f 'string) + (make-honu:type-prim #f 'int))) + (cons #'stringToFloat (make-honu:type-func #f + (make-honu:type-prim #f 'string) + (make-honu:type-prim #f 'float))) + (cons #'strlen (make-honu:type-func #f + (make-honu:type-prim #f 'string) + (make-honu:type-prim #f 'int))) + (cons #'substr (make-honu:type-func #f + (make-honu:type-tuple #f + (list (make-honu:type-prim #f 'string) + (make-honu:type-prim #f 'int) + (make-honu:type-prim #f 'int))) + (make-honu:type-prim #f 'string))) + (cons #'charAt (make-honu:type-func #f + (make-honu:type-tuple #f + (list (make-honu:type-prim #f 'string) + (make-honu:type-prim #f 'int))) + (make-honu:type-prim #f 'char))))) - ;; members will be a hashtable from member names to types - (define-struct (tenv-type tenv-entry) (supers members)) - (define-struct (tenv-class tenv-entry) (sub-type impls inits final? super)) - (define-struct (tenv-mixin tenv-entry) (arg-type sub-type impls inits - used-names used-types final?)) - (define-struct (tenv-func tenv-entry) (arg-types return-type)) - (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) + (identifier? tenv:entry? . -> . any) . -> . - list?)]) + list?)] + [tenv-for-each (tenv? + (identifier? tenv:entry? . -> . void?) + . -> . + void?)]) (define printable-key syntax-e) (define tenv-key=? bound-identifier=?) + (define (tenv-keystring (syntax-e k1)) + (symbol->string (syntax-e k2)))) (define tenv-map bound-identifier-mapping-map) + (define tenv-for-each bound-identifier-mapping-for-each) (provide/contract [empty-tenv (-> tenv?)] - [extend-tenv (identifier? tenv-entry? tenv? . -> . void?)] + [get-builtin-lenv (-> tenv?)] + [extend-tenv (identifier? tenv:entry? tenv? . -> . void?)] [create-tenv ((listof identifier?) - (listof tenv-entry?) + (listof tenv:entry?) . -> . tenv?)]) (define (empty-tenv) (make-bound-identifier-mapping)) + (define (get-builtin-lenv) + (let ([tenv (empty-tenv)]) + (for-each (lambda (n t) + (extend-tenv n (make-tenv:value #f t) tenv)) + (map car builtin-list) + (map cdr builtin-list)) + tenv)) (define (extend-tenv key val tenv) - (if (get-tenv-entry key tenv) - (raise-read-error-with-stx - (format "~a already bound by top-level definition" (printable-key key)) - key) + (if (get-tenv-entry tenv key) + (if (eqv? (string-ref (symbol->string (printable-key key)) 0) #\$) + (raise-read-error-with-stx + (format "~a already bound by a subclass or substruct" + (substring (symbol->string (printable-key key)) 1)) + key) + (raise-read-error-with-stx + (format "~a already bound by top-level definition" (printable-key key)) + key)) (bound-identifier-mapping-put! tenv key val))) (define (create-tenv keys vals) (let ((table (empty-tenv))) (begin (for-each extend-tenv table keys vals) table))) - ;(provide get-tenv-entry get-tenv-member-entry) - (define (get-tenv-entry key tenv) + ;; 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 (tenv? identifier? . -> . (union tenv:entry? false/c))]) + (define (get-tenv-entry tenv key) (bound-identifier-mapping-get tenv key (lambda () #f))) - (define (get-tenv-member-entry type member tenv) - (bound-identifier-mapping-get (tenv-type-members (get-tenv-entry type tenv)) - member - (lambda () #f))) - (provide/contract [get-type-entry (identifier? tenv? . -> . tenv-type?)] - [get-class-entry (identifier? tenv? . -> . tenv-class?)] - [get-mixin-entry (identifier? tenv? . -> . tenv-mixin?)] - [get-func-entry (identifier? tenv? . -> . tenv-func?)]) - (define (get-type-entry name tenv) - (let ([entry (get-tenv-entry name tenv)]) - (cond - [(not entry) - (raise-read-error-with-stx - (format "No type defined with name ~a" (printable-key name)) - name)] - [(not (tenv-type? entry)) - (raise-read-error-with-stx - (format "Definition of ~a is not a type" (printable-key name)) - name)] - [else entry]))) - (define (get-class-entry name tenv) - (let ([entry (get-tenv-entry name tenv)]) + (provide/contract [get-type-entry (tenv? + (union honu:type-iface? + honu:type-iface-top?) . -> . tenv:type?)] + [get-class-entry (tenv? identifier? . -> . tenv:class?)] + [get-mixin-entry (tenv? identifier? . -> . tenv:mixin?)] + [get-member-type (tenv? + (union honu:type-iface? + honu:type-iface-top?) + identifier? . -> . honu:type?)] + [get-value-entry (tenv? identifier? . -> . tenv:value?)]) + (define (get-type-entry tenv type) + (if (honu:type-iface-top? type) + (make-tenv:type #f (list) (list) (list)) + (let* ([name (honu:type-iface-name type)] + [entry (get-tenv-entry tenv name)]) + (cond + [(not entry) + (raise-read-error-with-stx + (format "No type defined with name ~a" (printable-key name)) + name)] + [(not (tenv:type? entry)) + (raise-read-error-with-stx + (format "Definition of ~a is not a type" (printable-key name)) + name)] + [else entry])))) + (define (get-class-entry tenv name) + (let ([entry (get-tenv-entry tenv name)]) (cond [(not entry) (raise-read-error-with-stx (format "No class defined with name ~a" (printable-key name)) name)] - [(not (tenv-class? entry)) + [(not (tenv:class? entry)) (raise-read-error-with-stx (format "Definition of ~a is not a class" (printable-key name)) name)] [else entry]))) - (define (get-mixin-entry name tenv) - (let ([entry (get-tenv-entry name tenv)]) + (define (get-mixin-entry tenv name) + (let ([entry (get-tenv-entry tenv name)]) (cond [(not entry) (raise-read-error-with-stx (format "No mixin defined with name ~a" (printable-key name)) name)] - [(not (tenv-mixin? entry)) + [(not (tenv:mixin? entry)) (raise-read-error-with-stx (format "Definition of ~a is not a mixin" (printable-key name)) name)] [else entry]))) - (define (get-func-entry name tenv) - (let ([entry (get-tenv-entry name tenv)]) + (define (get-member-type tenv type name) + (let* ([entry (get-type-entry tenv type)] + [mtype (find (lambda (m) + (tenv-key=? (tenv:member-name m) name)) + (append (tenv:type-members entry) + (tenv:type-inherited entry)))]) + (if mtype + (tenv:member-type mtype) + (raise-read-error-with-stx + (format "No member named ~a found for type ~a" + (printable-key name) + (if (honu:type-iface-top? type) + 'Any + (printable-key (honu:type-iface-name type)))) + name)))) + (define (get-value-entry tenv name) + (let ([entry (get-tenv-entry tenv name)]) (cond [(not entry) (raise-read-error-with-stx - (format "No function defined with name ~a" (printable-key name)) + (format "No function or top-level binding defined with name ~a" (printable-key name)) name)] - [(not (tenv-func? entry)) + [(not (tenv:value? entry)) (raise-read-error-with-stx - (format "Definition of ~a is not a function" (printable-key name)) + (format "Definition of ~a is not a function definition or value binding" (printable-key name)) name)] [else entry]))) + + (provide wrap-as-function extend-fenv) + + (define (wrap-as-function tenv) + (lambda (name) + (let ([entry (bound-identifier-mapping-get tenv name (lambda () #f))]) + (if entry (tenv:value-type entry) #f)))) + + (define (extend-fenv key value fenv) + (lambda (name) + (if (tenv-key=? key name) + value + (fenv name)))) + ) diff --git a/collects/honu/tool.ss b/collects/honu/tool.ss index 8b1d42b65c..3cda629361 100644 --- a/collects/honu/tool.ss +++ b/collects/honu/tool.ss @@ -5,12 +5,11 @@ (lib "unitsig.ss") (lib "etc.ss") (lib "class.ss") + (lib "list.ss" "srfi" "1") + "parsers/lex.ss" "parsers/parse.ss" - "ast.ss" "tenv.ss" - "private/typechecker/honu-type-utils.ss" "compile.ss" - "honu-compile-context.ss" (lib "string-constant.ss" "string-constants")) (provide tool@) @@ -22,9 +21,7 @@ (define (phase1) (void)) (define (phase2) (drscheme:language-configuration:add-language - (make-object ((drscheme:language:get-default-mixin) (honu-lang-mixin 'single)))) - (drscheme:language-configuration:add-language - (make-object ((drscheme:language:get-default-mixin) (honu-lang-mixin 'group))))) + (make-object ((drscheme:language:get-default-mixin) (honu-lang-mixin 'normal))))) (define (honu-lang-mixin level) (class* object% (drscheme:language:language<%>) @@ -36,51 +33,43 @@ (define/public (default-settings) null) (define/public (default-settings? x) #t) (define tenv (empty-tenv)) - (define env (empty-env)) + (define lenv (get-builtin-lenv)) (define level-parser (case level - [(single) parse-port] - [(group) parse-group])) + [(normal) parse-port])) (define/public (front-end/complete-program port settings teachpack-cache) (set! tenv (empty-tenv)) + (set! lenv (get-builtin-lenv)) (let ([name (object-name port)]) (lambda () (if (eof-object? (peek-char-or-special port)) eof - (let* ([parsed (level-parser port name)] - [compiled-defns (compile/complete-program tenv parsed)]) - (set! env (get-initial-env tenv)) - (datum->syntax-object #f `(run-honu-full-program ,compiled-defns) #f)))))) + (let* ([parsed (level-parser port name)]) + (let ([compiled-defns (compile/defns tenv lenv parsed)]) + (datum->syntax-object #f (cons 'begin compiled-defns) #f))))))) (define/public (front-end/interaction port settings teachpack-cache) (let ([name (object-name port)]) (lambda () (if (eof-object? (peek-char-or-special port)) eof (let ([parsed (parse-interaction port name)]) - (let-values ([(compiled-expr new-env) - (compile/interaction tenv env parsed)]) - (begin (set! env new-env) - (datum->syntax-object #f `(run-honu-interaction ,compiled-expr) #f)))))))) + (let ([compiled-expr (compile/interaction tenv lenv parsed)]) + (datum->syntax-object #f compiled-expr #f))))))) (define/public (get-style-delta) #f) (define/public (get-language-position) (list (string-constant experimental-languages) - "Honu" - (case level - [(single) "Single File"] - [(group) "Group File"]))) + "Honu")) (define/public (order-manuals x) (values (list #"drscheme" #"tour" #"help") #f)) (define/public (get-language-name) (case level - [(single) "Honu (single)"] - [(group) "Honu (group)"])) + [(normal) "Honu"])) (define/public (get-language-url) #f) (define/public (get-language-numbers) (case level - [(single) (list 1000 10 1)] - [(group) (list 1000 10 2)])) + [(normal) (list 1000 10)])) (define/public (get-teachpack-names) null) (define/public (marshall-settings x) x) (define/private (syntax-as-top s) @@ -97,21 +86,12 @@ (current-eval (with-handlers ([(lambda (x) #t) (lambda (x) (printf "~a~n" (exn-message x)))]) (lambda (exp) - (syntax-case exp (run-honu-full-program run-honu-interaction) - [(run-honu-full-program defns) - (let loop ([defns (syntax->list #'defns)]) - (if (null? defns) - (void) - (begin (old-current-eval (syntax-as-top (car defns))) - (loop (cdr defns)))))] - [(run-honu-interaction ex) - (old-current-eval (syntax-as-top #'ex))] - [(_) (old-current-eval exp)]))))) + (old-current-eval (syntax-as-top exp)))))) (with-handlers ([(lambda (x) #t) (lambda (x) (printf "~a~n" (exn-message x)))]) (namespace-attach-module n path) (namespace-require path)))))) - (define/public (render-value value settings port) (write value port)) - (define/public (render-value/format value settings port width) (write value port)) + (define/public (render-value value settings port) (display (format-honu value settings #t) port)) + (define/public (render-value/format value settings port width) (render-value value settings port) (if (not (null? value)) (newline port))) (define/public (unmarshall-settings x) x) (define/public (create-executable settings parent src-file teachpacks) (message-box "Unsupported" @@ -119,8 +99,7 @@ parent)) (define/public (get-one-line-summary) (case level - [(single) "Honu (also not Scheme at all!)"] - [(group) "List of Honu files to run together"])) + [(normal) "Honu (also not Scheme at all!)"])) (super-instantiate ()))) @@ -131,17 +110,79 @@ (define (matches-language l) (and l (pair? l) (pair? (cdr l)) (equal? (cadr l) "Honu"))) + (define (format-honu value settings at-top?) + (cond + [(number? value) (format "~a" value)] + [(char? value) (format "'~a'" value)] + [(string? value) (format "~v" value)] + [(boolean? value) (if value "true" "false")] + [(procedure? value) "procedure"] + ;; tuples -- first the zero tuple, then the non-empty tuples + ;; + ;; if you want void values to be printed out, uncomment + ;; the following: + ;; [(null? value) "()"] + [(null? value) + ;; the following makes it so that nothing is printed out + ;; for a void value, but if a zero-tuple is part of a tuple + ;; or structure, then it is printed out. + (if at-top? "" "()")] + [(list? value) + (string-append "(" + (fold (lambda (v s) + (string-append s ", " (format-honu v settings #f))) + (format-honu (car value) settings #f) + (cdr value)) + ")")] + [else (format "~a" value)])) + + + ;Set the Honu editing colors + (define color-prefs-table + `((keyword ,(make-object color% "black") "keyword") + (parenthesis ,(make-object color% 132 60 36) "parenthesis") + (string ,(make-object color% "forestgreen") "string") + (literal ,(make-object color% "forestgreen") "literal") + (comment ,(make-object color% 194 116 31) "comment") + (error ,(make-object color% "red") "error") + (identifier ,(make-object color% 38 38 128) "identifer") + (default ,(make-object color% "black") "default"))) + + ;; short-sym->pref-name : symbol -> symbol + ;; returns the preference name for the color prefs + (define (short-sym->pref-name sym) (string->symbol (short-sym->style-name sym))) + + ;; short-sym->style-name : symbol->string + ;; converts the short name (from the table above) into a name in the editor list + ;; (they are added in by `color-prefs:register-color-pref', called below) + (define (short-sym->style-name sym) (format "honu:syntax-coloring:scheme:~a" sym)) + + ;; extend-preferences-panel : vertical-panel -> void + ;; adds in the configuration for the Honu colors to the prefs panel + (define (extend-preferences-panel parent) + (for-each + (lambda (line) + (let ([sym (car line)]) + (color-prefs:build-color-selection-panel + parent + (short-sym->pref-name sym) + (short-sym->style-name sym) + (format "~a" sym)))) + color-prefs-table)) + ;Create the Honu editing mode (define mode-surrogate (new color:text-mode% (matches (list (list '|{| '|}|) (list '|(| '|)|) - (list '|[| '|]|))))) + (list '|[| '|]|))) + (get-token get-syntax-token) + (token-sym->style short-sym->style-name))) ;repl-submit: text int -> bool ;Determines if the reple should submit or not (define (repl-submit text prompt-position) - (let ((is-if? #f) + (let ((is-empty? #t) (is-string? #f) (open-parens 0) (open-braces 0) @@ -149,41 +190,58 @@ (let loop ((index 1) (char (send text get-character prompt-position))) (unless (eq? char #\nul) (cond - ;beginning of if statement - ((and (= index 1) - (eq? char #\i) - (eq? (send text get-character (add1 prompt-position)) #\f) - (eq? (send text get-character (+ 2 prompt-position)) #\space)) - (set! is-if? #t) - (loop 3 (send text get-character (+ 3 prompt-position)))) ((eq? char #\() + (set! is-empty? #f) (unless is-string? (set! open-parens (add1 open-parens))) (loop (add1 index) (send text get-character (+ index prompt-position)))) ((eq? char #\)) + (set! is-empty? #f) (unless is-string? (set! open-parens (sub1 open-parens))) (loop (add1 index) (send text get-character (+ index prompt-position)))) ((eq? char #\{) + (set! is-empty? #f) (unless is-string? (set! open-curlies (add1 open-curlies))) (loop (add1 index) (send text get-character (+ index prompt-position)))) ((eq? char #\}) + (set! is-empty? #f) (unless is-string? (set! open-curlies (sub1 open-curlies))) (loop (add1 index) (send text get-character (+ index prompt-position)))) ((eq? char #\[) + (set! is-empty? #f) (unless is-string? (set! open-braces (add1 open-braces))) (loop (add1 index) (send text get-character (+ index prompt-position)))) ((eq? char #\]) + (set! is-empty? #f) (unless is-string? (set! open-braces (sub1 open-braces))) (loop (add1 index) (send text get-character (+ index prompt-position)))) ;beginning of string ((eq? char #\") + (set! is-empty? #f) (set! is-string? (not is-string?)) (loop (add1 index) (send text get-character (+ index prompt-position)))) + ((char-whitespace? char) + (loop (add1 index) (send text get-character (+ index prompt-position)))) (else + (set! is-empty? #f) (loop (add1 index) (send text get-character (+ index prompt-position))))))) (not (or (not (= open-parens 0)) (not (= open-braces 0)) (not (= open-curlies 0)) - is-if?)))) + is-empty?)))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; Wire up to DrScheme + ;; (drscheme:modes:add-mode "Honu mode" mode-surrogate repl-submit matches-language) + (color-prefs:add-to-preferences-panel "Honu" extend-preferences-panel) + + (for-each (lambda (line) + (let ([sym (car line)] + [color (cadr line)]) + (color-prefs:register-color-pref (short-sym->pref-name sym) + (short-sym->style-name sym) + color))) + color-prefs-table) ))) diff --git a/collects/honu/utils.ss b/collects/honu/utils.ss index fc90104040..8c12f199da 100644 --- a/collects/honu/utils.ss +++ b/collects/honu/utils.ss @@ -44,4 +44,16 @@ (loop (map cdr lists) (cons m1 map1) (cons m2 map2)))))) + + (provide partition-first) + (define (partition-first f lis) + (let loop ([lis lis] + [passed '()]) + (cond + [(null? lis) + (values #f (reverse passed))] + [(f (car lis)) + (values (car lis) (append (reverse passed) (cdr lis)))] + [else + (loop (cdr lis) (cons (car lis) passed))]))) )