merged 292:296 from branches/sstrickl
svn: r297
This commit is contained in:
Stevie Strickland
parent
d94aa9230d
commit
7dbb99d3c6
|
|
@ -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
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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"))
|
||||
|
|
|
|||
|
|
@ -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)))]))
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
|||
<program> ::= <defn>*
|
||||
|
||||
<defn> ::= <function>
|
||||
| <top-bind>
|
||||
| <type>
|
||||
| <class>
|
||||
| <mixin>
|
||||
| <subclass>
|
||||
|
||||
<function> ::= <tid> <id> ( <argdecls> ) <block>
|
||||
<top-bind> ::= <bind> = <expr> ;
|
||||
| ( <bind> [, <bind>]* ) = <expr>;
|
||||
|
||||
<type> ::= type <id> <extends> { <mfdecl>* }
|
||||
| interface <id> <extends> { <mfdecl>* }
|
||||
<bind> ::= <tid> <id>
|
||||
| _
|
||||
|
||||
<function> ::= <tid> <id> ( <argdecls> ) <block>
|
||||
|
||||
<tid> ::= <ifacet>
|
||||
| <primtype>
|
||||
| <funtype>
|
||||
| <tuptype>
|
||||
|
||||
<funtype> ::= [ <typetup> ] -> <tid>
|
||||
<funtype> ::= <tid> -> <tid>
|
||||
|
||||
NOTE: The above are literal braces as opposed to the meta-braces.
|
||||
This is the only place they occur right now.
|
||||
|
||||
<typetup> ::= <tid> [, <tid>]*
|
||||
|
|
||||
<tuptype> ::= < >
|
||||
| < <tid> [, <tid>]* >
|
||||
|
||||
<ifacet> ::= id
|
||||
| Any
|
||||
|
|
@ -151,6 +141,9 @@ NOTE: The above are literal braces as opposed to the meta-braces.
|
|||
| char
|
||||
| void
|
||||
|
||||
<type> ::= type <id> <extends> { <mfdecl>* }
|
||||
| interface <id> <extends> { <mfdecl>* }
|
||||
|
||||
<extends> ::= extends <ifacet> [, <ifacet>]*
|
||||
| <: <ifacet> [, <ifacet>]*
|
||||
|
|
||||
|
|
@ -164,33 +157,34 @@ NOTE: The above are literal braces as opposed to the meta-braces.
|
|||
<argdecl> ::= <tid>
|
||||
| <tid> <varid>
|
||||
|
||||
<struct> ::= struct <id> <initargs> : <ifacet> <sctbody>
|
||||
| final struct <id> <initargs> : <ifacet> <sctbody>
|
||||
<struct> ::= struct <id> <initargs> : <ifacet> <impls> <clsbody>
|
||||
| final struct <id> <initargs> : <ifacet> <impls> <clsbody>
|
||||
| struct <id> <initargs> : <ifacet>
|
||||
extends <id> <initargs> : <ifacet> <impls> <mixbody>
|
||||
| final struct <id> <initargs> : <ifacet>
|
||||
extends <id> <initargs> : <ifacet> <impls> <mixbody>
|
||||
|
||||
<class> ::= class <id> <initargs> : <ifacet> <impls> <clsbody>
|
||||
| final class <initargs> <id> : <ifacet> <impls> <clsbody>
|
||||
| class <id> = <id> ( <id> ) ;
|
||||
| class <id> <initargs> : <ifacet>
|
||||
extends <id> <initargs> : <ifacet> <impls> <mixbody>
|
||||
| final class <id> <initargs> : <ifacet>
|
||||
extends <id> <initargs> : <ifacet> <impls> <mixbody>
|
||||
|
||||
<mixin> ::= mixin <id> <initargs> : <ifacet> <argtype> <impls> <mixbody>
|
||||
| final mixin <id> <initargs> : <ifacet> <argtype> <impls> <mixbody>
|
||||
|
||||
<subclass> ::= subclass <id> = <id> ( <id> ) ;
|
||||
| subclass <id> <initargs> : <ifacet> <scexts> <impls> <mixbody>
|
||||
| final subclass <id> <initargs> : <ifacet> <scexts> <impls> <mixbody>
|
||||
<mixin> ::= mixin <id> <initargs> : <ifacet> <initargs> -> <ifacet>
|
||||
<impls> <mixbody>
|
||||
| final mixin <id> <initargs> : <ifacet> <initargs> -> <ifacet>
|
||||
<impls> <mixbody>
|
||||
|
||||
<initargs> ::= ( <tid> <id> [, <tid> <id>]* )
|
||||
| ( )
|
||||
|
||||
<scexts> ::= extends <id> <argtype>
|
||||
|
||||
<argtype> ::= at <ifacet>
|
||||
| @ <ifacet>
|
||||
|
||||
<impls> ::= implements <ifacet> [, <ifacet>]*
|
||||
| impl <ifacet> [, <ifacet>]*
|
||||
|
|
||||
|
||||
<sctbody> ::= { <mfidefn>* }
|
||||
|
||||
<clsbody> ::= { <mfidefn>* <export>* }
|
||||
|
||||
<mixbody> ::= { <mfidefn>* <supernew> <mfidefn>* <export>* }
|
||||
|
|
@ -200,7 +194,7 @@ NOTE: The above are literal braces as opposed to the meta-braces.
|
|||
| <tid> <id> = <expr> ;
|
||||
| <tid> <id> ( <argdefns> ) <block>
|
||||
|
||||
<supernew> ::= super_new( <newargs> ) ;
|
||||
<supernew> ::= super( <newargs> ) ;
|
||||
|
||||
<argdefns> ::= <argdefn> [, <argdefn>]*
|
||||
|
|
||||
|
|
@ -221,13 +215,17 @@ NOTE: The above are literal braces as opposed to the meta-braces.
|
|||
|
||||
<expr> ::= <literal>
|
||||
| <lambda>
|
||||
| <tuple>
|
||||
| #n <expr>
|
||||
| <id>
|
||||
| <id> = <expr>
|
||||
| <id> ( <exprs-cd> )
|
||||
| <expr> = <expr>
|
||||
| <expr> <tuple>
|
||||
| this
|
||||
| <expr> : <ifacet>
|
||||
| <expr> isa <ifacet>
|
||||
| if <expr> <block> else <block>
|
||||
| if <expr> <block> [else <block>]?
|
||||
| cond { [<expr> => <expr> ;]+ }
|
||||
| cond { [<expr> => <expr> ;]* else <block> }
|
||||
| while <expr> <block>
|
||||
| new <id> : <ifacet> ( <newargs> )
|
||||
| new <id> ( <newargs> )
|
||||
|
|
@ -248,9 +246,7 @@ NOTE: The above are literal braces as opposed to the meta-braces.
|
|||
| <expr> / <expr>
|
||||
| <expr> % <expr>
|
||||
| <expr> . <id>
|
||||
| <expr> . <id> = <expr>
|
||||
| <expr> . <id> ( <exprs-cd> )
|
||||
| ( <expr> )
|
||||
| return <expr>
|
||||
| <block>
|
||||
|
||||
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
|
||||
|
||||
<lambda> ::= fun ( <argdecls> ) <block>
|
||||
<tuple> ::= ( )
|
||||
| ( <exprs-cd> )
|
||||
<lambda> ::= <tid> fun ( <argdecls> ) <block>
|
||||
|
||||
<exprs-cd> ::= <expr> [, <expr>]*
|
||||
| <expr>
|
||||
|
|
@ -286,11 +287,15 @@ NOTE: Here's the precedence and associativity of things above.
|
|||
| false
|
||||
| <strlit>
|
||||
| <charlit>
|
||||
| null
|
||||
|
||||
<block> ::= { <vardefn>* <expr-sc>+ }
|
||||
<block> ::= { <stmts> }
|
||||
|
||||
<vardefn> ::= <tid> <id> = <expr> ;
|
||||
<stmts> ::= <expr-sc>
|
||||
| <vardefn> <stmts>
|
||||
| <expr-sc> <stmts>
|
||||
|
||||
<vardefn> ::= <bind> = <expr> ;
|
||||
| ( <bind> [, <bind>]* ) = <expr> ;
|
||||
|
||||
<expr-sc> ::= <expr> ;
|
||||
| return ;
|
||||
| return <expr> ;
|
||||
|
|
|
|||
|
|
@ -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, Any);
|
||||
Any foldr(<Any, Any> -> 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, Any> -> 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, Any> -> Any f, Any i) {
|
||||
return f(car, cdr.foldl(f, i));
|
||||
}
|
||||
|
||||
Any foldr([Any, Any] -> Any f, Any i) {
|
||||
Any foldr(<Any, Any> -> 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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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 -> 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); }
|
||||
|
|
|
|||
1
collects/honu/examples/bind-tup-top.honu
Normal file
1
collects/honu/examples/bind-tup-top.honu
Normal file
|
|
@ -0,0 +1 @@
|
|||
(int x, int y) = { int x = 3; int y = 4; (x, y); };
|
||||
5
collects/honu/examples/cond-test.honu
Normal file
5
collects/honu/examples/cond-test.honu
Normal file
|
|
@ -0,0 +1,5 @@
|
|||
int x = cond {
|
||||
1 > 3 => 4;
|
||||
5 < 6 => 2;
|
||||
else 8;
|
||||
};
|
||||
48
collects/honu/examples/exprs.honu
Normal file
48
collects/honu/examples/exprs.honu
Normal file
|
|
@ -0,0 +1,48 @@
|
|||
int fact(int n) {
|
||||
if (n == 0) { return 1; }
|
||||
else { return n * fact(n - 1); };
|
||||
}
|
||||
|
||||
<int, int> 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);
|
||||
}
|
||||
|
||||
<int, int> 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;
|
||||
};
|
||||
}
|
||||
177
collects/honu/examples/old/List.honu
Normal file
177
collects/honu/examples/old/List.honu
Normal file
|
|
@ -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;
|
||||
}
|
||||
40
collects/honu/examples/old/Y.honu
Normal file
40
collects/honu/examples/old/Y.honu
Normal file
|
|
@ -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);
|
||||
}
|
||||
56
collects/honu/examples/old/point.honu
Normal file
56
collects/honu/examples/old/point.honu
Normal file
|
|
@ -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);
|
||||
}
|
||||
|
|
@ -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:
|
||||
//
|
||||
// <input class type>(<with args>) -> <output class type>
|
||||
|
||||
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);
|
||||
|
|
|
|||
5
collects/honu/examples/struct.honu
Normal file
5
collects/honu/examples/struct.honu
Normal file
|
|
@ -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(); }
|
||||
6
collects/honu/examples/tup-bind.honu
Normal file
6
collects/honu/examples/tup-bind.honu
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
<int, int> f(int x) { return (x, x); }
|
||||
|
||||
struct C() : T {
|
||||
int x = 3;
|
||||
int y = { (int x, int y) = f(x); x; };
|
||||
}
|
||||
13
collects/honu/examples/types-error.honu
Normal file
13
collects/honu/examples/types-error.honu
Normal file
|
|
@ -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);
|
||||
}
|
||||
12
collects/honu/examples/types.honu
Normal file
12
collects/honu/examples/types.honu
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
type t1 {
|
||||
int x;
|
||||
}
|
||||
|
||||
type t2 {
|
||||
int m(int);
|
||||
}
|
||||
|
||||
type t3 <: t1, t2 {
|
||||
int y;
|
||||
int m2(int, int);
|
||||
}
|
||||
|
|
@ -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))
|
||||
276
collects/honu/parsers/lex.ss
Normal file
276
collects/honu/parsers/lex.ss
Normal file
|
|
@ -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)]))
|
||||
|
||||
)
|
||||
File diff suppressed because it is too large
Load Diff
852
collects/honu/parsers/post-parsing.ss
Normal file
852
collects/honu/parsers/post-parsing.ss
Normal file
|
|
@ -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 <member>
|
||||
;;;; into my.<member>
|
||||
;;;; 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.<SLOTNAME>)
|
||||
|
||||
(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)])]))
|
||||
)
|
||||
|
|
@ -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 (pexp<? a b)
|
||||
(or (string<? (symbol->string (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)))
|
||||
(string<? (symbol->string (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<?)))
|
||||
(let loop ((pexps sorted-exports)
|
||||
(acc '()))
|
||||
(cond
|
||||
[(null? pexps) (reverse acc)]
|
||||
[(null? (cdr pexps)) (reverse (cons (car pexps) acc))]
|
||||
[(pexp=? (car pexps)
|
||||
(cadr pexps)) (loop (cdr pexps) acc)]
|
||||
[else (loop (cdr pexps) (cons (car pexps) acc))]))))
|
||||
|
||||
(define (get-local-fields slotdefns)
|
||||
(filter-map (lambda (d)
|
||||
(cond
|
||||
[(honu-init-field? d) (honu-init-field-name d)]
|
||||
[(honu-field? d) (honu-field-name d)]
|
||||
[else #f]))
|
||||
slotdefns))
|
||||
|
||||
(define (get-local-methods slotdefns)
|
||||
(filter-map (lambda (d)
|
||||
(cond
|
||||
[(honu-method? d) (honu-method-name d)]
|
||||
[else #f]))
|
||||
slotdefns))
|
||||
)
|
||||
|
|
@ -1,25 +0,0 @@
|
|||
(module honu-translate-class mzscheme
|
||||
|
||||
(require (lib "list.ss" "srfi" "1")
|
||||
(lib "plt-match.ss"))
|
||||
|
||||
(require "../../ast.ss")
|
||||
(require "../../tenv.ss")
|
||||
(require "honu-translate-utils.ss")
|
||||
(require "honu-translate-class-utils.ss")
|
||||
(require "honu-translate-expression.ss")
|
||||
|
||||
(provide honu-translate-class)
|
||||
(define (honu-translate-class pgm cls)
|
||||
(match cls
|
||||
[(struct honu-class (stx name type final? init-names init-types impls defns exports))
|
||||
(at stx `(define ,(honu-translate-class-name name)
|
||||
(parameterize ([current-inspector (make-inspector (current-inspector))])
|
||||
(define ,(honu-translate-class-name name)
|
||||
(class* object% ,(filter-map honu-translate-type-name impls)
|
||||
,@(honu-translate-init-slots (honu-class-init-names cls))
|
||||
,@(honu-translate-slotdefns pgm cls (honu-class-defns cls))
|
||||
,@(honu-translate-exports pgm cls '() (honu-class-exports cls))
|
||||
(super-new)))
|
||||
,(honu-translate-class-name name))))]))
|
||||
)
|
||||
|
|
@ -1,266 +0,0 @@
|
|||
(module honu-translate-expression mzscheme
|
||||
|
||||
(require (all-except (lib "list.ss" "srfi" "1") any)
|
||||
(lib "contract.ss")
|
||||
(lib "plt-match.ss"))
|
||||
|
||||
(require "../../ast.ss")
|
||||
(require "../../tenv.ss")
|
||||
(require "honu-translate-utils.ss")
|
||||
(require "../../read-error-with-stx.ss")
|
||||
|
||||
(define (get-builtin-translation name)
|
||||
; (case (printable-key name)
|
||||
; [(println) (at name '(lambda (s) (display s) (newline)))]
|
||||
; [(error) (at name '(lambda (s) (error s)))]))
|
||||
;; since we can change the context of identifiers, just make
|
||||
;; sure that the appropriate things are bound in honu-compile-context.
|
||||
(at-ctxt name))
|
||||
|
||||
(define (field-in-defn? field defn)
|
||||
(or (find (lambda (n)
|
||||
(tenv-key=? n field))
|
||||
(cond
|
||||
[(honu-class? defn) (honu-class-init-names defn)]
|
||||
[(honu-mixin? defn) (honu-mixin-init-names defn)]))
|
||||
(find (match-lambda
|
||||
[(struct honu-field (_ name _ _))
|
||||
(tenv-key=? name field)]
|
||||
[(struct honu-init-field (_ name _ _))
|
||||
(tenv-key=? name field)]
|
||||
[_ #f])
|
||||
(cond
|
||||
[(honu-class? defn) (honu-class-defns defn)]
|
||||
[(honu-mixin? defn) (append (honu-mixin-defns-before defn)
|
||||
(honu-mixin-defns-after defn))]))))
|
||||
|
||||
(provide/contract [honu-translate-expression
|
||||
(tenv?
|
||||
(union false/c
|
||||
honu-defn?)
|
||||
honu-exp?
|
||||
. -> .
|
||||
; (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))]
|
||||
[(char)
|
||||
(at stx `(,(at op-stx 'char<?) ,left-exp ,right-exp))])]
|
||||
[(le)
|
||||
(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))])]
|
||||
[(gt)
|
||||
(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))])]
|
||||
[(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)]))]))
|
||||
)
|
||||
|
||||
|
|
@ -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)))]))
|
||||
)
|
||||
|
|
@ -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))]))
|
||||
|
||||
)
|
||||
|
|
@ -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)))))
|
||||
])]))
|
||||
|
||||
)
|
||||
|
|
@ -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)))))]))
|
||||
)
|
||||
|
|
@ -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))))))
|
||||
)
|
||||
151
collects/honu/private/compiler/translate-class-utils.ss
Normal file
151
collects/honu/private/compiler/translate-class-utils.ss
Normal file
|
|
@ -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))]))
|
||||
|
||||
|
||||
)
|
||||
308
collects/honu/private/compiler/translate-expression.ss
Normal file
308
collects/honu/private/compiler/translate-expression.ss
Normal file
|
|
@ -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)))]
|
||||
[(char)
|
||||
(at stx
|
||||
`(,(at op-stx 'char<?)
|
||||
,(translate-expression tenv arg-type larg)
|
||||
,(translate-expression tenv arg-type rarg)))])]
|
||||
[(le)
|
||||
(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)))])]
|
||||
[(gt)
|
||||
(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)))])]
|
||||
[(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))]))
|
||||
|
||||
)
|
||||
138
collects/honu/private/compiler/translate-utils.ss
Normal file
138
collects/honu/private/compiler/translate-utils.ss
Normal file
|
|
@ -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)))
|
||||
|
||||
)
|
||||
97
collects/honu/private/compiler/translate.ss
Normal file
97
collects/honu/private/compiler/translate.ss
Normal file
|
|
@ -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)))))]))
|
||||
|
||||
)
|
||||
|
|
@ -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]))
|
||||
)
|
||||
|
|
@ -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)) "<any type>"]
|
||||
[(struct honu-top-type (stx)) "void"]
|
||||
[(struct honu-iface-bottom-type (stx)) "<interface type>"]
|
||||
[(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))))
|
||||
|
||||
)
|
||||
|
|
@ -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)
|
||||
(string<? (symbol->string 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))
|
||||
)
|
||||
|
|
@ -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))))
|
||||
)
|
||||
|
|
@ -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' <fd, 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' <fd, 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' <md, t_1 ... t_n -> 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))])))))
|
||||
)
|
||||
|
|
@ -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)))))))
|
||||
)
|
||||
|
|
@ -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)
|
||||
(string<? (symbol->string (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))))
|
||||
)
|
||||
|
|
@ -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))]))
|
||||
|
||||
)
|
||||
|
|
@ -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))]))
|
||||
|
||||
|
||||
)
|
||||
|
|
@ -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))]))]))
|
||||
)
|
||||
|
|
@ -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))]))
|
||||
)
|
||||
265
collects/honu/private/typechecker/type-utils.ss
Normal file
265
collects/honu/private/typechecker/type-utils.ss
Normal file
|
|
@ -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))
|
||||
)
|
||||
283
collects/honu/private/typechecker/typecheck-class-utils.ss
Normal file
283
collects/honu/private/typechecker/typecheck-class-utils.ss
Normal file
|
|
@ -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)]))
|
||||
|
||||
)
|
||||
634
collects/honu/private/typechecker/typecheck-expression.ss
Normal file
634
collects/honu/private/typechecker/typecheck-expression.ss
Normal file
|
|
@ -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.<id>)
|
||||
;; 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: #<struct:honu:if> #<struct:honu:type-prim>
|
||||
;; 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))]))
|
||||
|
||||
)
|
||||
181
collects/honu/private/typechecker/typechecker.ss
Normal file
181
collects/honu/private/typechecker/typechecker.ss
Normal file
|
|
@ -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)]))
|
||||
|
||||
)
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
(module read-error-with-stx mzscheme
|
||||
(module readerr mzscheme
|
||||
|
||||
(require (lib "readerr.ss" "syntax"))
|
||||
|
||||
|
|
@ -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 "}~%"))]))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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<? (identifier? identifier? . -> . 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-key<? k1 k2)
|
||||
(string<? (symbol->string (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))))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
)))
|
||||
|
|
|
|||
|
|
@ -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))])))
|
||||
)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user