Removed out-of-date honu module.
svn: r2185
This commit is contained in:
Carl Eastlund
parent
2b47616f14
commit
871a696fb9
|
|
@ -1,298 +0,0 @@
|
|||
(module ast mzscheme
|
||||
|
||||
(require (lib "contract.ss")
|
||||
(planet "hierarchy.ss" ("dherman" "struct.plt" 2 1))
|
||||
(planet "inspector.ss" ("dherman" "inspector.plt" 1 0))
|
||||
(planet "contract-utils.ss" ("cobbe" "contract-utils.plt" 1 0))
|
||||
)
|
||||
|
||||
(with-public-inspector
|
||||
(define-hierarchy/provide/contract
|
||||
|
||||
(ast ; parent structure for AST nodes
|
||||
([syntax (optional/c syntax?)] ; all nodes store syntax locations
|
||||
)
|
||||
|
||||
(ast:type () ; parent structure for types
|
||||
|
||||
(ast:type:top ()) ; "void" or "unit" type
|
||||
(ast:type:bot ()) ; "error" type, or for non-returning operations
|
||||
|
||||
(ast:type:object () ; Object type
|
||||
(ast:type:object:any ()) ; Distinguished Any type, top of hierarchy
|
||||
(ast:type:object:null ()) ; Type of null, bottom of hierarchy
|
||||
(ast:type:object:iface ; Interface type
|
||||
([name identifier?] ; name of the interface
|
||||
)))
|
||||
|
||||
(ast:type:primitive ; Builtin type (int, char, bool, etc.)
|
||||
([name symbol?] ; builtins come from a fixed set of names
|
||||
))
|
||||
|
||||
(ast:type:tuple ; Tuple type
|
||||
([elems (listof ast:type?)] ; types of each tuple element
|
||||
))
|
||||
|
||||
(ast:type:partial/tuple ; Tuple type as inferred from selector
|
||||
([position integer?] ; position at which type is known
|
||||
[elem ast:type?] ; type at that position
|
||||
))
|
||||
|
||||
(ast:type:function ; Function type (without dispatch)
|
||||
([input ast:type?] ; input type
|
||||
[output ast:type?] ; output type
|
||||
))
|
||||
|
||||
(ast:type:method ; Method type (with receiver dispatch)
|
||||
([receiver ast:type:object?] ; type of the method's receiver
|
||||
[input ast:type?] ; input type
|
||||
[output ast:type?] ; input type
|
||||
))
|
||||
)
|
||||
|
||||
(ast:defn () ; parent structure for top-level definitions
|
||||
|
||||
(ast:defn:iface ; Interface definitions
|
||||
([name identifier?] ; interface name
|
||||
[supers (listof ast:type:object?)] ; parent interfaces
|
||||
[members (listof ast:iface/member?)] ; members (methods and fields)
|
||||
))
|
||||
|
||||
(ast:defn:class ; Class definitions
|
||||
([name identifier?] ; interface name
|
||||
[self-type ast:type:object?] ; class's type internally and for subclassing
|
||||
[final? boolean?] ; whether the class may be extended
|
||||
[client-types (listof ast:type:object?)] ; implemented interfaces
|
||||
[formals (listof ast:formal?)] ; constructor arguments
|
||||
[members (listof ast:class/member?)] ; member definitions
|
||||
[exports (listof ast:export?)] ; export declarations
|
||||
))
|
||||
|
||||
(ast:defn:mixin ; Mixin definition
|
||||
([name identifier?] ; mixin name
|
||||
[self-type ast:type:object?] ; mixin's type internally and for subclassing
|
||||
[super-type ast:type:object?] ; input interface
|
||||
[final? boolean?] ; whether the mixin can be extended
|
||||
[client-types (listof ast:type:object?)] ; implemented interfaces
|
||||
[formals (listof ast:formal?)] ; constructor arguments
|
||||
[super-formals (listof ast:formal?)] ; expected parent arguments
|
||||
[super-new ast:super-new?] ; parent initialization
|
||||
[pre-members (listof ast:class/member?)] ; members defined before super-new
|
||||
[post-members (listof ast:class/member?)] ; members defined after super-new
|
||||
[exports (listof ast:export?)] ; export declarations
|
||||
))
|
||||
|
||||
(ast:defn:subclass ; Subclass definition (applies a mixin to a class)
|
||||
([name identifier?] ; new class's name
|
||||
[base identifier?] ; superclass
|
||||
[mixin identifier?] ; applied mixin
|
||||
))
|
||||
|
||||
(ast:defn:structure ; Structure definition (class and type defined at once)
|
||||
([name identifier?] ; structure name
|
||||
[self-type ast:type:object?] ; internal/subclassing type (how does this relate to "structure" type?)
|
||||
[final? boolean?] ; whether the structure can be extended
|
||||
[client-types (listof ast:type:object?)] ; implemented interfaces
|
||||
[formals (listof ast:formal?)] ; constructor arguments
|
||||
[members (listof ast:class/member?)] ; member definitions
|
||||
[exports (listof ast:export?)] ; export declarations
|
||||
))
|
||||
|
||||
(ast:defn:substructure ; Substructure definition (defines and instantiates subclassing)
|
||||
([name identifier?] ; substructure name
|
||||
[self-type ast:type:object?] ; internal/subclassing type
|
||||
[super-class identifier?] ; parent class
|
||||
[super-type ast:type:object?] ; parent interface
|
||||
[final? boolean?] ; whether the substructure can be extended
|
||||
[client-types (listof ast:type:object?)] ; implemented interfaces
|
||||
[formals (listof ast:formal?)] ; constructor arguments
|
||||
[super-formals (listof ast:formal?)] ; expected parent arguments
|
||||
[super-new ast:super-new?] ; parent initialization
|
||||
[pre-members (listof ast:class/member?)] ; members defined before super-new
|
||||
[post-members (listof ast:class/member?)] ; members defined after super-new
|
||||
[exports (listof ast:export?)] ; export declarations
|
||||
))
|
||||
|
||||
(ast:defn:function ; Function definition
|
||||
([name identifier?] ; function name
|
||||
[return-type ast:type?] ; output type
|
||||
[formals (listof ast:formal?)] ; input names and types
|
||||
[body ast:expr?] ; function implementation
|
||||
))
|
||||
|
||||
(ast:defn:binding ; Top-level variable binding
|
||||
([names (listof identifier?)] ; variable name or names (if binding a tuple)
|
||||
[types (listof ast:type?)] ; variable type(s)
|
||||
[init ast:expr?] ; expression providing the bound value(s)
|
||||
))
|
||||
|
||||
)
|
||||
|
||||
(ast:iface/member ; Member declared in an interface
|
||||
([name identifier?] ; member name
|
||||
)
|
||||
(ast:iface/member:field ; Field of an interface
|
||||
([type ast:type?] ; field type
|
||||
))
|
||||
(ast:iface/member:method ; Method of an interface
|
||||
([return-type ast:type?] ; output type
|
||||
[formal-types (listof ast:type?)] ; input types
|
||||
)))
|
||||
|
||||
(ast:class/member ; Member defined in a class/mixin
|
||||
([name identifier?] ; member name
|
||||
)
|
||||
(ast:class/member:field ; Field of a class
|
||||
([type ast:type?] ; field type
|
||||
[default (optional/c ast:expr?)] ; default value
|
||||
))
|
||||
(ast:class/member:field/formal ; Field and constructor argument
|
||||
([type ast:type?] ; field type
|
||||
[default (optional/c ast:expr?)] ; default value
|
||||
))
|
||||
(ast:class/member:method ; Method of a class
|
||||
([return-type ast:type?] ; output type
|
||||
[formals (listof ast:formal?)] ; method arguments
|
||||
[body ast:expr?] ; method implementation
|
||||
)))
|
||||
|
||||
(ast:super-new ; Parent class initializer
|
||||
([args (listof ast:named/arg?)] ; constructor arguments
|
||||
))
|
||||
|
||||
(ast:expr () ; Parent structure for expressions
|
||||
|
||||
(ast:expr:self ()) ; Self-reference within an object
|
||||
|
||||
(ast:expr:var ; Variable reference
|
||||
([name identifier?] ; variable name
|
||||
))
|
||||
|
||||
(ast:expr:assign ; Assignment
|
||||
([lhs ast:expr?] ; assignment destination
|
||||
[rhs ast:expr?] ; assignment source
|
||||
))
|
||||
|
||||
(ast:expr:apply ; Function call
|
||||
([func ast:expr?] ; invoked function
|
||||
[arg ast:expr?] ; actual arguments
|
||||
))
|
||||
|
||||
(ast:expr:literal ; Primitive value
|
||||
([type ast:type?] ; literal type
|
||||
[value syntax?] ; literal value
|
||||
))
|
||||
|
||||
(ast:expr:unary/op ; Prefix operation
|
||||
(
|
||||
[name symbol?] ; operator name
|
||||
[rator-stx syntax?] ; operator syntax
|
||||
[rator-type (optional/c ast:type?)] ; operator type (presumably added by typechecker)
|
||||
[arg ast:expr?] ; operator argument
|
||||
))
|
||||
|
||||
(ast:expr:binary/op ; Infix operation
|
||||
(
|
||||
[name symbol?] ; operator name
|
||||
[rator-stx syntax?] ; operator syntax
|
||||
[rator-type (optional/c ast:type?)] ; operator type (presumably added by typechecker)
|
||||
[left ast:expr?] ; first argument
|
||||
[right ast:expr?] ; second argument
|
||||
))
|
||||
|
||||
(ast:expr:function ; Anonymous function value
|
||||
([return-type ast:type?] ; output type
|
||||
[formals (listof ast:formal?)] ; arguments
|
||||
[body ast:expr?] ; function implementation
|
||||
))
|
||||
|
||||
(ast:expr:if ; Simple conditional
|
||||
([test ast:expr?] ; Boolean expression
|
||||
[then ast:expr?] ; Result when true
|
||||
[else ast:expr?] ; Result when false
|
||||
))
|
||||
|
||||
(ast:expr:cast ; Typecast
|
||||
([object ast:expr?] ; value to cast
|
||||
[type ast:type:object?] ; type of cast
|
||||
))
|
||||
|
||||
(ast:expr:isa ; Type conditional
|
||||
([object ast:expr?] ; value to test
|
||||
[type ast:type:object?] ; type of test
|
||||
))
|
||||
|
||||
(ast:expr:member ; Access field or method
|
||||
([object (union ast:expr? (symbols 'my))] ; receiver
|
||||
[object-type (optional/c ast:type:object?)] ; receiver type
|
||||
[name identifier?] ; member name
|
||||
[method? (union boolean? (symbols 'unknown))] ; whether member is a method or field
|
||||
))
|
||||
|
||||
(ast:expr:let ; Local bindings
|
||||
([bindings (listof ast:defn:binding?)] ; new definitions
|
||||
[body ast:expr?] ; expression in new scope
|
||||
))
|
||||
|
||||
(ast:expr:sequence ; Sequential statements
|
||||
([statements (listof ast:expr?)] ; executed in order for effect only
|
||||
[result ast:expr?] ; executed last and returned
|
||||
))
|
||||
|
||||
(ast:expr:new ; Object construction
|
||||
([class identifier?] ; class to instantiate
|
||||
[type (optional/c ast:type:object?)] ; static type of object (presumably added by typechecker)
|
||||
[args (listof ast:named/arg?)] ; constructor arguments
|
||||
))
|
||||
|
||||
(ast:expr:cond ; Multiple-branch conditional
|
||||
([clauses (listof ast:cond/clause?)] ; conditional clauses
|
||||
[else ast:expr?] ; result if all else fails
|
||||
))
|
||||
|
||||
(ast:expr:while ; Imperative recursion
|
||||
([test ast:expr?] ; controls loop
|
||||
[body ast:expr?] ; loop body
|
||||
))
|
||||
|
||||
(ast:expr:return ; Escapes function/method
|
||||
([result ast:expr?] ; returned value
|
||||
))
|
||||
|
||||
(ast:expr:tuple ; Tuple constructor
|
||||
([elems (listof ast:expr?)] ; tuple elements
|
||||
))
|
||||
|
||||
(ast:expr:tuple/select ; Tuple projection
|
||||
([position integer?] ; selected element
|
||||
[arg ast:expr?] ; tuple expression
|
||||
)))
|
||||
|
||||
(ast:export ; Export declaration
|
||||
([type ast:type:object?] ; exported type
|
||||
[members (listof ast:export/member?)] ; exported members
|
||||
))
|
||||
|
||||
(ast:formal ; Declared arguments
|
||||
([name identifier?] ; variable name
|
||||
[type ast:type?] ; argument type
|
||||
))
|
||||
|
||||
(ast:cond/clause ; Conditional branches
|
||||
([test ast:expr?] ; condition
|
||||
[result ast:expr?] ; result if true
|
||||
))
|
||||
|
||||
(ast:export/member ; Individual export specification
|
||||
([internal identifier?] ; name inside class/mixin
|
||||
[external identifier?] ; name from interface
|
||||
))
|
||||
|
||||
(ast:named/arg ; By-name arguments
|
||||
([name identifier?] ; argument name
|
||||
[actual ast:expr?] ; argument value
|
||||
))
|
||||
|
||||
)))
|
||||
|
||||
)
|
||||
|
|
@ -1,84 +0,0 @@
|
|||
(module base mzscheme
|
||||
|
||||
(require (lib "class.ss"))
|
||||
|
||||
(define-syntax (honu:send stx)
|
||||
(syntax-case stx ()
|
||||
[(_ obj msg arg ...)
|
||||
#'(if (is-a? obj null%)
|
||||
(error "Attempt to access member of null")
|
||||
(send obj msg arg ...))]))
|
||||
|
||||
(define null%
|
||||
(class object%
|
||||
(inspect #f)
|
||||
(super-new)))
|
||||
|
||||
(define null-obj (new null%))
|
||||
|
||||
(define Any<%>
|
||||
(interface ()))
|
||||
|
||||
(define (printString s)
|
||||
(display s)
|
||||
'())
|
||||
|
||||
(define (printLine s)
|
||||
(display s)
|
||||
(newline)
|
||||
'())
|
||||
|
||||
(define (readChar arg-tuple)
|
||||
(read-char))
|
||||
|
||||
(define (readLine arg-tuple)
|
||||
(read-line))
|
||||
|
||||
(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 (stringToFloat s)
|
||||
(let ([number (string->number s)])
|
||||
(if (and number (inexact? number))
|
||||
number
|
||||
(error (format "Tried to convert \"~a\" to an float" s)))))
|
||||
|
||||
(define (intToString i)
|
||||
(number->string i))
|
||||
|
||||
(define (floatToString f)
|
||||
(number->string f))
|
||||
|
||||
(define (charToString c)
|
||||
(string c))
|
||||
|
||||
(define (strlen s)
|
||||
(string-length s))
|
||||
|
||||
(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 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)
|
||||
(rename ormap mz:ormap)
|
||||
(all-from (lib "class.ss"))
|
||||
(all-defined)))
|
||||
|
|
@ -1,41 +0,0 @@
|
|||
Todo:
|
||||
|
||||
AST
|
||||
- changed names in ast.ss, propagate to everywhere else
|
||||
- added (some) contracts; add the rest and verify what's there
|
||||
- finish writing, and use, define-structs[/provide[/contract]]
|
||||
Mixin Sealing
|
||||
- move to single, applicative environment
|
||||
Test Suite Improvements
|
||||
Numeric Library
|
||||
|
||||
------------------------------------------------------------
|
||||
|
||||
File purposes:
|
||||
|
||||
doc.txt: implementation notes
|
||||
tool.ss: definition of language level
|
||||
compile.ss: top-level compilation functions
|
||||
util.ss: general functions (similar to list.ss)
|
||||
tenv.ss: definition of type environment
|
||||
- don't understand all the types defined
|
||||
tenv-utils.ss: manipulate environments
|
||||
base.ss: top-level honu definitions
|
||||
ast.ss: ast structs
|
||||
private/typechecker/type-utils.ss: simple type operations
|
||||
|
||||
------------------------------------------------------------
|
||||
|
||||
General structure:
|
||||
|
||||
3 phases:
|
||||
- parser tools (-> AST)
|
||||
- post-parsing
|
||||
- static references to "my" references (my.x for static fields, etc.)
|
||||
- references to "this" only in member access (this.x) or in casts ((IFace)this)
|
||||
- adds casts to this.x
|
||||
- simplify-ast : gather asts/sequences into big lets/sequences
|
||||
.
|
||||
.
|
||||
.
|
||||
|
||||
|
|
@ -1,62 +0,0 @@
|
|||
(module compile mzscheme
|
||||
|
||||
(require (lib "boundmap.ss" "syntax")
|
||||
(lib "contract.ss")
|
||||
(lib "plt-match.ss")
|
||||
"ast.ss"
|
||||
"honu-context.ss"
|
||||
"parameters.ss"
|
||||
"readerr.ss"
|
||||
"tenv.ss"
|
||||
"tenv-utils.ss"
|
||||
"parsers/post-parsing.ss"
|
||||
"private/compiler/translate.ss"
|
||||
"private/compiler/translate-expression.ss"
|
||||
"private/typechecker/type-utils.ss"
|
||||
"private/typechecker/typechecker.ss"
|
||||
"private/typechecker/typecheck-expression.ss")
|
||||
|
||||
(provide/contract [compile/defns
|
||||
((tenv? tenv? (listof ast:defn?))
|
||||
. ->* .
|
||||
(any/c (listof (syntax/c any/c))))]
|
||||
[compile/interaction
|
||||
((tenv?
|
||||
tenv?
|
||||
(union ast:defn:binding? ast:expr?))
|
||||
. ->* .
|
||||
((syntax/c any/c)
|
||||
(union ast:type? false/c)))])
|
||||
(define (compile/defns tenv lenv pgm)
|
||||
(parameterize ([current-type-environment tenv]
|
||||
[current-lexical-environment lenv])
|
||||
(let ([pgm (post-parse-program (add-defns-to-tenv pgm))])
|
||||
(let ([checked (typecheck pgm)])
|
||||
(parameterize ([current-compile-context honu-compile-context])
|
||||
(translate checked))))))
|
||||
|
||||
(define (check-bound-names names)
|
||||
(for-each (lambda (n)
|
||||
(if (and n (get-lenv-entry n))
|
||||
(raise-read-error-with-stx
|
||||
(format "~a already bound" (printable-key n))
|
||||
n)))
|
||||
names))
|
||||
|
||||
(define (compile/interaction tenv lenv ast)
|
||||
(parameterize ([current-type-environment tenv]
|
||||
[current-lexical-environment lenv])
|
||||
(match (post-parse-interaction ast)
|
||||
[(struct ast:defn:binding (stx names _ value))
|
||||
(check-bound-names names)
|
||||
(let ([checked (typecheck-defn ast)])
|
||||
(parameterize ([current-compile-context honu-compile-context])
|
||||
(values (translate-defn checked) #f)))]
|
||||
[else
|
||||
(let-values ([(checked type)
|
||||
(typecheck-expression
|
||||
(wrap-lenv) (make-top-type #f) ast)])
|
||||
(parameterize ([current-compile-context honu-compile-context])
|
||||
(values (translate-expression checked) type)))])))
|
||||
)
|
||||
|
||||
|
|
@ -1,409 +0,0 @@
|
|||
_Honu_
|
||||
|
||||
_TODO_
|
||||
|
||||
* Admit statements as elements of mixin bodies, i.e.,
|
||||
|
||||
struct ExamplesC() : Examples {
|
||||
IStack s0 = new StackC();
|
||||
int d0 = s0.depth();
|
||||
s0.push(s0);
|
||||
}
|
||||
|
||||
should work. -- MF
|
||||
|
||||
* Work out details of standard library, including boxed versions of
|
||||
primitive types.
|
||||
|
||||
* If you do have a standard library, document it please. -- MF
|
||||
|
||||
* Let's add arrays.
|
||||
|
||||
* Add new statement that uses positional initialization arguments.
|
||||
|
||||
* Add autoboxing of primitive types.
|
||||
|
||||
* Add generics (parametric polymorphism and bounded polymorphism).
|
||||
RESEARCH!
|
||||
|
||||
_Primitive types_
|
||||
|
||||
int - integers
|
||||
float - floating point numbers
|
||||
string - strings (double quoted)
|
||||
bool - booleans (true, false)
|
||||
char - characters (single quoted)
|
||||
|
||||
_Built-in functions_
|
||||
|
||||
Error reporting:
|
||||
|
||||
> error(string message) => 'a
|
||||
- Raises an error and prints the string as an error message.
|
||||
- Calls to error() do not return.
|
||||
|
||||
Input/output:
|
||||
|
||||
> printString(string message) => void
|
||||
- Takes a string and prints it on the standard output.
|
||||
|
||||
> 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() => string
|
||||
- Reads a line of text from the standard input.
|
||||
|
||||
Conversions to string:
|
||||
|
||||
> intToString(int val) => string
|
||||
- Converts an integer to a string.
|
||||
|
||||
> floatToString(float val) => string
|
||||
- Converts a floating point number to a string.
|
||||
|
||||
> charToString(char val) => string
|
||||
- Converts a character to a string.
|
||||
|
||||
String conversions:
|
||||
|
||||
> stringToInt(string val) => int
|
||||
- Converts a string to an integer.
|
||||
- Raises an error if the string cannot be converted.
|
||||
|
||||
> stringToFloat(string val) => float
|
||||
- Converts a string to a floating point number.
|
||||
- Raises an error if the string cannot be converted.
|
||||
|
||||
String operations:
|
||||
|
||||
> strlen(string s) => int
|
||||
- Takes a string and returns the string length.
|
||||
|
||||
> 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(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
|
||||
than the string length.
|
||||
|
||||
Numeric operations:
|
||||
|
||||
> sqrt(float f) => float
|
||||
- Produces the square root of its argument.
|
||||
|
||||
_Operators_
|
||||
|
||||
Unary operators:
|
||||
|
||||
> ! : bool -> bool
|
||||
- Boolean negation (not)
|
||||
|
||||
> - : bool -> bool
|
||||
- Arithmetic negation
|
||||
|
||||
Binary operators:
|
||||
|
||||
> || : bool * bool -> bool
|
||||
- Boolean disjunction (or)
|
||||
|
||||
> && : bool * bool -> bool
|
||||
- Boolean conjunction (and)
|
||||
|
||||
> == : bool * bool -> bool
|
||||
> == : int * int -> bool
|
||||
> == : char * char -> bool
|
||||
> == : float * float -> bool
|
||||
> == : string * string -> bool
|
||||
- Equivalence for primitives (value equality)
|
||||
|
||||
> == : Any * Any -> bool
|
||||
- Identity for classes (pointer equality)
|
||||
|
||||
> != (same types as ==)
|
||||
- Boolean negation of equivalence/identity
|
||||
|
||||
> ==== : Any * Any -> bool
|
||||
- Equivalence for classes (value equality)
|
||||
|
||||
> < : int * int -> bool
|
||||
> < : float * float -> bool
|
||||
> < : char * char -> bool
|
||||
> < : string * string -> bool
|
||||
- Less than (numeric / character set / lexiographic)
|
||||
|
||||
> > (same types as <)
|
||||
- Greater than
|
||||
|
||||
> <= (same types as <)
|
||||
- Less than or equal to
|
||||
|
||||
> >= (same types as <)
|
||||
- Greater than or equal to
|
||||
|
||||
> + : int * int -> int
|
||||
> + : float * float -> float
|
||||
- Addition
|
||||
|
||||
> + : string * string -> string
|
||||
- String concatenation
|
||||
|
||||
> - : int * int -> int
|
||||
> - : float * float -> float
|
||||
- Subtraction
|
||||
|
||||
> * : int * int -> int
|
||||
> * : float * float -> float
|
||||
- Multiplication
|
||||
|
||||
> / : int * int -> int
|
||||
- Integer division
|
||||
|
||||
> / : float * float -> float
|
||||
- Division
|
||||
|
||||
> % : int * int -> int
|
||||
- Remainder (from integer division)
|
||||
|
||||
_Grammar_
|
||||
|
||||
NOTE: Since I want to use parentheses to mean "real" parentheses, I use
|
||||
square brackets for grouping inside of rules.
|
||||
|
||||
<program> ::= <defn>*
|
||||
|
||||
<defn> ::= <function>
|
||||
| <top-bind>
|
||||
| <type>
|
||||
| <class>
|
||||
| <mixin>
|
||||
| <subclass>
|
||||
|
||||
<top-bind> ::= <bind> = <expr> ;
|
||||
| ( <bind> [, <bind>]* ) = <expr>;
|
||||
|
||||
<bind> ::= <tid> <id>
|
||||
| _
|
||||
|
||||
<function> ::= <tid> <id> ( <argdecls> ) <block>
|
||||
|
||||
<tid> ::= <ifacet>
|
||||
| <primtype>
|
||||
| <funtype>
|
||||
| <tuptype>
|
||||
|
||||
<funtype> ::= <tid> -> <tid>
|
||||
|
||||
<tuptype> ::= < >
|
||||
| < <tid> [, <tid>]* >
|
||||
|
||||
<ifacet> ::= id
|
||||
| Any
|
||||
|
||||
<primtype> ::= int
|
||||
| float
|
||||
| bool
|
||||
| str
|
||||
| char
|
||||
| void
|
||||
|
||||
<type> ::= type <id> <extends> { <mfdecl>* }
|
||||
| interface <id> <extends> { <mfdecl>* }
|
||||
|
||||
<extends> ::= extends <ifacet> [, <ifacet>]*
|
||||
| <: <ifacet> [, <ifacet>]*
|
||||
|
|
||||
|
||||
<mfdecl> ::= <tid> <fdid> ;
|
||||
| <tid> <mdid> ( <argdecls>* ) ;
|
||||
|
||||
<argdecls> ::= <argdecl> [, <argdecl>]*
|
||||
|
|
||||
|
||||
<argdecl> ::= <tid>
|
||||
| <tid> <varid>
|
||||
|
||||
<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> <initargs> -> <ifacet>
|
||||
<impls> <mixbody>
|
||||
| final mixin <id> <initargs> : <ifacet> <initargs> -> <ifacet>
|
||||
<impls> <mixbody>
|
||||
|
||||
<initargs> ::= ( <tid> <id> [, <tid> <id>]* )
|
||||
| ( )
|
||||
|
||||
<impls> ::= implements <ifacet> [, <ifacet>]*
|
||||
| impl <ifacet> [, <ifacet>]*
|
||||
|
|
||||
|
||||
<clsbody> ::= { <mfidefn>* <export>* }
|
||||
|
||||
<mixbody> ::= { <mfidefn>* <supernew> <mfidefn>* <export>* }
|
||||
|
||||
<mfidefn> ::= init <tid> <id> ;
|
||||
| init <tid> <id> = <expr> ;
|
||||
| <tid> <id> = <expr> ;
|
||||
| <tid> <id> ( <argdefns> ) <block>
|
||||
|
||||
<supernew> ::= super( <newargs> ) ;
|
||||
|
||||
<argdefns> ::= <argdefn> [, <argdefn>]*
|
||||
|
|
||||
|
||||
<argdefn> ::= <tid> <id>
|
||||
|
||||
<newargs> ::= <newarg> [, <newarg>]*
|
||||
|
|
||||
|
||||
<newarg> ::= <id> = <expr>
|
||||
|
||||
<export> ::= export <ifacet> : <renames> ;
|
||||
|
||||
<renames> ::= <rename> [, <rename>]*
|
||||
|
||||
<rename> ::= <id>
|
||||
| <id> as <id>
|
||||
|
||||
<expr> ::= <literal>
|
||||
| <lambda>
|
||||
| <tuple>
|
||||
| #n <expr>
|
||||
| <id>
|
||||
| <expr> = <expr>
|
||||
| <expr> <tuple>
|
||||
| this
|
||||
| <expr> : <ifacet>
|
||||
| <expr> isa <ifacet>
|
||||
| if <expr> <block> [else <block>]?
|
||||
| cond { [<expr> => <expr> ;]+ }
|
||||
| cond { [<expr> => <expr> ;]* else <expr> ; }
|
||||
| while <expr> <block>
|
||||
| new <id> : <ifacet> ( <newargs> )
|
||||
| new <id> ( <newargs> )
|
||||
| ! <expr>
|
||||
| - <expr>
|
||||
| <expr> || <expr>
|
||||
| <expr> && <expr>
|
||||
| <expr> == <expr>
|
||||
| <expr> != <expr>
|
||||
| <expr> ==== <expr>
|
||||
| <expr> < <expr>
|
||||
| <expr> > <expr>
|
||||
| <expr> <= <expr>
|
||||
| <expr> >= <expr>
|
||||
| <expr> + <expr>
|
||||
| <expr> - <expr>
|
||||
| <expr> * <expr>
|
||||
| <expr> / <expr>
|
||||
| <expr> % <expr>
|
||||
| <expr> . <id>
|
||||
| return <expr>
|
||||
| <block>
|
||||
|
||||
NOTE: Here's the precedence and associativity of things above.
|
||||
Top is most strongly binding, bottom is least. Things on
|
||||
the same line have same precedence. The : below refers to
|
||||
casting, and the = is for assignment. else requires a
|
||||
precedence to avoid shift/reduce errors, even though we
|
||||
don't have the dangling else problem.
|
||||
|
||||
LEFT | RIGHT | NONASSOC
|
||||
----------+----------+-----------
|
||||
. | |
|
||||
| | ( (function application)
|
||||
| | #n (tuple selector)
|
||||
| : isa |
|
||||
| | !, - (un)
|
||||
* / % | |
|
||||
+ - | |
|
||||
| | < <= > >=
|
||||
| | ====
|
||||
== != | |
|
||||
&& | |
|
||||
|| | |
|
||||
= | |
|
||||
else | |
|
||||
| | return
|
||||
|
||||
<tuple> ::= ( )
|
||||
| ( <exprs-cd> )
|
||||
<lambda> ::= <tid> fun ( <argdecls> ) <block>
|
||||
|
||||
<exprs-cd> ::= <expr> [, <expr>]*
|
||||
| <expr>
|
||||
|
||||
<literal> ::= <intlit>
|
||||
| <floatlit>
|
||||
| true
|
||||
| false
|
||||
| <strlit>
|
||||
| <charlit>
|
||||
| null
|
||||
|
||||
<block> ::= { <stmts> }
|
||||
|
||||
<stmts> ::= <expr-sc>
|
||||
| <vardefn> <stmts>
|
||||
| <expr-sc> <stmts>
|
||||
|
||||
<vardefn> ::= <bind> = <expr> ;
|
||||
| ( <bind> [, <bind>]* ) = <expr> ;
|
||||
|
||||
<expr-sc> ::= <expr> ;
|
||||
|
||||
_Mixin Definitions_
|
||||
|
||||
Assume a mixin of the following form:
|
||||
|
||||
[final] mixin MixinName( initType1 initArg1, ..., initTypeN initArgN ) :
|
||||
ParentIFace( superType1 superArg1, ..., superTypeM superArgM ) -> SelfIFace
|
||||
[implements IFace1, ..., IFaceK]
|
||||
{
|
||||
Member1; ... MemberI;
|
||||
SuperNew;
|
||||
MemberI+1; ... MemberJ;
|
||||
Exports;
|
||||
}
|
||||
|
||||
This defines a mixin called MixinName. This mixin consumes a class with
|
||||
selftype ParentIFace and produces one with selftype SelfIFace. The parent class
|
||||
must have the initialization arguments listed after ParentIFace. These
|
||||
arguments are supplied by the new class's initialization. The new class
|
||||
provides interfaces IFace1 through IFaceK for clients and interface SelfIFace
|
||||
(its selftype) for further mixins.
|
||||
|
||||
The new class introduces the arguments listed after MixinName as well as all
|
||||
init fields declared in the members (Member1 through MemberJ). All init
|
||||
arguments, whether declared in the header or the body of the mixin definition,
|
||||
are both initialization arguments to the new class and fields usable within
|
||||
the body of the class. Init field declarations in the body may include default
|
||||
values. All other initialization arguments to the new class are passed on to
|
||||
its superclass initializer.
|
||||
|
||||
Member definitions include fields, init fields, and methods, and exactly one
|
||||
call to the superclass initializer; as mentioned above, init arguments are also
|
||||
implicit field definitions. Export declarations define a mapping from exported
|
||||
names to internal member names.
|
||||
|
|
@ -1,46 +0,0 @@
|
|||
(module environment mzscheme
|
||||
|
||||
(require (lib "contract.ss")
|
||||
(prefix env: (planet "environment.ss" ("cobbe" "environment.plt" 2 1)))
|
||||
)
|
||||
|
||||
(provide/contract
|
||||
[mapping? (any/c . -> . boolean?)]
|
||||
[empty (-> mapping?)]
|
||||
[extend (mapping? identifier? any/c . -> . mapping?)]
|
||||
[contains? (mapping? identifier? . -> . boolean?)]
|
||||
[lookup (([mapping
|
||||
(lambda (mapping)
|
||||
(and (mapping? mapping)
|
||||
(contains? mapping id)))]
|
||||
[id identifier?])
|
||||
. ->r . any)]
|
||||
)
|
||||
|
||||
;; mapping? : Any -> Boolean
|
||||
;; Reports whether a value is a mapping.
|
||||
(define (mapping? value)
|
||||
(env:env? value))
|
||||
|
||||
;; empty : -> [Mapping X]
|
||||
;; Contructs an empty mapping.
|
||||
(define (empty)
|
||||
(env:make-empty-env bound-identifier=?))
|
||||
|
||||
;; extend : [Mapping X] Identifier X -> [Mapping X]
|
||||
;; Adds or shadows an environment binding.
|
||||
(define (extend mapping id entry)
|
||||
(env:extend-env (list id) (list entry) mapping))
|
||||
|
||||
;; contains? : [Mapping X] Identifier -> Boolean
|
||||
;; Reports whether the given key has an entry.
|
||||
(define (contains? mapping id)
|
||||
(env:bound? mapping id))
|
||||
|
||||
;; lookup : [Mapping X] Identifier -> X
|
||||
;; Returns the entry for the given key.
|
||||
;; Raises exn:fail:contract if no entry exists.
|
||||
(define (lookup mapping id)
|
||||
(env:lookup mapping id))
|
||||
|
||||
)
|
||||
|
|
@ -1,41 +0,0 @@
|
|||
(define (push stack num)
|
||||
(send stack BoundedStack<%>-push (new IntegerC% [value num])))
|
||||
|
||||
(define s0 (emptyBoundedStack 5))
|
||||
(define s1 (push s0 5))
|
||||
(define s2 (push s1 3))
|
||||
(define s3 (push s2 10))
|
||||
(define s4 (push s3 20))
|
||||
(define s5 (push s4 40))
|
||||
|
||||
(append (map interface? (list List<%>
|
||||
Stack<%>
|
||||
BoundedStack<%>
|
||||
Integer<%>))
|
||||
(map class? (list ConsList%
|
||||
BoundedStackC%
|
||||
ListStackC%
|
||||
IntegerC%))
|
||||
(map
|
||||
(lambda (object)
|
||||
(andmap
|
||||
(lambda (spec) (is-a? object spec))
|
||||
(list Stack<%> BoundedStack<%> BoundedStack<%>)))
|
||||
(list s0 s1 s2 s3 s4 s5))
|
||||
(list
|
||||
(not (send s0 BoundedStack<%>-isFull '()))
|
||||
(not (send s1 BoundedStack<%>-isFull '()))
|
||||
(not (send s2 BoundedStack<%>-isFull '()))
|
||||
(not (send s3 BoundedStack<%>-isFull '()))
|
||||
(not (send s4 BoundedStack<%>-isFull '()))
|
||||
(send s5 BoundedStack<%>-isFull '()))
|
||||
(list
|
||||
(let* ([expected (list 5 3 10 20 40)]
|
||||
[actual (list)])
|
||||
(send s5 BoundedStack<%>-foreach
|
||||
(lambda (int)
|
||||
(set! actual (cons (send int Integer<%>-value-get 'Dummy) actual))))
|
||||
(equal? expected actual))
|
||||
(with-handlers ([exn:fail? (lambda (exn) #t)])
|
||||
(push s5 50)
|
||||
#f)))
|
||||
|
|
@ -1,345 +0,0 @@
|
|||
//
|
||||
//
|
||||
// -$@:@ @@
|
||||
// @ -@ @ @
|
||||
// $: @@@@@ $@$: $@+@ @ @@@
|
||||
// -$@$ @ -@ $+ -@ @ *$
|
||||
// *$ @ -$@$@ @ @$$
|
||||
// @ @ $* @ @ @$$
|
||||
// @+ -$ @: :$ @- *@ $* -$ @ -$
|
||||
// @:@$- :@@$- -$$-@@ $@$- @@ @@@-
|
||||
//
|
||||
//
|
||||
//
|
||||
//
|
||||
|
||||
type Stack {
|
||||
Stack push(Any x);
|
||||
<Stack, Any> pop();
|
||||
void foreach(Any -> void);
|
||||
}
|
||||
|
||||
class ListStackC(List list) : Stack impl Stack {
|
||||
|
||||
Stack push(Any x) {
|
||||
return new ListStackC(list = new ConsList(car = x, cdr = list));
|
||||
}
|
||||
|
||||
<Stack, Any> pop() {
|
||||
return (new ListStackC(list = list.rest()), list.first());
|
||||
}
|
||||
|
||||
void foreach(Any -> void f) { list.foreach(f); }
|
||||
|
||||
export Stack : push, pop, foreach;
|
||||
}
|
||||
|
||||
Stack emptyStack() {
|
||||
return new ListStackC(list = new MTList());
|
||||
}
|
||||
|
||||
//
|
||||
//
|
||||
//@@@@@: @@ @@ -$@:@ @@
|
||||
// @ :@ @ @ @ -@ @ @
|
||||
// @ -$ $@$ @@ @@ @@:@@: $@:@ -@@$ $@:@ $: @@@@@ $@$: $@+@ @ @@@
|
||||
// @@@$ $- -$ @ @ @+ :@ $* *@ $ -$ $* *@ -$@$ @ -@ $+ -@ @ *$
|
||||
// @ :$ @ @ @ @ @ @ @ @ @@@@@ @ @ *$ @ -$@$@ @ @$$
|
||||
// @ @ @ @ @ @ @ @ @ @ $ @ @ @ @ $* @ @ @$$
|
||||
// @ :@ $- -$ @: +@ @ @ $* *@ +: $* *@ @+ -$ @: :$ @- *@ $* -$ @ -$
|
||||
//@@@@@: $@$ :@$-@@@@@ @@@ $@:@@ $@@+ $@:@@ @:@$- :@@$- -$$-@@ $@$- @@ @@@-
|
||||
//
|
||||
//
|
||||
//
|
||||
//
|
||||
|
||||
type BoundedStack <: Stack {
|
||||
BoundedStack push(Any x);
|
||||
<BoundedStack, Any> pop();
|
||||
bool isFull();
|
||||
int spaceRemaining();
|
||||
}
|
||||
|
||||
// space = number of pushes possible on this stack
|
||||
class BoundedStackC(Stack stack, int space) : BoundedStack impl BoundedStack {
|
||||
|
||||
bool isFull() { return space < 1; }
|
||||
int spaceRemaining() { return space; }
|
||||
|
||||
BoundedStack push(Any x) {
|
||||
if(isFull()) { error("Stack is full"); }
|
||||
else {
|
||||
return new BoundedStackC(stack = stack.push(x), space = space - 1);
|
||||
};
|
||||
}
|
||||
|
||||
<BoundedStack, Any> pop() {
|
||||
(Stack s, Any obj) = stack.pop();
|
||||
return (new BoundedStackC(stack = s, space = space + 1), obj);
|
||||
}
|
||||
|
||||
void foreach(Any -> void f) { stack.foreach(f); }
|
||||
|
||||
export BoundedStack : push, pop, isFull, spaceRemaining, foreach;
|
||||
}
|
||||
|
||||
BoundedStack emptyBoundedStack(int n) {
|
||||
return new BoundedStackC(stack = emptyStack(), space = n);
|
||||
}
|
||||
|
||||
//
|
||||
//
|
||||
// +@@@*
|
||||
// @ @
|
||||
// @ @@:@@: @@@@@ -@@$ $@-@@ -@@$ @@-$+
|
||||
// @ @+ :@ @ $ -$ $* :@ $ -$ @$ :
|
||||
// @ @ @ @ @@@@@ @ @ @@@@@ @
|
||||
// @ @ @ @ $ @ @ $ @
|
||||
// @ @ @ @: :$ +: $* :@ +: @
|
||||
// -@@@: @@@ @@@ :@@$- $@@+ $@:@ $@@+ @@@@@
|
||||
// -$
|
||||
// -@@$
|
||||
//
|
||||
//
|
||||
|
||||
struct IntegerC(int value) : Integer { }
|
||||
|
||||
//
|
||||
//
|
||||
// @@@ @
|
||||
// @ @
|
||||
// @ -@@ :@@+@ @@@@@
|
||||
// @ @ @$ -@ @
|
||||
// @ @ :@@$- @
|
||||
// @ @ @ *@ @
|
||||
// @ @ @ @ :@ @: :$
|
||||
// @@@@@ @@@@@ $+@@: :@@$-
|
||||
//
|
||||
//
|
||||
//
|
||||
//
|
||||
|
||||
type List {
|
||||
|
||||
List addToFront(Any);
|
||||
List addToEnd(Any);
|
||||
|
||||
Any first();
|
||||
Any atIndex(int);
|
||||
Any last();
|
||||
|
||||
List rest();
|
||||
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);
|
||||
void foreach(Any -> void);
|
||||
|
||||
}
|
||||
|
||||
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("Cannot get the rest of the empty list!");
|
||||
}
|
||||
|
||||
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); }
|
||||
|
||||
void foreach(Any -> void f) { return(); }
|
||||
|
||||
export List : add as addToFront, add as addToEnd,
|
||||
no_elt as first, no_elts as atIndex, no_elt as last,
|
||||
rest, drop, take, reverse,
|
||||
ret_other as appendToEnd, ret_other as appendToFront,
|
||||
length, empty,
|
||||
map, fold as foldl, fold as foldr, filter, foreach;
|
||||
}
|
||||
|
||||
// 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; }
|
||||
|
||||
Any atIndex(int n) {
|
||||
if n == 0 {
|
||||
car;
|
||||
} else {
|
||||
cdr.atIndex(n - 1);
|
||||
};
|
||||
}
|
||||
|
||||
Any last() {
|
||||
if cdr.empty() {
|
||||
car;
|
||||
} else {
|
||||
cdr.last();
|
||||
};
|
||||
}
|
||||
|
||||
List rest() {
|
||||
return cdr;
|
||||
}
|
||||
|
||||
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);
|
||||
};
|
||||
}
|
||||
|
||||
void foreach(Any -> void f) {
|
||||
f(car);
|
||||
cdr.foreach(f);
|
||||
}
|
||||
|
||||
export List : addToFront, addToEnd, first, atIndex, last, reverse,
|
||||
rest, drop, take, appendToEnd, appendToFront, length, empty,
|
||||
map, foldl, foldr, filter, foreach;
|
||||
}
|
||||
|
||||
|
||||
//
|
||||
//
|
||||
//@@@@@@ @@
|
||||
// @ @ @
|
||||
// @ @ @@ @@ $@$: @@+-$: @@:@$- @ -@@$ :@@+@
|
||||
// @@@ $ -$- -@ @+@$@ @: -$ @ $ -$ @$ -@
|
||||
// @ @ $$- -$@$@ @ @ @ @ @ @ @@@@@ :@@$-
|
||||
// @ -$$ $* @ @ @ @ @ @ @ $ *@
|
||||
// @ @ -$- $ @- *@ @ @ @ @: -$ @ +: @ :@
|
||||
//@@@@@@ @@ @@ -$$-@@@@@@@@@ @-@$ @@@@@ $@@+ $+@@:
|
||||
// @
|
||||
// @@@
|
||||
//
|
||||
//
|
||||
|
||||
|
||||
// Stack empty = emptyBoundedStack(5);
|
||||
// Stack s1 = empty.push(new IntegerC(value = 5));
|
||||
// Stack s2 = s1.push(new IntegerC(value = 3));
|
||||
// Stack s3 = s2.push(new IntegerC(value = 10));
|
||||
// Stack s4 = s3.push(new IntegerC(value = 20));
|
||||
// Stack s5 = s4.push(new IntegerC(value = 40));
|
||||
|
||||
// use foreach + don't care(about binding) syntax
|
||||
|
||||
// _ = s5.foreach(void fun(Any x) {
|
||||
// cond {
|
||||
// x isa Integer => printLine(intToString((x : Integer).value));
|
||||
// else printLine("Unknown type of value");
|
||||
// };
|
||||
// });
|
||||
|
||||
// Now try adding something to s5!
|
||||
|
||||
// Stack s6 = s5.push(new IntegerC(value = 50));
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
(define EO (new EvenOddC%))
|
||||
|
||||
(list (interface? EvenOdd<%>)
|
||||
(class? EvenOddC%)
|
||||
(send EO EvenOdd<%>-even 4)
|
||||
(not (send EO EvenOdd<%>-even 5))
|
||||
(send EO EvenOdd<%>-odd 7)
|
||||
(not (send EO EvenOdd<%>-odd 6)))
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
type EvenOdd {
|
||||
bool even(int);
|
||||
bool odd(int);
|
||||
}
|
||||
|
||||
// The following class tests mutually recursive methods.
|
||||
|
||||
class EvenOddC() : EvenOdd impl EvenOdd {
|
||||
bool even(int n) {
|
||||
cond {
|
||||
n == 0 => return true;
|
||||
n < 0 => return even(-n);
|
||||
else return odd(n - 1);
|
||||
};
|
||||
}
|
||||
bool odd(int n) {
|
||||
cond {
|
||||
n == 0 => return false;
|
||||
n < 0 => return odd(-n);
|
||||
else return even(n - 1);
|
||||
};
|
||||
}
|
||||
export EvenOdd : even, odd;
|
||||
}
|
||||
|
|
@ -1,19 +0,0 @@
|
|||
(define MT (new MTList%))
|
||||
(define (Cons first rest) (new ConsList% [car first] [cdr rest]))
|
||||
|
||||
(define l0 MT)
|
||||
(define l1 (Cons 0 l0))
|
||||
(define l2 (Cons 1 l1))
|
||||
(define l3 (Cons 2 l2))
|
||||
|
||||
(list (interface? List<%>)
|
||||
(class? MTList%)
|
||||
(class? ConsList%)
|
||||
(send l0 List<%>-empty '())
|
||||
(not (send l1 List<%>-empty '()))
|
||||
(not (send l2 List<%>-empty '()))
|
||||
(not (send l3 List<%>-empty '()))
|
||||
(equal? (send l0 List<%>-length '()) 0)
|
||||
(equal? (send l1 List<%>-length '()) 1)
|
||||
(equal? (send l2 List<%>-length '()) 2)
|
||||
(equal? (send l3 List<%>-length '()) 3))
|
||||
|
|
@ -1,185 +0,0 @@
|
|||
type List {
|
||||
|
||||
List addToFront(Any);
|
||||
List addToEnd(Any);
|
||||
|
||||
Any first();
|
||||
Any atIndex(int);
|
||||
Any last();
|
||||
|
||||
List rest();
|
||||
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);
|
||||
void foreach(Any -> void);
|
||||
|
||||
}
|
||||
|
||||
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("Cannot get the rest of an empty list!");
|
||||
}
|
||||
|
||||
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); }
|
||||
|
||||
void foreach(Any -> void f) { return(); }
|
||||
|
||||
export List : add as addToFront, add as addToEnd,
|
||||
no_elt as first, no_elts as atIndex, no_elt as last,
|
||||
rest, drop, take, reverse,
|
||||
ret_other as appendToEnd, ret_other as appendToFront,
|
||||
length, empty,
|
||||
map, fold as foldl, fold as foldr, filter, foreach;
|
||||
}
|
||||
|
||||
// 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; }
|
||||
|
||||
Any atIndex(int n) {
|
||||
if n == 0 {
|
||||
car;
|
||||
} else {
|
||||
cdr.atIndex(n - 1);
|
||||
};
|
||||
}
|
||||
|
||||
Any last() {
|
||||
if cdr.empty() {
|
||||
car;
|
||||
} else {
|
||||
cdr.last();
|
||||
};
|
||||
}
|
||||
|
||||
List rest() { return cdr; }
|
||||
|
||||
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);
|
||||
};
|
||||
}
|
||||
|
||||
void foreach(Any -> void f) {
|
||||
f(car);
|
||||
cdr.foreach(f);
|
||||
}
|
||||
|
||||
export List : addToFront, addToEnd, first, atIndex, last, reverse,
|
||||
rest, drop, take, appendToEnd, appendToFront, length, empty,
|
||||
map, foldl, foldr, filter, foreach;
|
||||
}
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
(list (interface? T<%>)
|
||||
(class? Y%)
|
||||
(= (main 5) 120)
|
||||
(= ((fix (lambda (f)
|
||||
(lambda (n)
|
||||
(if (zero? n) 0 (+ n (f (- n 1))))))) 5)
|
||||
15))
|
||||
|
|
@ -1,15 +0,0 @@
|
|||
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));
|
||||
}
|
||||
|
||||
struct Y(T -> int -> int f) : T { }
|
||||
|
||||
int -> int factorialor(int -> int factorial) {
|
||||
int fun(int x) {
|
||||
if(x == 0) { 1; }
|
||||
else { x * factorial(x - 1); };
|
||||
};
|
||||
}
|
||||
|
||||
int main(int n) { fix(factorialor)(n); }
|
||||
|
|
@ -1 +0,0 @@
|
|||
(list (= x 3) (= y 4))
|
||||
|
|
@ -1 +0,0 @@
|
|||
(int x, int y) = { int x = 3; int y = 4; (x, y); };
|
||||
|
|
@ -1 +0,0 @@
|
|||
(list (= x 2))
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
int x = cond {
|
||||
1 > 3 => 4;
|
||||
5 < 6 => 2;
|
||||
else 8;
|
||||
};
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
(list (even 4)
|
||||
(not (even 5))
|
||||
(not (odd 4))
|
||||
(odd 5))
|
||||
|
|
@ -1,23 +0,0 @@
|
|||
// This tests mutually recursive function definitions.
|
||||
|
||||
bool even(int n) {
|
||||
cond {
|
||||
n == 0 => return true;
|
||||
n < 0 => return even(-n);
|
||||
else return odd(n - 1);
|
||||
};
|
||||
}
|
||||
|
||||
// If the following line is uncommented, loading this file
|
||||
// should fail because even and odd are no longer considered
|
||||
// mutually recursive.
|
||||
//
|
||||
// _ = null;
|
||||
|
||||
bool odd(int n) {
|
||||
cond {
|
||||
n == 0 => return false;
|
||||
n < 0 => return odd(-n);
|
||||
else return even(n - 1);
|
||||
};
|
||||
}
|
||||
|
|
@ -1,19 +0,0 @@
|
|||
(define (testfact fact)
|
||||
(list (= (fact 1) 1)
|
||||
(= (fact 2) 2)
|
||||
(= (fact 3) 6)
|
||||
(= (fact 4) 24)
|
||||
(= (fact 5) 120)))
|
||||
|
||||
(define (testfib fib)
|
||||
(list (= (fib 0) 0)
|
||||
(= (fib 2) 1)
|
||||
(= (fib 4) 3)
|
||||
(= (fib 6) 8)))
|
||||
|
||||
(append (testfact fact)
|
||||
(testfact fact2)
|
||||
(testfact impfact)
|
||||
(testfact (lambda (n) (cadr (fibfact n))))
|
||||
(testfib fib)
|
||||
(testfib (lambda (n) (car (fibfact n)))))
|
||||
|
|
@ -1,48 +0,0 @@
|
|||
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;
|
||||
};
|
||||
}
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
type Character {
|
||||
char value;
|
||||
String toString();
|
||||
}
|
||||
|
||||
class CharBox() : Character impl Character {
|
||||
init char value;
|
||||
|
||||
String toString() { return new StrBox(value = charToStr(value)); }
|
||||
|
||||
export Character : value, toString;
|
||||
}
|
||||
|
|
@ -1,78 +0,0 @@
|
|||
type Integer {
|
||||
int value;
|
||||
|
||||
Integer succ();
|
||||
Integer plus(Integer y);
|
||||
Integer times(Integer y);
|
||||
}
|
||||
|
||||
type IFact {
|
||||
Integer fact();
|
||||
}
|
||||
|
||||
class Zero() : Integer impl Integer, IFact {
|
||||
|
||||
int value = 0;
|
||||
|
||||
Integer plus(Integer y) {
|
||||
return y;
|
||||
}
|
||||
|
||||
Integer times(Integer y) {
|
||||
return (this : Integer);
|
||||
}
|
||||
|
||||
Integer succ() {
|
||||
return new Positive : Integer(pred = (this : Integer));
|
||||
}
|
||||
|
||||
Integer fact() {
|
||||
return new Positive : Integer(pred = (this : Integer));
|
||||
}
|
||||
|
||||
export Integer : value, plus, times, succ;
|
||||
|
||||
export IFact : fact;
|
||||
}
|
||||
|
||||
class Positive() : Integer impl Integer, IFact {
|
||||
|
||||
init Integer pred;
|
||||
|
||||
int value = pred.value + 1;
|
||||
|
||||
Integer plus(Integer y) {
|
||||
return pred.plus(y.succ());
|
||||
}
|
||||
|
||||
Integer times(Integer y) {
|
||||
return pred.times(y).plus(y);
|
||||
}
|
||||
|
||||
Integer succ() {
|
||||
return new Positive : Integer(pred = (this : Integer));
|
||||
}
|
||||
|
||||
Integer fact() {
|
||||
return times((pred : IFact).fact());
|
||||
}
|
||||
|
||||
export Integer : value, plus, times, succ;
|
||||
export IFact : fact;
|
||||
}
|
||||
|
||||
Integer main(){
|
||||
Integer zero = new Zero : Integer();
|
||||
Integer one = new Positive : Integer(pred = zero);
|
||||
Integer two = new Positive : Integer(pred = one);
|
||||
Integer three = one.plus(two);
|
||||
Integer four = two.times(two);
|
||||
Integer five = four.plus(one);
|
||||
Integer six = two.plus(four);
|
||||
Integer seven = one.plus(two.plus(four));
|
||||
Integer eight = two.times(two);
|
||||
Integer nine = three.times(three);
|
||||
Integer ten = nine.plus(one);
|
||||
|
||||
return (five : IFact).fact();
|
||||
}
|
||||
|
|
@ -1,33 +0,0 @@
|
|||
type IFact {
|
||||
int fact(int n);
|
||||
}
|
||||
|
||||
class FactRec() : IFact impl IFact {
|
||||
int fact(int n) {
|
||||
return factA(n, 1);
|
||||
}
|
||||
|
||||
int factA(int n, int a) {
|
||||
if n == 0 { a; }
|
||||
else { factA(n - 1, a * n); };
|
||||
}
|
||||
|
||||
export IFact : fact;
|
||||
}
|
||||
|
||||
class FactAcc() : IFact impl IFact {
|
||||
int fact(int n) {
|
||||
int ret = 1;
|
||||
while (n > 1) {
|
||||
ret = ret * n;
|
||||
n = n - 1;
|
||||
};
|
||||
return ret;
|
||||
}
|
||||
|
||||
export IFact : fact;
|
||||
}
|
||||
|
||||
int main(){
|
||||
(new FactRec:IFact()).fact(500) + (new FactAcc:IFact()).fact(500);
|
||||
}
|
||||
|
|
@ -1,13 +0,0 @@
|
|||
type Float {
|
||||
float value;
|
||||
|
||||
String toString();
|
||||
}
|
||||
|
||||
class FloatBox() : Float impl Float {
|
||||
init float value;
|
||||
|
||||
String toString() { return new StrBox(value = floatToStr(value)); }
|
||||
|
||||
export Float : value, toString;
|
||||
}
|
||||
|
|
@ -1,13 +0,0 @@
|
|||
type Integer {
|
||||
int value;
|
||||
|
||||
String toString();
|
||||
}
|
||||
|
||||
class IntBox() : Integer impl Integer {
|
||||
init int value;
|
||||
|
||||
String toString() { return new StrBox(value = intToStr(value)); }
|
||||
|
||||
export Integer : value, toString;
|
||||
}
|
||||
|
|
@ -1,58 +0,0 @@
|
|||
type Integer {
|
||||
init();
|
||||
|
||||
Integer pred;
|
||||
|
||||
Integer succ();
|
||||
Integer plus(Integer y);
|
||||
Integer times(Integer y);
|
||||
}
|
||||
|
||||
class Zero : Integer imp Integer {
|
||||
init() {
|
||||
my.pred = this;
|
||||
}
|
||||
|
||||
Integer pred;
|
||||
|
||||
Integer plus(Integer y) {
|
||||
return y;
|
||||
}
|
||||
|
||||
Integer times(Integer y) {
|
||||
return this;
|
||||
}
|
||||
|
||||
Integer succ() {
|
||||
Integer that = new Positive : Integer();
|
||||
that.pred = this;
|
||||
return that;
|
||||
}
|
||||
|
||||
export Integer : pred as pred, plus as plus, times as times, succ as succ;
|
||||
}
|
||||
|
||||
class Positive : Integer imp Integer {
|
||||
|
||||
init() {
|
||||
my.pred = null;
|
||||
}
|
||||
|
||||
Integer pred;
|
||||
|
||||
Integer plus(Integer y) {
|
||||
return pred.plus(y.succ());
|
||||
}
|
||||
|
||||
Integer times(Integer y) {
|
||||
return pred.times(y).plus(y);
|
||||
}
|
||||
|
||||
Integer succ() {
|
||||
Integer that = new Positive : Integer();
|
||||
that.pred = this;
|
||||
return that;
|
||||
}
|
||||
|
||||
export Integer : pred as pred, plus as plus, times as times, succ as succ;
|
||||
}
|
||||
|
|
@ -1,62 +0,0 @@
|
|||
type Integer {
|
||||
int value;
|
||||
|
||||
Integer succ();
|
||||
Integer plus(Integer y);
|
||||
Integer times(Integer y);
|
||||
}
|
||||
|
||||
class Zero() : Integer impl Integer {
|
||||
|
||||
int value = 0;
|
||||
|
||||
Integer plus(Integer y) {
|
||||
return y;
|
||||
}
|
||||
|
||||
Integer times(Integer y) {
|
||||
return (this : Integer);
|
||||
}
|
||||
|
||||
Integer succ() {
|
||||
return new Positive : Integer(pred = (this : Integer));
|
||||
}
|
||||
|
||||
export Integer : value, plus, times, succ;
|
||||
}
|
||||
|
||||
class Positive() : Integer impl Integer {
|
||||
|
||||
init Integer pred;
|
||||
|
||||
int value = pred.value + 1;
|
||||
|
||||
Integer plus(Integer y) {
|
||||
return pred.plus(y.succ());
|
||||
}
|
||||
|
||||
Integer times(Integer y) {
|
||||
return pred.times(y).plus(y);
|
||||
}
|
||||
|
||||
Integer succ() {
|
||||
return new Positive : Integer(pred = (this : Integer));
|
||||
}
|
||||
|
||||
export Integer : value, plus, times, succ;
|
||||
}
|
||||
|
||||
Integer main() {
|
||||
Integer zero = new Zero : Integer();
|
||||
Integer one = new Positive : Integer(pred = zero);
|
||||
Integer two = new Positive : Integer(pred = one);
|
||||
Integer three = one.plus(two);
|
||||
Integer four = two.times(two);
|
||||
Integer five = four.plus(one);
|
||||
Integer six = two.plus(four);
|
||||
Integer seven = one.plus(two.plus(four));
|
||||
Integer eight = two.times(two);
|
||||
Integer nine = three.times(three);
|
||||
|
||||
return nine.plus(one);
|
||||
}
|
||||
|
|
@ -1,56 +0,0 @@
|
|||
type Integer {
|
||||
Integer succ();
|
||||
Integer plus(Integer y);
|
||||
Integer times(Integer y);
|
||||
}
|
||||
|
||||
class Zero() : Integer impl Integer {
|
||||
|
||||
Integer plus(Integer y) {
|
||||
return y;
|
||||
}
|
||||
|
||||
Integer times(Integer y) {
|
||||
return (this : Integer);
|
||||
}
|
||||
|
||||
Integer succ() {
|
||||
return new Positive : Integer(pred = (this : Integer));
|
||||
}
|
||||
|
||||
export Integer : plus, times, succ;
|
||||
}
|
||||
|
||||
class Positive() : Integer impl Integer {
|
||||
|
||||
init Integer pred;
|
||||
|
||||
Integer plus(Integer y) {
|
||||
return pred.plus(y.succ());
|
||||
}
|
||||
|
||||
Integer times(Integer y) {
|
||||
return pred.times(y).plus(y);
|
||||
}
|
||||
|
||||
Integer succ() {
|
||||
return new Positive : Integer(pred = (this : Integer));
|
||||
}
|
||||
|
||||
export Integer : plus, times, succ;
|
||||
}
|
||||
|
||||
Integer main() {
|
||||
Integer zero = new Zero : Integer();
|
||||
Integer one = new Positive : Integer(pred = zero);
|
||||
Integer two = new Positive : Integer(pred = one);
|
||||
Integer three = one.plus(two);
|
||||
Integer four = two.times(two);
|
||||
Integer five = four.plus(one);
|
||||
Integer six = two.plus(four);
|
||||
Integer seven = one.plus(two.plus(four));
|
||||
Integer eight = two.times(two);
|
||||
Integer nine = three.times(three);
|
||||
|
||||
return nine.plus(one);
|
||||
}
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
List iota(int n) {
|
||||
List ret = new MTList : List();
|
||||
while(n > 0) {
|
||||
ret = new ConsList : List(car = new Int : IInt(value = n), cdr = ret);
|
||||
n = n - 1;
|
||||
};
|
||||
return ret;
|
||||
}
|
||||
|
||||
int main() {
|
||||
List x = iota(100);
|
||||
List y = x.map(fun(Any x) {
|
||||
if(x isa IInt) {
|
||||
new Int : IInt(value = (x : IInt).value * 2);
|
||||
} else {
|
||||
x;
|
||||
};
|
||||
});
|
||||
(y.foldl(fun(Any x, Any i) {
|
||||
if x isa IInt && i isa IInt {
|
||||
new Int : IInt(value = (x : IInt).value + (i : IInt).value);
|
||||
} else { i; } ;
|
||||
}, new Int : IInt(value = 0)) : IInt).value;
|
||||
}
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
"List" ; for List, MTList, ConsList
|
||||
"struct-test" ; for Int/IInt
|
||||
"List-main" ; for main
|
||||
|
|
@ -1,177 +0,0 @@
|
|||
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;
|
||||
}
|
||||
|
|
@ -1,25 +0,0 @@
|
|||
IStack main() {
|
||||
IStack x = new CountedListStack : IStack();
|
||||
IStack y = null;
|
||||
|
||||
x.push(new CharBox : Character(value = '5'));
|
||||
x.push(new IntBox : Integer(value = 3));
|
||||
|
||||
y = x.copy();
|
||||
|
||||
while(!y.empty()) {
|
||||
Any curr = y.pop();
|
||||
|
||||
if curr isa Character {
|
||||
printLine("Got a character");
|
||||
} else {
|
||||
if curr isa Integer {
|
||||
printLine("Got an integer");
|
||||
} else {
|
||||
printLine("Got something else");
|
||||
};
|
||||
};
|
||||
};
|
||||
|
||||
x;
|
||||
}
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
"List" ; For IList, MTList, and ConsList
|
||||
"Character" ; For Character and CharBox
|
||||
"Integer-box" ; For Integer and IntBox
|
||||
"Float" ; For Float and FloatBox
|
||||
"String" ; For String and StrBox
|
||||
"Stack" ; For IStack, ListStack, and CountedListStack
|
||||
"Stack-main" ; For the main expression
|
||||
|
|
@ -1,80 +0,0 @@
|
|||
type IStack
|
||||
{
|
||||
void push (Any elt);
|
||||
Any pop();
|
||||
bool empty();
|
||||
IStack copy();
|
||||
}
|
||||
|
||||
class ListStack() : IStack impl IStack {
|
||||
List stack = new MTList();
|
||||
|
||||
void push (Any elt) {
|
||||
stack = new ConsList(car = elt, cdr = stack);
|
||||
}
|
||||
|
||||
Any pop() {
|
||||
if stack.empty() {
|
||||
error("The stack is empty!");
|
||||
} else {
|
||||
Any x = stack.first();
|
||||
stack = stack.drop(1);
|
||||
return x;
|
||||
};
|
||||
}
|
||||
|
||||
bool empty() {
|
||||
return stack.empty();
|
||||
}
|
||||
|
||||
IStack copy() {
|
||||
List tocopy = stack.reverse();
|
||||
IStack newStack = new ListStack();
|
||||
while(!tocopy.empty()) {
|
||||
newStack.push(tocopy.first());
|
||||
tocopy = tocopy.drop(1);
|
||||
};
|
||||
return newStack;
|
||||
}
|
||||
|
||||
export IStack : push, pop, empty, copy;
|
||||
}
|
||||
|
||||
type ICountedStack <: IStack
|
||||
{
|
||||
int numElements();
|
||||
}
|
||||
|
||||
mixin addCount() : ICountedStack at IStack impl ICountedStack
|
||||
{
|
||||
int numElts = 0;
|
||||
|
||||
super();
|
||||
|
||||
void countedPush(Any elt)
|
||||
{
|
||||
numElts = numElts + 1;
|
||||
push(elt);
|
||||
}
|
||||
|
||||
Any countedPop()
|
||||
{
|
||||
Any x = pop();
|
||||
numElts = numElts - 1;
|
||||
return x;
|
||||
}
|
||||
|
||||
int getSize()
|
||||
{
|
||||
numElts;
|
||||
}
|
||||
|
||||
export ICountedStack :
|
||||
countedPush as push,
|
||||
countedPop as pop,
|
||||
empty,
|
||||
copy, // but this isn't a countable stack!
|
||||
getSize as numElements;
|
||||
}
|
||||
|
||||
subclass CountedListStack = addCount(ListStack);
|
||||
|
|
@ -1,36 +0,0 @@
|
|||
type String {
|
||||
str value;
|
||||
|
||||
void printStr();
|
||||
void printLine();
|
||||
Integer strToInt();
|
||||
Float strToFloat();
|
||||
Integer strLen();
|
||||
String substr(int, int);
|
||||
Character charAt(int);
|
||||
}
|
||||
|
||||
class StrBox() : String impl String {
|
||||
init str value;
|
||||
|
||||
void printStr() { printStr(value); }
|
||||
|
||||
void printLine() { printLine(value); }
|
||||
|
||||
Integer strToInt() { return new IntBox(value = strToInt(value)); }
|
||||
|
||||
Float strToFloat() { return new FloatBox(value = strToFloat(value)); }
|
||||
|
||||
Integer strLen() { return new IntBox(value = strLen(value)); }
|
||||
|
||||
String substr(int start, int end) {
|
||||
return new StrBox(value = substr(value, start, end));
|
||||
}
|
||||
|
||||
Character charAt(int i) {
|
||||
return new CharBox(value = charAt(value, i));
|
||||
}
|
||||
|
||||
export String : value, printStr, printLine, strToInt, strToFloat, strLen,
|
||||
substr, charAt;
|
||||
}
|
||||
|
|
@ -1,15 +0,0 @@
|
|||
int -> int fix(<int -> int> -> int -> int f) {
|
||||
T -> int -> int g = fun(T x) { f(fun(int y) { x.f x y; }); };
|
||||
g (new Y(f = g));
|
||||
}
|
||||
|
||||
struct Y : T {
|
||||
init T -> int -> int f;
|
||||
}
|
||||
|
||||
int factorialor(int -> int factorial) (int x) {
|
||||
if(x == 0) 1
|
||||
else x * factorial(x - 1);
|
||||
}
|
||||
|
||||
int main(int n) { fix factorialor n; }
|
||||
|
|
@ -1,40 +0,0 @@
|
|||
// 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);
|
||||
}
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
int main() {
|
||||
int x = if true { 3; } else { error("I shouldn't be here!"); };
|
||||
x + 4;
|
||||
}
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
type t {
|
||||
int x;
|
||||
}
|
||||
|
||||
type t2 <: t {
|
||||
int y;
|
||||
}
|
||||
|
||||
type contains_t {
|
||||
t x;
|
||||
}
|
||||
|
||||
class c() : t2 impl t2 {
|
||||
init int x;
|
||||
init int y;
|
||||
|
||||
export t2 : x, y;
|
||||
}
|
||||
|
||||
class cct() : contains_t impl contains_t {
|
||||
init t2 x;
|
||||
|
||||
export contains_t : x;
|
||||
}
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
type t {
|
||||
int x;
|
||||
}
|
||||
|
||||
class c(int x) : t impl t {
|
||||
int y = x;
|
||||
export t : y as x;
|
||||
}
|
||||
|
||||
t main() {
|
||||
new c:t();
|
||||
}
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
int fact(int x) {
|
||||
int ret = 1;
|
||||
while(x > 1) {
|
||||
ret = ret * x;
|
||||
x = x - 1;
|
||||
};
|
||||
return ret;
|
||||
}
|
||||
|
||||
int main() {
|
||||
fact(5);
|
||||
}
|
||||
|
|
@ -1,435 +0,0 @@
|
|||
// -*- java -*-
|
||||
|
||||
/*
|
||||
* General Notes:
|
||||
*
|
||||
* 1) we need some sort of error reporting mechanism. Full exceptions
|
||||
* would be nice, but even a MzScheme-like error primitive would be
|
||||
* sufficient for now.
|
||||
* 2) We desperately need some sort of polymorphism -- even Java 1.4
|
||||
* style would be an improvement!
|
||||
* 3) What did we decide w.r.t typing _this_ again?
|
||||
*/
|
||||
|
||||
/*
|
||||
* Assumed built-in types, operations
|
||||
* OCaml-style extensional equality
|
||||
* null? (or, more generally, intensional equality)
|
||||
* String (changed to str)
|
||||
* int
|
||||
* boolean (changed to bool)
|
||||
*/
|
||||
|
||||
/*
|
||||
**********************************************************************
|
||||
* Infrastructure: sets, lists, etc.
|
||||
**********************************************************************/
|
||||
|
||||
type StringList
|
||||
{
|
||||
bool contains(str s);
|
||||
|
||||
// Returns copy of this list with first occurrence of s removed.
|
||||
// If no s, returns copy of this list.
|
||||
StringList remove(str s);
|
||||
|
||||
// fold that produces a set.
|
||||
StringSet setFold(StringSet initial, StringSetOp op);
|
||||
|
||||
bool hasDuplicates();
|
||||
}
|
||||
|
||||
type StringSetOp
|
||||
{
|
||||
// invoke this closure.
|
||||
StringSet run(StringSet accum, str s);
|
||||
}
|
||||
|
||||
class EmptyStringList() : StringList impl StringList
|
||||
{
|
||||
bool contains(str s) { false; }
|
||||
StringList remove(str s) { this : StringList; }
|
||||
|
||||
StringSet setFold(StringSet initial, StringSetOp op) { initial; }
|
||||
|
||||
bool hasDuplicates() { false; }
|
||||
|
||||
export StringList : contains, setFold, remove, hasDuplicates;
|
||||
}
|
||||
|
||||
class ConsStringList(StringList rest) : StringList impl StringList
|
||||
{
|
||||
init str first;
|
||||
|
||||
StringList rest =
|
||||
if rest == null {
|
||||
error("ConsStringList.rest null");
|
||||
} else { rest; };
|
||||
|
||||
bool contains(str s)
|
||||
{
|
||||
(s == first) || rest.contains(s);
|
||||
}
|
||||
|
||||
StringList remove(str s)
|
||||
{
|
||||
if s == first { rest; }
|
||||
else { new ConsStringList : StringList
|
||||
(first = first,
|
||||
rest = rest.remove(s)); };
|
||||
}
|
||||
|
||||
StringSet setFold(StringSet initial, StringSetOp op)
|
||||
{
|
||||
rest.setFold(op.run(initial, first), op);
|
||||
}
|
||||
|
||||
bool hasDuplicates()
|
||||
{
|
||||
rest.contains(first) || rest.hasDuplicates();
|
||||
}
|
||||
|
||||
export StringList : contains, setFold, remove, hasDuplicates;
|
||||
}
|
||||
|
||||
class UnionOp() : StringSetOp impl StringSetOp
|
||||
{
|
||||
StringSet run(StringSet accum, str s)
|
||||
{
|
||||
accum.singleUnion(s);
|
||||
}
|
||||
|
||||
export StringSetOp : run;
|
||||
}
|
||||
|
||||
type StringSet
|
||||
{
|
||||
StringSet singleUnion(str elt);
|
||||
StringSet union(StringSet rhs);
|
||||
StringSet subElt(str elt);
|
||||
}
|
||||
|
||||
class StringSetCls() : StringSet impl StringSet
|
||||
{
|
||||
init StringList contents = new EmptyStringList : StringList();
|
||||
// this showed up a bug in the parser where I wasn't adding
|
||||
// the default expressions to things. This caused problems
|
||||
// when relying on them (i.e. not giving a contents init arg).
|
||||
// Fixed.
|
||||
|
||||
// How should this get translated? You have a default value
|
||||
// for contents so it can't go into the init args in the header,
|
||||
// but you want an additional check later (hasDuplicates()).
|
||||
StringList contents =
|
||||
if contents.hasDuplicates() {
|
||||
error("StringList.contents must be set");
|
||||
} else { contents; };
|
||||
|
||||
StringSet singleUnion(str elt)
|
||||
{
|
||||
if contents.contains(elt) { this : StringSet; }
|
||||
else {
|
||||
new StringSetCls : StringSet
|
||||
(contents = new ConsStringList : StringList(first = elt,
|
||||
rest = contents));
|
||||
};
|
||||
}
|
||||
|
||||
StringSet union(StringSet rhs)
|
||||
{
|
||||
contents.setFold(rhs, new UnionOp : StringSetOp());
|
||||
}
|
||||
|
||||
StringSet subElt(str elt)
|
||||
{
|
||||
new StringSetCls : StringSet(contents = contents.remove(elt));
|
||||
}
|
||||
|
||||
export StringSet : singleUnion, union, subElt;
|
||||
// was export StringSetCls, typechecker caught this.
|
||||
}
|
||||
|
||||
/*
|
||||
**********************************************************************
|
||||
* Values
|
||||
**********************************************************************/
|
||||
|
||||
type Value
|
||||
{
|
||||
Value apply(Value arg);
|
||||
}
|
||||
|
||||
class IntValue() : Value impl Value // was class Constant, typechecker caught this
|
||||
// line 359 was the use of IntValue
|
||||
{
|
||||
init int n;
|
||||
|
||||
Value apply(Value arg) { error("cannot apply a constant"); }
|
||||
|
||||
export Value : apply;
|
||||
}
|
||||
|
||||
class Closure(Ast body, Env rho) : Value impl Value
|
||||
{
|
||||
init str argName;
|
||||
Ast body =
|
||||
if body == null {
|
||||
error("Closure.body null");
|
||||
} else { body; };
|
||||
Env rho =
|
||||
if rho == null {
|
||||
error("Closure.rho null");
|
||||
} else { rho; }; // was else body, Typechecker caught this
|
||||
|
||||
Value apply(Value arg)
|
||||
{
|
||||
body.getValue(rho.extend(argName, arg));
|
||||
// originally thought this was a bug in the interpreter,
|
||||
// but it was a bug in the typechecker (did supertype
|
||||
// checking on method arguments, not subtype checking). Fixed.
|
||||
}
|
||||
|
||||
export Value : apply; // no export statement, typechecker caught this.
|
||||
}
|
||||
|
||||
/*
|
||||
**********************************************************************
|
||||
* Types
|
||||
**********************************************************************/
|
||||
|
||||
type Type
|
||||
{
|
||||
Type getRange(Type domain);
|
||||
}
|
||||
|
||||
class IntType() : Type impl Type
|
||||
{
|
||||
Type getRange(Type domain) { error("IntType.getRange"); }
|
||||
|
||||
export Type : getRange;
|
||||
}
|
||||
|
||||
class ArrowType(Type dom, Type rng) : Type impl Type
|
||||
{
|
||||
Type dom =
|
||||
if dom == null {
|
||||
error("ArrowType.dom null");
|
||||
} else { dom; };
|
||||
Type rng =
|
||||
if rng == null {
|
||||
error("ArrowType.rng null");
|
||||
} else { rng; };
|
||||
|
||||
Type getRange(Type domain)
|
||||
{
|
||||
// extensional equality
|
||||
if domain ==== dom { rng; }
|
||||
else { error("arrowType.getRange: domain mismatch"); };
|
||||
}
|
||||
|
||||
export Type : getRange;
|
||||
}
|
||||
|
||||
/*
|
||||
**********************************************************************
|
||||
* Environments
|
||||
**********************************************************************/
|
||||
|
||||
type Env
|
||||
{
|
||||
Env extend(str var, Any t);
|
||||
Any lookup(str var);
|
||||
}
|
||||
|
||||
class EmptyEnv() : Env impl Env
|
||||
{
|
||||
Env extend(str var, Any t)
|
||||
{
|
||||
new RibEnv : Env(id = var, bdg = t, rest = this : Env);
|
||||
}
|
||||
|
||||
Any lookup(str var)
|
||||
{
|
||||
error("unbound id");
|
||||
}
|
||||
|
||||
export Env : extend, lookup;
|
||||
}
|
||||
|
||||
class RibEnv(Any bdg, Env rest) : Env impl Env
|
||||
{
|
||||
init str id;
|
||||
Any bdg =
|
||||
if bdg == null {
|
||||
error("RibEnv.bdg null");
|
||||
} else { bdg; };
|
||||
Env rest =
|
||||
if rest == null {
|
||||
error("RibEnv.rest null");
|
||||
} else { rest; };
|
||||
|
||||
Env extend(str var, Any t)
|
||||
{
|
||||
new RibEnv : Env(id = var, bdg = t, rest = this : Env);
|
||||
}
|
||||
|
||||
Any lookup(str var)
|
||||
{
|
||||
if var == id { bdg; } else { rest.lookup(var); };
|
||||
}
|
||||
|
||||
export Env : extend, lookup;
|
||||
// was export TypeEnv, should be Env, typechecker caught this.
|
||||
}
|
||||
/*
|
||||
**********************************************************************
|
||||
* ASTS
|
||||
**********************************************************************/
|
||||
|
||||
type Ast
|
||||
{
|
||||
StringSet vars();
|
||||
StringSet freeVars();
|
||||
|
||||
Type getType(Env gamma);
|
||||
Value getValue(Env rho);
|
||||
}
|
||||
|
||||
class Constant() : Ast impl Ast
|
||||
{
|
||||
init int n;
|
||||
|
||||
StringSet vars()
|
||||
{
|
||||
new StringSetCls : StringSet();
|
||||
}
|
||||
|
||||
StringSet fv()
|
||||
{
|
||||
vars();
|
||||
}
|
||||
|
||||
Type getType(Env gamma)
|
||||
{
|
||||
new IntType : Type();
|
||||
}
|
||||
|
||||
Value getValue(Env rho)
|
||||
{
|
||||
new IntValue : Value(n = n);
|
||||
}
|
||||
|
||||
export Ast : vars, fv as freeVars, getType, getValue;
|
||||
}
|
||||
|
||||
class Variable() : Ast impl Ast
|
||||
{
|
||||
init str name;
|
||||
|
||||
StringSet vars()
|
||||
{
|
||||
StringSet result = new StringSetCls : StringSet();
|
||||
result.singleUnion(name);
|
||||
}
|
||||
|
||||
StringSet fv() { vars(); }
|
||||
|
||||
Type getType(Env gamma)
|
||||
{
|
||||
gamma.lookup(name) : Type;
|
||||
}
|
||||
|
||||
Value getValue(Env rho)
|
||||
{
|
||||
rho.lookup(name) : Value;
|
||||
}
|
||||
|
||||
export Ast : vars, fv as freeVars, getType, getValue;
|
||||
// last part was erroneously typed "getName" instead of "getValue",
|
||||
// caught by typechecker.
|
||||
}
|
||||
|
||||
class Lambda(Ast body, Type argType) : Ast impl Ast
|
||||
{
|
||||
init str argName;
|
||||
|
||||
Ast body =
|
||||
if body == null {
|
||||
error("Lambda.body null");
|
||||
} else { body; };
|
||||
Type argType =
|
||||
if argType == null {
|
||||
error("Lambda.argType null");
|
||||
} else { argType; };
|
||||
|
||||
StringSet vars()
|
||||
{
|
||||
body.vars();
|
||||
}
|
||||
|
||||
StringSet freeVars()
|
||||
{
|
||||
body.freeVars().subElt(argName);
|
||||
// was arg (init field) instead of argName (field).
|
||||
// typechecker caught this.
|
||||
}
|
||||
|
||||
Type getType(Env gamma)
|
||||
{
|
||||
body.getType(gamma.extend(argName, argType));
|
||||
// originally thought this was a bug in the interpreter,
|
||||
// but it was a bug in the typechecker (did supertype
|
||||
// checking on method arguments, not subtype checking). Fixed.
|
||||
}
|
||||
|
||||
Value getValue(Env rho)
|
||||
{
|
||||
return new Closure : Value(argName = argName, body = body, rho = rho);
|
||||
}
|
||||
|
||||
export Ast : vars, freeVars, getType, getValue;
|
||||
}
|
||||
|
||||
class Application(Ast rator, Ast rand) : Ast impl Ast
|
||||
{
|
||||
Ast rator =
|
||||
if rator == null {
|
||||
error("Application.rator null");
|
||||
} else { rator; };
|
||||
Ast rand =
|
||||
if rand == null {
|
||||
error("Application.rand null");
|
||||
} else { rand; };
|
||||
|
||||
StringSet vars()
|
||||
{
|
||||
StringSet ratorVars = rator.vars();
|
||||
ratorVars.union(rand.vars());
|
||||
}
|
||||
|
||||
StringSet fv()
|
||||
{
|
||||
StringSet ratorFv = rator.freeVars();
|
||||
// rator.freeVars (public name) was rator.fv (private name).
|
||||
// typechecker caught this (happened below also with rand)
|
||||
ratorFv.union(rand.freeVars());
|
||||
}
|
||||
|
||||
Type getType(Env gamma)
|
||||
{
|
||||
Type ratorType = rator.getType(gamma);
|
||||
ratorType.getRange(rand.getType(gamma));
|
||||
}
|
||||
|
||||
Value getValue(Env rho)
|
||||
{
|
||||
Value ratorVal = rator.getValue(rho);
|
||||
ratorVal.apply(rand.getValue(rho));
|
||||
// ratorVal.apply was rator.apply, which gave method not found error
|
||||
// typechecker caught this.
|
||||
// also, rand.getValue was rand.value. Same error.
|
||||
// typechecker caught this.
|
||||
}
|
||||
|
||||
export Ast : vars, fv as freeVars, getType, getValue;
|
||||
}
|
||||
|
|
@ -1,465 +0,0 @@
|
|||
// -*- java -*-
|
||||
|
||||
/*
|
||||
* General Notes:
|
||||
*
|
||||
* 1) we need some sort of error reporting mechanism. Full exceptions
|
||||
* would be nice, but even a MzScheme-like error primitive would be
|
||||
* sufficient for now.
|
||||
* 2) We desperately need some sort of polymorphism -- even Java 1.4
|
||||
* style would be an improvement!
|
||||
* 3) What did we decide w.r.t typing _this_ again?
|
||||
*/
|
||||
|
||||
/*
|
||||
* Assumed built-in types, operations
|
||||
* OCaml-style extensional equality
|
||||
* null? (or, more generally, intensional equality)
|
||||
* String (changed to str)
|
||||
* int
|
||||
* boolean (changed to bool)
|
||||
*/
|
||||
|
||||
/*
|
||||
**********************************************************************
|
||||
* Boxing: str -> String
|
||||
**********************************************************************/
|
||||
|
||||
type String {
|
||||
str val;
|
||||
}
|
||||
|
||||
/*
|
||||
**********************************************************************
|
||||
* Infrastructure: sets, lists, etc.
|
||||
**********************************************************************/
|
||||
|
||||
type StringList
|
||||
{
|
||||
bool contains(String s);
|
||||
|
||||
// Returns copy of this list with first occurrence of s removed.
|
||||
// If no s, returns copy of this list.
|
||||
StringList remove(String s);
|
||||
|
||||
// fold that produces a set.
|
||||
StringSet setFold(StringSet initial, StringSetOp op);
|
||||
|
||||
bool hasDuplicates();
|
||||
}
|
||||
|
||||
type StringSetOp
|
||||
{
|
||||
// invoke this closure.
|
||||
StringSet run(StringSet accum, String s);
|
||||
}
|
||||
|
||||
class EmptyStringList() : StringList impl StringList
|
||||
{
|
||||
bool contains(String s) { false; }
|
||||
StringList remove(String s) { this : StringList; }
|
||||
|
||||
StringSet setFold(StringSet initial, StringSetOp op) { initial; }
|
||||
|
||||
bool hasDuplicates() { false; }
|
||||
|
||||
export StringList : contains, setFold, remove, hasDuplicates;
|
||||
}
|
||||
|
||||
class ConsStringList(String init_first, StringList init_rest) : StringList impl StringList
|
||||
{
|
||||
String first =
|
||||
if(init_first == null) {
|
||||
error("ConsStringList.init_first null");
|
||||
} else {
|
||||
init_first;
|
||||
};
|
||||
StringList rest =
|
||||
if init_rest == null {
|
||||
error("ConsStringList.init_rest null");
|
||||
} else { init_rest; };
|
||||
|
||||
bool contains(String s)
|
||||
{
|
||||
(s ==== first) || rest.contains(s);
|
||||
}
|
||||
|
||||
StringList remove(String s)
|
||||
{
|
||||
if s ==== first {
|
||||
rest;
|
||||
} else {
|
||||
new ConsStringList : StringList
|
||||
(init_first = first,
|
||||
init_rest = rest.remove(s));
|
||||
};
|
||||
}
|
||||
|
||||
StringSet setFold(StringSet initial, StringSetOp op)
|
||||
{
|
||||
rest.setFold(op.run(initial, first), op);
|
||||
}
|
||||
|
||||
bool hasDuplicates()
|
||||
{
|
||||
rest.contains(first) || rest.hasDuplicates();
|
||||
}
|
||||
|
||||
export StringList : contains, setFold, remove, hasDuplicates;
|
||||
}
|
||||
|
||||
class UnionOp() : StringSetOp impl StringSetOp
|
||||
{
|
||||
StringSet run(StringSet accum, String s)
|
||||
{
|
||||
accum.singleUnion(s);
|
||||
}
|
||||
|
||||
export StringSetOp : run;
|
||||
}
|
||||
|
||||
type StringSet
|
||||
{
|
||||
StringSet singleUnion(String elt);
|
||||
StringSet union(StringSet rhs);
|
||||
StringSet subElt(String elt);
|
||||
}
|
||||
|
||||
class StringSetCls() : StringSet impl StringSet
|
||||
{
|
||||
init StringList init_contents = new EmptyStringList : StringList();
|
||||
// this showed up a bug in the parser where I wasn't adding
|
||||
// the default expressions to things. This caused problems
|
||||
// when relying on them (i.e. not giving a contents init arg).
|
||||
// Fixed.
|
||||
|
||||
// How should this get translated? You have a default value
|
||||
// for contents so it can't go into the init args in the header,
|
||||
// but you want an additional check later (hasDuplicates()).
|
||||
StringList contents =
|
||||
if init_contents.hasDuplicates() {
|
||||
error("StringList.contents must be set");
|
||||
} else { init_contents; };
|
||||
|
||||
StringSet singleUnion(String elt)
|
||||
{
|
||||
if contents.contains(elt) {
|
||||
this : StringSet;
|
||||
} else {
|
||||
new StringSetCls : StringSet
|
||||
(init_contents = new ConsStringList : StringList(init_first = elt,
|
||||
init_rest = contents));
|
||||
};
|
||||
}
|
||||
|
||||
StringSet union(StringSet rhs)
|
||||
{
|
||||
contents.setFold(rhs, new UnionOp : StringSetOp());
|
||||
}
|
||||
|
||||
StringSet subElt(String elt)
|
||||
{
|
||||
new StringSetCls : StringSet(init_contents = contents.remove(elt));
|
||||
}
|
||||
|
||||
export StringSet : singleUnion, union, subElt;
|
||||
// was export StringSetCls, typechecker caught this.
|
||||
}
|
||||
|
||||
/*
|
||||
**********************************************************************
|
||||
* Values
|
||||
**********************************************************************/
|
||||
|
||||
type Value
|
||||
{
|
||||
Value apply(Value arg);
|
||||
}
|
||||
|
||||
class IntValue() : Value impl Value // was class Constant, typechecker caught this
|
||||
// line 359 was the use of IntValue
|
||||
{
|
||||
init int init_n;
|
||||
|
||||
Value apply(Value arg) { error("cannot apply a constant"); }
|
||||
|
||||
export Value : apply;
|
||||
}
|
||||
|
||||
class Closure(String init_argName, Ast init_body, Env init_rho) : Value impl Value
|
||||
{
|
||||
String argName =
|
||||
if init_argName == null {
|
||||
error("Closure.argName null");
|
||||
} else { init_argName; };
|
||||
Ast body =
|
||||
if init_body == null {
|
||||
error("Closure.body null");
|
||||
} else { init_body; };
|
||||
Env rho =
|
||||
if init_rho == null {
|
||||
error("Closure.rho null") ;
|
||||
} else { init_rho; }; // was else body, Typechecker caught this
|
||||
|
||||
Value apply(Value arg)
|
||||
{
|
||||
body.getValue(rho.extend(argName, arg));
|
||||
// originally thought this was a bug in the interpreter,
|
||||
// but it was a bug in the typechecker (did supertype
|
||||
// checking on method arguments, not subtype checking). Fixed.
|
||||
}
|
||||
|
||||
export Value : apply; // no export statement, typechecker caught this.
|
||||
}
|
||||
|
||||
/*
|
||||
**********************************************************************
|
||||
* Types
|
||||
**********************************************************************/
|
||||
|
||||
type Type
|
||||
{
|
||||
Type getRange(Type domain);
|
||||
}
|
||||
|
||||
class IntType() : Type impl Type
|
||||
{
|
||||
Type getRange(Type domain) { error("IntType.getRange"); }
|
||||
|
||||
export Type : getRange;
|
||||
}
|
||||
|
||||
class ArrowType(Type init_dom, Type init_rng) : Type impl Type
|
||||
{
|
||||
Type dom =
|
||||
if init_dom == null {
|
||||
error("ArrowType.dom null");
|
||||
} else { init_dom; };
|
||||
Type rng =
|
||||
if init_rng == null {
|
||||
error("ArrowType.rng null");
|
||||
} else { init_rng; };
|
||||
|
||||
Type getRange(Type domain)
|
||||
{
|
||||
// extensional equality
|
||||
if domain ==== dom { rng; }
|
||||
else { error("arrowType.getRange: domain mismatch"); };
|
||||
}
|
||||
|
||||
export Type : getRange;
|
||||
}
|
||||
|
||||
/*
|
||||
**********************************************************************
|
||||
* Environments
|
||||
**********************************************************************/
|
||||
|
||||
type Env
|
||||
{
|
||||
Env extend(String var, Any t);
|
||||
Any lookup(String var);
|
||||
}
|
||||
|
||||
class EmptyEnv() : Env impl Env
|
||||
{
|
||||
Env extend(String var, Any t)
|
||||
{
|
||||
new RibEnv : Env(init_id = var, init_bdg = t, init_rest = this : Env);
|
||||
}
|
||||
|
||||
Any lookup(String var)
|
||||
{
|
||||
error("unbound id");
|
||||
}
|
||||
|
||||
export Env : extend, lookup;
|
||||
}
|
||||
|
||||
class RibEnv(String init_id, Any init_bdg, Env init_rest) : Env impl Env
|
||||
{
|
||||
|
||||
String id =
|
||||
if init_id == null {
|
||||
error("RibEnv.id null");
|
||||
} else { init_id; };
|
||||
Any bdg =
|
||||
if init_bdg == null {
|
||||
error("RibEnv.bdg null");
|
||||
} else { init_bdg; };
|
||||
Env rest =
|
||||
if init_rest == null {
|
||||
error("RibEnv.rest null");
|
||||
} else { init_rest; };
|
||||
|
||||
Env extend(String var, Any t)
|
||||
{
|
||||
new RibEnv : Env(init_id = var, init_bdg = t, init_rest = this : Env);
|
||||
}
|
||||
|
||||
Any lookup(String var)
|
||||
{
|
||||
if var ==== id { bdg; }
|
||||
else { rest.lookup(var); };
|
||||
}
|
||||
|
||||
export Env : extend, lookup;
|
||||
// was export TypeEnv, should be Env, typechecker caught this.
|
||||
}
|
||||
/*
|
||||
**********************************************************************
|
||||
* ASTS
|
||||
**********************************************************************/
|
||||
|
||||
type Ast
|
||||
{
|
||||
StringSet vars();
|
||||
StringSet freeVars();
|
||||
|
||||
Type getType(Env gamma);
|
||||
Value getValue(Env rho);
|
||||
}
|
||||
|
||||
class Constant() : Ast impl Ast
|
||||
{
|
||||
init int n;
|
||||
|
||||
StringSet vars()
|
||||
{
|
||||
new StringSetCls : StringSet();
|
||||
}
|
||||
|
||||
StringSet fv()
|
||||
{
|
||||
vars();
|
||||
}
|
||||
|
||||
Type getType(Env gamma)
|
||||
{
|
||||
new IntType : Type();
|
||||
}
|
||||
|
||||
Value getValue(Env rho)
|
||||
{
|
||||
new IntValue : Value(init_n = n);
|
||||
}
|
||||
|
||||
export Ast : vars, fv as freeVars, getType, getValue;
|
||||
}
|
||||
|
||||
class Variable(String init_name) : Ast impl Ast
|
||||
{
|
||||
String name =
|
||||
if init_name == null {
|
||||
error("Variable.name null");
|
||||
} else { init_name; };
|
||||
|
||||
StringSet vars()
|
||||
{
|
||||
StringSet result = new StringSetCls : StringSet();
|
||||
result.singleUnion(name);
|
||||
}
|
||||
|
||||
StringSet fv() { vars(); }
|
||||
|
||||
Type getType(Env gamma)
|
||||
{
|
||||
gamma.lookup(name) : Type;
|
||||
}
|
||||
|
||||
Value getValue(Env rho)
|
||||
{
|
||||
rho.lookup(name) : Value;
|
||||
}
|
||||
|
||||
export Ast : vars, fv as freeVars, getType, getValue;
|
||||
// last part was erroneously typed "getName" instead of "getValue",
|
||||
// caught by typechecker.
|
||||
}
|
||||
|
||||
class Lambda(String init_arg, Ast init_body, Type init_argType) : Ast impl Ast
|
||||
{
|
||||
String argName =
|
||||
if init_arg == null {
|
||||
error("Lambda.argName null");
|
||||
} else { init_arg; };
|
||||
Ast body =
|
||||
if init_body == null {
|
||||
error("Lambda.body null");
|
||||
} else { init_body; };
|
||||
Type argType =
|
||||
if init_argType == null {
|
||||
error("Lambda.argType null");
|
||||
} else { init_argType; };
|
||||
|
||||
StringSet vars()
|
||||
{
|
||||
body.vars();
|
||||
}
|
||||
|
||||
StringSet freeVars()
|
||||
{
|
||||
body.freeVars().subElt(argName);
|
||||
// was arg (init field) instead of argName (field).
|
||||
// typechecker caught this.
|
||||
}
|
||||
|
||||
Type getType(Env gamma)
|
||||
{
|
||||
body.getType(gamma.extend(argName, argType));
|
||||
// originally thought this was a bug in the interpreter,
|
||||
// but it was a bug in the typechecker (did supertype
|
||||
// checking on method arguments, not subtype checking). Fixed.
|
||||
}
|
||||
|
||||
Value getValue(Env rho)
|
||||
{
|
||||
return new Closure : Value(init_argName = argName, init_body = body, init_rho = rho);
|
||||
}
|
||||
|
||||
export Ast : vars, freeVars, getType, getValue;
|
||||
}
|
||||
|
||||
class Application(Ast init_rator, Ast init_rand) : Ast impl Ast
|
||||
{
|
||||
Ast rator =
|
||||
if init_rator == null {
|
||||
error("Application.rator null");
|
||||
} else { init_rator; };
|
||||
Ast rand =
|
||||
if init_rand == null {
|
||||
error("Application.rand null");
|
||||
} else { init_rand; };
|
||||
|
||||
StringSet vars()
|
||||
{
|
||||
StringSet ratorVars = rator.vars();
|
||||
ratorVars.union(rand.vars());
|
||||
}
|
||||
|
||||
StringSet fv()
|
||||
{
|
||||
StringSet ratorFv = rator.freeVars();
|
||||
// rator.freeVars (public name) was rator.fv (private name).
|
||||
// typechecker caught this (happened below also with rand)
|
||||
ratorFv.union(rand.freeVars());
|
||||
}
|
||||
|
||||
Type getType(Env gamma)
|
||||
{
|
||||
Type ratorType = rator.getType(gamma);
|
||||
ratorType.getRange(rand.getType(gamma));
|
||||
}
|
||||
|
||||
Value getValue(Env rho)
|
||||
{
|
||||
Value ratorVal = rator.getValue(rho);
|
||||
ratorVal.apply(rand.getValue(rho));
|
||||
// ratorVal.apply was rator.apply, which gave method not found error
|
||||
// typechecker caught this.
|
||||
// also, rand.getValue was rand.value. Same error.
|
||||
// typechecker caught this.
|
||||
}
|
||||
|
||||
export Ast : vars, fv as freeVars, getType, getValue;
|
||||
}
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
int main() {
|
||||
[int, int] -> int x = fun(int x, int y) { x + y; };
|
||||
x(3, 4);
|
||||
}
|
||||
|
|
@ -1,23 +0,0 @@
|
|||
type t {
|
||||
void m();
|
||||
}
|
||||
|
||||
class A():t { // no implements necessary
|
||||
t state = null;
|
||||
void m() {
|
||||
state = this; // do we need coercions here?
|
||||
}
|
||||
export t : m;
|
||||
}
|
||||
|
||||
type s <: t { }
|
||||
|
||||
subclass B():s extends A at t {
|
||||
super();
|
||||
// use of m somewhere
|
||||
void m2 { m(); }
|
||||
// .: the type of this is s
|
||||
// .: the assignment of state = this still works
|
||||
// because s is below t
|
||||
export s : m2 as m;
|
||||
}
|
||||
|
|
@ -1,35 +0,0 @@
|
|||
type t {
|
||||
void m();
|
||||
}
|
||||
|
||||
class A():t { // no implements necessary
|
||||
t state = null;
|
||||
void m() {
|
||||
state = (this : t); // do we need coercions here? -- yes!
|
||||
}
|
||||
export t : m;
|
||||
}
|
||||
|
||||
type s <: t { }
|
||||
|
||||
type u {
|
||||
void m();
|
||||
}
|
||||
|
||||
subclass B():s extends A at t implements u {
|
||||
super();
|
||||
// use of m somewhere
|
||||
void m2() {
|
||||
m();
|
||||
}
|
||||
// .: the type of this is s
|
||||
// .: the assignment of state = this still works
|
||||
// because s is below t
|
||||
export s : m;
|
||||
export u : m2 as m;
|
||||
}
|
||||
|
||||
void main() {
|
||||
u x = new B:u();
|
||||
x.m();
|
||||
}
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
type t {
|
||||
int md(int);
|
||||
}
|
||||
|
||||
int main() {
|
||||
t x = null;
|
||||
x.md(3);
|
||||
}
|
||||
|
|
@ -1,15 +0,0 @@
|
|||
type t {
|
||||
int md(int);
|
||||
}
|
||||
|
||||
class c() : t impl t {
|
||||
int my_md(int x) {
|
||||
return this.md(x);
|
||||
}
|
||||
export t : my_md as md;
|
||||
}
|
||||
|
||||
int main() {
|
||||
t x = new c:t();
|
||||
x.md(3);
|
||||
}
|
||||
|
|
@ -1,26 +0,0 @@
|
|||
type t {
|
||||
int x;
|
||||
}
|
||||
|
||||
type t2 <: t {
|
||||
int y;
|
||||
}
|
||||
|
||||
type contains_t {
|
||||
t x(t2);
|
||||
}
|
||||
|
||||
class c() : t2 impl t2 {
|
||||
init int x;
|
||||
init int y;
|
||||
|
||||
export t2 : x, y;
|
||||
}
|
||||
|
||||
class cct() : contains_t impl contains_t {
|
||||
t2 x(t x) {
|
||||
return new c : t2 (x = x.x, y = x.x);
|
||||
}
|
||||
|
||||
export contains_t : x;
|
||||
}
|
||||
|
|
@ -1,31 +0,0 @@
|
|||
/* should parse & type check. */
|
||||
|
||||
type T
|
||||
{
|
||||
int x;
|
||||
int y;
|
||||
int get_x();
|
||||
}
|
||||
|
||||
class BaseCls() : T impl T
|
||||
{
|
||||
init int x;
|
||||
init int y;
|
||||
int get_x() { x; }
|
||||
export T : x, y, get_x;
|
||||
}
|
||||
|
||||
mixin mx() : T at T impl T with int x
|
||||
{
|
||||
init int z;
|
||||
super(x = 3);
|
||||
export T : z as x, y as y, get_x as get_x;
|
||||
}
|
||||
|
||||
subclass DerivedCls = mx(BaseCls);
|
||||
|
||||
int main() {
|
||||
T t = new DerivedCls : T (y = 4, z = 5);
|
||||
|
||||
t.get_x() + t.x + t.y; // should evaluate to 12
|
||||
}
|
||||
|
|
@ -1,98 +0,0 @@
|
|||
/* Again, should parse and type-check. */
|
||||
|
||||
type charList
|
||||
{
|
||||
charList cons(char);
|
||||
bool isEmpty();
|
||||
char car();
|
||||
charList cdr();
|
||||
}
|
||||
|
||||
final class MTCList() : charList impl charList {
|
||||
charList cons(char x) {
|
||||
return new ConsCList : charList (car = x, cdr = (this : charList));
|
||||
}
|
||||
bool isEmpty() { return true; }
|
||||
char car() { error("There are no elements in the empty list!"); }
|
||||
charList cdr() { return (this : charList); }
|
||||
export charList : car, cdr, isEmpty, cons;
|
||||
}
|
||||
|
||||
final class ConsCList() : charList impl charList {
|
||||
init char car;
|
||||
init charList cdr;
|
||||
charList cons(char x) {
|
||||
return new ConsCList : charList (car = x, cdr = (this : charList));
|
||||
}
|
||||
bool isEmpty() { return false; }
|
||||
char car_func() { return car; }
|
||||
charList cdr_func() { return cdr; }
|
||||
export charList : car_func as car, cdr_func as cdr, isEmpty, cons;
|
||||
}
|
||||
|
||||
type stack
|
||||
{
|
||||
char push (char elt);
|
||||
char pop();
|
||||
}
|
||||
|
||||
class listStack() : stack impl stack {
|
||||
charList stack = new MTCList : charList();
|
||||
|
||||
char push (char elt) {
|
||||
stack = stack.cons(elt);
|
||||
return elt;
|
||||
}
|
||||
char pop() {
|
||||
if stack.isEmpty() {
|
||||
error("The stack is empty!");
|
||||
} else {
|
||||
char x = stack.car();
|
||||
stack = stack.cdr();
|
||||
return x;
|
||||
};
|
||||
}
|
||||
|
||||
export stack : push, pop;
|
||||
}
|
||||
|
||||
type countedStack <: stack
|
||||
{
|
||||
int numElements();
|
||||
}
|
||||
|
||||
mixin addCount() : countedStack at stack impl countedStack
|
||||
{
|
||||
int numElts = 0;
|
||||
|
||||
super();
|
||||
|
||||
char countedPush(char elt)
|
||||
{
|
||||
numElts = numElts + 1;
|
||||
push(elt);
|
||||
}
|
||||
|
||||
char countedPop()
|
||||
{
|
||||
char x = pop();
|
||||
numElts = numElts - 1;
|
||||
return x;
|
||||
}
|
||||
|
||||
int getSize()
|
||||
{
|
||||
numElts;
|
||||
}
|
||||
|
||||
export countedStack :
|
||||
countedPush as push,
|
||||
countedPop as pop,
|
||||
getSize as numElements;
|
||||
}
|
||||
|
||||
subclass countedListStack = addCount(listStack);
|
||||
|
||||
char main() {
|
||||
(new countedListStack : stack()).push('5');
|
||||
}
|
||||
|
|
@ -1,56 +0,0 @@
|
|||
/* 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,17 +0,0 @@
|
|||
type t1 {
|
||||
bool x();
|
||||
}
|
||||
|
||||
class c() : t1 impl t1 {
|
||||
bool x() { return true; }
|
||||
export t1 : x;
|
||||
}
|
||||
|
||||
bool main() {
|
||||
t1 x = new c:t1();
|
||||
if (1 < 3) && (2.0 >= 1.5) {
|
||||
!x.x();
|
||||
} else {
|
||||
error("How'd I get here?");
|
||||
};
|
||||
}
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
type t {
|
||||
int x;
|
||||
}
|
||||
|
||||
class c(int x) : t impl t {
|
||||
int y = x;
|
||||
export t : y as x;
|
||||
}
|
||||
|
||||
t main() {
|
||||
new c:t(x = 5);
|
||||
}
|
||||
|
|
@ -1,38 +0,0 @@
|
|||
/* This should parse and type-check correctly.
|
||||
Note the field initialization in unitSquare: the declaration of the
|
||||
field x should shadow the init arg x from that point forward, but
|
||||
of course the RHS of x's declaration should refer to the init arg.
|
||||
*/
|
||||
|
||||
type shape
|
||||
{
|
||||
int x;
|
||||
int y;
|
||||
int area();
|
||||
}
|
||||
|
||||
type square extends shape
|
||||
{
|
||||
int length;
|
||||
}
|
||||
|
||||
class unitSquare() : shape impl shape, square
|
||||
{
|
||||
init int x;
|
||||
init int y;
|
||||
|
||||
int x = x;
|
||||
int y = y;
|
||||
int size = 1;
|
||||
|
||||
int area() { size * size; }
|
||||
|
||||
export shape : x as x,
|
||||
y as y,
|
||||
area as area;
|
||||
|
||||
export square : x as x,
|
||||
y as y,
|
||||
area as area,
|
||||
size as length;
|
||||
}
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
float main() {
|
||||
if ("foo" + "bar" == "foobar") { 1.3 + 5.7; }
|
||||
else { error("Oops!"); }
|
||||
}
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
struct Int() : IInt {
|
||||
init int value;
|
||||
}
|
||||
|
|
@ -1,11 +0,0 @@
|
|||
type t {}
|
||||
|
||||
class c() : t { init int x; export t; }
|
||||
|
||||
mixin mx() : t at t with int x, int y {
|
||||
init int z;
|
||||
super(x = 1, y = 2);
|
||||
export t;
|
||||
}
|
||||
|
||||
subclass c2 = mx(c); // should fail thanks to y = 2 above.
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
type t {}
|
||||
|
||||
final class c() : t { init int x; export t; }
|
||||
|
||||
mixin mx() : t at t with int x { init int z; super(x = 1); export t; }
|
||||
|
||||
subclass c2 = mx(c); // should fail because c is final
|
||||
|
|
@ -1,30 +0,0 @@
|
|||
type t1 {
|
||||
int x;
|
||||
int y;
|
||||
}
|
||||
|
||||
type t2 <: t1 {
|
||||
int add();
|
||||
}
|
||||
|
||||
class c1() : t1 implements t1 {
|
||||
init int x;
|
||||
init int y;
|
||||
|
||||
export t1 : x, y;
|
||||
}
|
||||
|
||||
subclass c2() : t2 extends c1 at t1 implements t2 with int x, int y {
|
||||
init int x;
|
||||
init int y;
|
||||
|
||||
super(x = x, y = y);
|
||||
|
||||
int add() { return x + y; }
|
||||
|
||||
export t2: x, y, add;
|
||||
}
|
||||
|
||||
int main() {
|
||||
new c2:t2(x = 4, y = 6).add();
|
||||
}
|
||||
|
|
@ -1,13 +0,0 @@
|
|||
type t1 {
|
||||
int x();
|
||||
}
|
||||
|
||||
class c() : t1 impl t1 {
|
||||
int x() { return 7; }
|
||||
export t1 : x;
|
||||
}
|
||||
|
||||
int main() {
|
||||
t1 x = new c:t1();
|
||||
-x.x();
|
||||
}
|
||||
|
|
@ -1,15 +0,0 @@
|
|||
(append (map interface? (list MovingPoint<%>
|
||||
Point3D<%>
|
||||
Point<%>
|
||||
ColorPoint<%>
|
||||
Color<%>))
|
||||
(map class? (list ColorC%
|
||||
Point3DC%
|
||||
ColorPointC%
|
||||
ColorMovingPointC%
|
||||
MovingColorPointC%
|
||||
PointC%
|
||||
MovingPointC%))
|
||||
(map mixin? (list makeMobile-mixin
|
||||
addColor-mixin
|
||||
$Point3DC-mixin)))
|
||||
|
|
@ -1,36 +0,0 @@
|
|||
struct PointC(int x, int y) : Point { }
|
||||
struct ColorC(int r, int g, int b) : Color { }
|
||||
|
||||
// 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;
|
||||
}
|
||||
|
||||
class ColorPointC = addColor(PointC);
|
||||
class MovingPointC = makeMobile(PointC);
|
||||
|
||||
// only useable as a MovingPoint
|
||||
class MovingColorPointC = makeMobile(ColorPointC);
|
||||
// only usable as a ColorPoint
|
||||
class ColorMovingPointC = addColor(MovingPointC);
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
(append (map interface? (list Color<%> Posn<%> ColorPosn<%>))
|
||||
(map class? (list PosnC% ColorC% ColorPosnC%))
|
||||
(map mixin? (list $ColorPosnC-mixin)))
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
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(); }
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
(list (interface? T<%>)
|
||||
(class? C%)
|
||||
(equal? (f 'dummy) '(dummy dummy))
|
||||
(= (send (new C%) T<%>-x-get '()) 3)
|
||||
(= (send (new C%) T<%>-y-get '()) 3))
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
<int, int> f(int x) { return (x, x); }
|
||||
|
||||
struct C() : T {
|
||||
int x = 3;
|
||||
int y = { (int x, int y) = f(x); x; };
|
||||
}
|
||||
|
|
@ -1,13 +0,0 @@
|
|||
type t1 {
|
||||
int x;
|
||||
}
|
||||
|
||||
type t2 {
|
||||
string x;
|
||||
int m(int);
|
||||
}
|
||||
|
||||
type t3 <: t1, t2 {
|
||||
int y;
|
||||
int m2(int, int);
|
||||
}
|
||||
|
|
@ -1 +0,0 @@
|
|||
(map interface? (list t1<%> t2<%> t3<%>))
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
type t1 {
|
||||
int x;
|
||||
}
|
||||
|
||||
type t2 {
|
||||
int m(int);
|
||||
}
|
||||
|
||||
type t3 <: t1, t2 {
|
||||
int y;
|
||||
int m2(int, int);
|
||||
}
|
||||
|
|
@ -1,75 +0,0 @@
|
|||
(module format mzscheme
|
||||
|
||||
(require (lib "contract.ss")
|
||||
(lib "list.ss")
|
||||
(lib "class.ss")
|
||||
(lib "plt-match.ss")
|
||||
(only "base.ss" null%)
|
||||
"ast.ss"
|
||||
)
|
||||
|
||||
(provide/contract
|
||||
[honu-value->string (any/c . -> . string?)]
|
||||
[honu-type->string (ast:type? . -> . string?)]
|
||||
)
|
||||
|
||||
(define (string-append-delimited pre mid post strings)
|
||||
(string-append
|
||||
pre
|
||||
(if (null? strings)
|
||||
""
|
||||
(foldl (lambda (str prefix)
|
||||
(string-append prefix mid str))
|
||||
(car strings)
|
||||
(cdr strings)))
|
||||
post))
|
||||
|
||||
(define (honu-value->string value)
|
||||
(cond
|
||||
[(number? value) (format "~a" value)]
|
||||
[(char? value) (format "'~a'" value)]
|
||||
[(string? value) (format "~s" value)]
|
||||
[(boolean? value) (if value "true" "false")]
|
||||
[(procedure? value) "procedure"]
|
||||
[(null? value) "()"]
|
||||
[(list? value) ; Always non-empty
|
||||
(honu-tuple->string value)]
|
||||
[(is-a? value null%) "null"]
|
||||
[(object? value) ; Always non-null
|
||||
(honu-object->string value)]
|
||||
[else (error 'honu-value->string "Unknown value ~s" value)]))
|
||||
|
||||
(define (honu-tuple->string tuple)
|
||||
(string-append-delimited "(" ", " ")" (map honu-value->string tuple)))
|
||||
|
||||
(define (honu-object->string value)
|
||||
(send value format-class-name))
|
||||
|
||||
(define (honu-type->string t)
|
||||
(match t
|
||||
[(struct ast:type:top (_))
|
||||
"(top type / any value)"]
|
||||
[(struct ast:type:bot (_))
|
||||
"(bottom type / no value)"]
|
||||
[(struct ast:type:primitive (_ name))
|
||||
(symbol->string name)]
|
||||
[(struct ast:type:tuple (_ args))
|
||||
(string-append-delimited "tuple(" ", " ")" (map honu-type->string args))]
|
||||
[(struct ast:type:partial/tuple (_ slot type))
|
||||
(format "tuple of size >= ~a where the type in position ~a is ~a"
|
||||
slot slot (honu-type->string type))]
|
||||
[(struct ast:type:function (_ arg ret))
|
||||
(if (ast:type:function? arg)
|
||||
(string-append "(" (honu-type->string arg) ") -> " (honu-type->string ret))
|
||||
(string-append (honu-type->string arg) " -> " (honu-type->string ret)))]
|
||||
[(struct ast:type:method (_ disp arg ret))
|
||||
(string-append "[" (honu-type->string disp) "] "
|
||||
(honu-type->string arg) " -> " (honu-type->string ret))]
|
||||
[(struct ast:type:object:iface (_ name))
|
||||
(symbol->string (syntax-e name))]
|
||||
[(struct ast:type:object:any (_))
|
||||
"Any"]
|
||||
[(struct ast:type:object:null (_))
|
||||
"null"]))
|
||||
|
||||
)
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
(module honu-context (lib "base.ss" "honu")
|
||||
|
||||
(provide honu-compile-context)
|
||||
(define honu-compile-context #'here))
|
||||
|
|
@ -1,20 +0,0 @@
|
|||
(module honu-tests mzscheme
|
||||
|
||||
(require (lib "contract.ss")
|
||||
(planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
|
||||
"private/tests/typechecker-tests.ss"
|
||||
"private/tests/program-tests.ss"
|
||||
)
|
||||
|
||||
(provide/contract [honu-tests test-suite?])
|
||||
|
||||
;; honu-tests : TestSuite
|
||||
;; Honu Test Suite
|
||||
(define honu-tests
|
||||
(make-test-suite
|
||||
"Honu"
|
||||
program-tests
|
||||
typechecker-tests
|
||||
))
|
||||
|
||||
)
|
||||
Binary file not shown.
|
Before Width: | Height: | Size: 821 B |
|
|
@ -1,5 +0,0 @@
|
|||
(module info (lib "infotab.ss" "setup")
|
||||
(define name "Honu")
|
||||
(define doc.txt "doc.txt")
|
||||
(define tools (list (list "tool.ss")))
|
||||
(define tool-icons '(("honu.png" "honu"))))
|
||||
|
|
@ -1,11 +0,0 @@
|
|||
(module parameters mzscheme
|
||||
|
||||
(provide (all-defined))
|
||||
|
||||
(define current-compile-context (make-parameter #f))
|
||||
|
||||
;; tenv and lenv, respectively
|
||||
(define current-type-environment (make-parameter #f))
|
||||
(define current-lexical-environment (make-parameter #f))
|
||||
|
||||
)
|
||||
|
|
@ -1,276 +0,0 @@
|
|||
(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 (string->symbol lexeme) 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)]))
|
||||
|
||||
)
|
||||
|
|
@ -1,673 +0,0 @@
|
|||
(module parse mzscheme
|
||||
|
||||
(require (lib "yacc.ss" "parser-tools")
|
||||
"lex.ss"
|
||||
"../readerr.ss"
|
||||
"../ast.ss"
|
||||
"../private/tools/general.ss"
|
||||
"../private/typechecker/type-utils.ss")
|
||||
|
||||
(define (generate-honu-parser source-name)
|
||||
(define honu-parser
|
||||
(parser
|
||||
(start <program> <interact>)
|
||||
(end EOF)
|
||||
(src-pos)
|
||||
;; (debug "honu.debug")
|
||||
;; (yacc-output "honu.yacc")
|
||||
;; Since we have things that can look like x.y.z.w(...), we need to
|
||||
;; actually specify a precedence for DOT. There are 3 shift/reduce
|
||||
;; conflicts for it, so if that warning is seen, it can be safely
|
||||
;; ignored. I don't want to turn off the warnings yet in case this
|
||||
;; number increases, which means that I've added additional
|
||||
;; conflicts.
|
||||
(precs (right ARROW) ;; for types
|
||||
|
||||
(nonassoc return)
|
||||
(left else) ;; for expressions
|
||||
(left BINDS)
|
||||
(left OR)
|
||||
(left AND)
|
||||
(left NEQ EQUALS)
|
||||
(nonassoc CLS_EQ)
|
||||
(nonassoc LT LE GT GE)
|
||||
(left PLUS MINUS)
|
||||
(left TIMES DIV MOD)
|
||||
(nonassoc NOT UMINUS) ;; unary operators
|
||||
(right COLON isa)
|
||||
(nonassoc selector)
|
||||
(left O_PAREN) ;; this gives application a precedence
|
||||
(left DOT))
|
||||
(tokens keywords separators operators val-tokens lex-errors EOF for-prec)
|
||||
(error (lambda (a b stx start end)
|
||||
(raise-read-error-with-stx
|
||||
(format "parse error near ~a" (syntax-e stx))
|
||||
stx)))
|
||||
(grammar
|
||||
(<program>
|
||||
[(<defns>)
|
||||
$1])
|
||||
(<defns>
|
||||
[(<defn> <defns>)
|
||||
(if (ast? $1)
|
||||
(cons $1 $2)
|
||||
(append $1 $2))]
|
||||
[()
|
||||
(list)])
|
||||
(<defn>
|
||||
[(<function-defn>)
|
||||
$1]
|
||||
[(<iface-defn>)
|
||||
$1]
|
||||
[(<class-defn>)
|
||||
$1]
|
||||
[(<struct-defn>)
|
||||
$1]
|
||||
[(<mixin-defn>)
|
||||
$1]
|
||||
[(<binding-defn>)
|
||||
$1])
|
||||
|
||||
(<binding-defn>
|
||||
[(<bind> BINDS <expr> SEMI_COLON)
|
||||
(make-ast:defn:binding
|
||||
(create-src-stx 'ast:defn:binding source-name $1-start-pos $4-end-pos)
|
||||
(list (ast:formal-name $1)) (list (ast:formal-type $1)) $3)]
|
||||
[(O_PAREN <binds-cd> C_PAREN BINDS <expr> SEMI_COLON)
|
||||
(let-values ([(names types) (map-two-values (lambda (f)
|
||||
(values (ast:formal-name f)
|
||||
(ast:formal-type f)))
|
||||
$2)])
|
||||
(make-ast:defn:binding
|
||||
(create-src-stx 'ast:defn:binding source-name $1-start-pos $6-end-pos)
|
||||
names types $5))])
|
||||
(<binds-cd>
|
||||
[(<bind> COMMA <binds-cd>)
|
||||
(cons $1 $3)]
|
||||
[(<bind>)
|
||||
(list $1)])
|
||||
(<bind>
|
||||
[(<any-type> id)
|
||||
(make-ast:formal
|
||||
(create-src-stx 'ast:formal source-name $1-start-pos $2-end-pos)
|
||||
$2 $1)]
|
||||
[(USCORE)
|
||||
(make-ast:formal
|
||||
(create-src-stx 'ast:formal source-name $1-start-pos $1-end-pos)
|
||||
#f (make-top-type $1))])
|
||||
|
||||
(<function-defn>
|
||||
[(<any-type> id O_PAREN <args> C_PAREN <block>)
|
||||
(make-ast:defn:function
|
||||
(create-src-stx 'ast:defn:function source-name $1-start-pos $6-end-pos)
|
||||
$2 $1 $4 $6)])
|
||||
|
||||
;; Type definitions and needed parts
|
||||
|
||||
(<iface-defn>
|
||||
[(<iface-tag> id <ext-clause> O_CURLY <fmdecs> C_CURLY)
|
||||
(make-ast:defn:iface
|
||||
(create-src-stx 'ast:defn:iface source-name $1-start-pos $6-end-pos)
|
||||
$2 $3 $5)])
|
||||
(<iface-tag>
|
||||
[(type) (void)]
|
||||
[(interface) (void)])
|
||||
(<type-id>
|
||||
[(id)
|
||||
(make-iface-type $1 $1)]
|
||||
[(Any)
|
||||
(make-any-type $1)])
|
||||
(<any-type>
|
||||
[(<type-id>)
|
||||
$1]
|
||||
[(void)
|
||||
(make-void-type $1)]
|
||||
[(int)
|
||||
(make-int-type $1)]
|
||||
[(bool)
|
||||
(make-bool-type $1)]
|
||||
[(float)
|
||||
(make-float-type $1)]
|
||||
[(char)
|
||||
(make-char-type $1)]
|
||||
[(string)
|
||||
(make-string-type $1)]
|
||||
[(<tup-type>)
|
||||
$1]
|
||||
[(<any-type> ARROW <any-type>)
|
||||
(make-func-type
|
||||
(create-src-stx 'honu:func-type source-name $1-start-pos $3-end-pos)
|
||||
$1 $3)])
|
||||
(<tup-type>
|
||||
[(LT GT)
|
||||
(make-tuple-type
|
||||
(create-src-stx 'ast:type:tuple source-name $1-start-pos $2-end-pos)
|
||||
(list))]
|
||||
[(LT <any-type+> GT)
|
||||
(if (null? (cdr $2))
|
||||
(car $2)
|
||||
(make-tuple-type
|
||||
(create-src-stx 'ast:type:tuple source-name $1-start-pos $3-end-pos)
|
||||
$2))])
|
||||
(<any-type+>
|
||||
[(<any-type>)
|
||||
(list $1)]
|
||||
[(<any-type> COMMA <any-type+>)
|
||||
(cons $1 $3)])
|
||||
(<ext-clause>
|
||||
[(extends <type-ids+>)
|
||||
$2]
|
||||
[(SUBTYPE <type-ids+>)
|
||||
$2]
|
||||
[()
|
||||
'()])
|
||||
(<type-ids+>
|
||||
[(<type-id> COMMA <type-ids+>)
|
||||
(cons $1 $3)]
|
||||
[(<type-id>)
|
||||
(list $1)])
|
||||
(<args>
|
||||
[(<args-cd>)
|
||||
$1]
|
||||
[()
|
||||
(list)])
|
||||
(<args-cd>
|
||||
[(<arg> COMMA <args-cd>)
|
||||
(cons $1 $3)]
|
||||
[(<arg>)
|
||||
(list $1)])
|
||||
(<arg>
|
||||
[(<any-type> id)
|
||||
(make-ast:formal
|
||||
(create-src-stx 'ast:formal source-name $1-start-pos $2-end-pos)
|
||||
$2 $1)])
|
||||
(<fmdecs>
|
||||
[(<fdec> <fmdecs>)
|
||||
(cons $1 $2)]
|
||||
[(<mdec> <fmdecs>)
|
||||
(cons $1 $2)]
|
||||
[()
|
||||
(list)])
|
||||
(<fdec>
|
||||
[(<any-type> id SEMI_COLON)
|
||||
(make-ast:iface/member:field
|
||||
(create-src-stx 'ast:iface/member:field source-name $1-start-pos $3-end-pos)
|
||||
$2 $1)])
|
||||
(<mdec>
|
||||
[(<any-type> id O_PAREN <mdec-args> C_PAREN SEMI_COLON)
|
||||
(make-ast:iface/member:method
|
||||
(create-src-stx 'ast:iface/member:method source-name $1-start-pos $6-end-pos)
|
||||
$2 $1 $4)])
|
||||
(<mdec-args>
|
||||
[(<mdec-args-cd>)
|
||||
$1]
|
||||
[()
|
||||
(list)])
|
||||
(<mdec-args-cd>
|
||||
[(<mdec-arg> COMMA <mdec-args-cd>)
|
||||
(cons $1 $3)]
|
||||
[(<mdec-arg>)
|
||||
(list $1)])
|
||||
(<mdec-arg>
|
||||
[(<any-type>)
|
||||
$1]
|
||||
[(<any-type> id)
|
||||
$1])
|
||||
|
||||
(<struct-defn>
|
||||
[(struct id <init-slots> COLON <type-id> <imp-clause> O_CURLY <fmidefns> <exports> C_CURLY)
|
||||
(make-ast:defn:structure
|
||||
(create-src-stx 'ast:defn:structure source-name $1-start-pos $10-end-pos)
|
||||
$2 $5 #f $6 $3 $8 $9)]
|
||||
[(final struct id <init-slots> COLON <type-id> <imp-clause> O_CURLY <fmidefns> <exports> C_CURLY)
|
||||
(make-ast:defn:structure
|
||||
(create-src-stx 'ast:defn:structure source-name $1-start-pos $11-end-pos)
|
||||
$3 $6 #t $7 $4 $9 $10)]
|
||||
[(struct id <init-slots> COLON <type-id> extends id <init-slots> COLON <type-id> <imp-clause>
|
||||
O_CURLY <fmidefns> <supernew> <fmidefns> <exports> C_CURLY)
|
||||
(make-ast:defn:substructure
|
||||
(create-src-stx 'ast:defn:substructure source-name $1-start-pos $17-end-pos)
|
||||
$2 $5 $7 $10 #f $11 $3 $8 $14 $13 $15 $16)]
|
||||
[(final struct id <init-slots> COLON <type-id> extends id <init-slots> COLON <type-id> <imp-clause>
|
||||
O_CURLY <fmidefns> <supernew> <fmidefns> <exports> C_CURLY)
|
||||
(make-ast:defn:substructure
|
||||
(create-src-stx 'ast:defn:substructure source-name $1-start-pos $18-end-pos)
|
||||
$3 $6 $8 $11 #t $12 $4 $9 $15 $14 $16 $17)])
|
||||
|
||||
;; Class and subclass definitions and needed parts
|
||||
|
||||
(<class-defn>
|
||||
[(class id <init-slots> COLON <type-id> <imp-clause> O_CURLY <fmidefns> <exports> C_CURLY)
|
||||
(make-ast:defn:class
|
||||
(create-src-stx 'ast:defn:class source-name $1-start-pos $10-end-pos)
|
||||
$2 $5 #f $6 $3 $8 $9)]
|
||||
[(final class id <init-slots> COLON <type-id> <imp-clause> O_CURLY <fmidefns> <exports> C_CURLY)
|
||||
(make-ast:defn:class
|
||||
(create-src-stx 'ast:defn:class source-name $1-start-pos $11-end-pos)
|
||||
$3 $6 #t $7 $3 $9 $10)]
|
||||
[(class id BINDS id O_PAREN id C_PAREN SEMI_COLON)
|
||||
(make-ast:defn:subclass
|
||||
(create-src-stx 'ast:defn:subclass source-name $1-start-pos $8-end-pos)
|
||||
$2 $6 $4)]
|
||||
[(class id <init-slots> COLON <type-id> extends id <init-slots> COLON <type-id> <imp-clause>
|
||||
O_CURLY <fmidefns> <supernew> <fmidefns> <exports> C_CURLY)
|
||||
(let ([mixin-name (datum->syntax-object $2 (string->symbol (string-append "$" (symbol->string (syntax-e $2)))) $2)]
|
||||
[subclass-stx (create-src-stx 'ast:defn:subclass source-name $1-start-pos $17-end-pos)])
|
||||
(list (make-ast:defn:mixin subclass-stx mixin-name $5 $10 #f $11 $3 $8 $14 $13 $15 $16)
|
||||
(make-ast:defn:subclass subclass-stx $2 $7 mixin-name)))]
|
||||
[(final class id <init-slots> COLON <type-id> extends id <init-slots> COLON <type-id> <imp-clause>
|
||||
O_CURLY <fmidefns> <supernew> <fmidefns> <exports> C_CURLY)
|
||||
(let ([mixin-name (datum->syntax-object $3 (string->symbol (string-append "$" (symbol->string (syntax-e $3)))))]
|
||||
[subclass-stx (create-src-stx 'ast:defn:subclass source-name $1-start-pos $18-end-pos)])
|
||||
(list (make-ast:defn:mixin subclass-stx mixin-name $6 $10 #t $12 $4 $9 $15 $14 $16 $17)
|
||||
(make-ast:defn:subclass subclass-stx $3 $8 mixin-name)))])
|
||||
|
||||
(<imp-clause>
|
||||
[(impl <type-ids+>)
|
||||
$2]
|
||||
[(implements <type-ids+>)
|
||||
$2]
|
||||
[()
|
||||
'()])
|
||||
(<init-slots>
|
||||
[(O_PAREN <args> C_PAREN)
|
||||
$2])
|
||||
(<at-clause>
|
||||
[(at <type-id>)
|
||||
$2]
|
||||
[(AT <type-id>)
|
||||
$2])
|
||||
(<fmidefns>
|
||||
[(<fdefn> <fmidefns>)
|
||||
(cons $1 $2)]
|
||||
[(<mdefn> <fmidefns>)
|
||||
(cons $1 $2)]
|
||||
[(<initdefn> <fmidefns>)
|
||||
(cons $1 $2)]
|
||||
[()
|
||||
(list)])
|
||||
(<fdefn>
|
||||
[(<any-type> id BINDS <expr> SEMI_COLON)
|
||||
(make-ast:class/member:field
|
||||
(create-src-stx 'ast:class/member:field source-name $1-start-pos $5-end-pos)
|
||||
$2 $1 $4)])
|
||||
(<mdefn>
|
||||
[(<any-type> id O_PAREN <args> C_PAREN <block>)
|
||||
(make-ast:class/member:method
|
||||
(create-src-stx 'ast:class/member:method source-name $1-start-pos $6-end-pos)
|
||||
$2 $1 $4 $6)])
|
||||
(<initdefn>
|
||||
[(init <any-type> id SEMI_COLON)
|
||||
(make-ast:class/member:field/formal
|
||||
(create-src-stx 'ast:class/member:field/formal source-name $1-start-pos $4-end-pos)
|
||||
$3 $2 #f)]
|
||||
[(init <any-type> id BINDS <expr> SEMI_COLON)
|
||||
(make-ast:class/member:field/formal
|
||||
(create-src-stx 'ast:class/member:field/formal source-name $1-start-pos $4-end-pos)
|
||||
$3 $2 $5)])
|
||||
(<exports>
|
||||
[(<expdefn> <exports>)
|
||||
(cons $1 $2)]
|
||||
[()
|
||||
(list)])
|
||||
(<expdefn>
|
||||
[(export <type-id> COLON <expdecs> SEMI_COLON)
|
||||
(make-ast:export
|
||||
(create-src-stx 'ast:export source-name $1-start-pos $5-end-pos)
|
||||
$2 $4)]
|
||||
[(export <type-id> SEMI_COLON)
|
||||
(make-ast:export
|
||||
(create-src-stx 'ast:export source-name $1-start-pos $3-end-pos)
|
||||
$2 (list))])
|
||||
(<expdecs>
|
||||
[(<expdec> COMMA <expdecs>)
|
||||
(cons $1 $3)]
|
||||
[(<expdec>)
|
||||
(list $1)])
|
||||
(<expdec>
|
||||
[(id as id)
|
||||
(make-ast:export/member
|
||||
(create-src-stx 'ast:export/member source-name $1-start-pos $3-end-pos)
|
||||
$1 $3)]
|
||||
[(id)
|
||||
(make-ast:export/member
|
||||
(create-src-stx 'ast:export/member source-name $1-start-pos $1-end-pos)
|
||||
$1 $1)])
|
||||
|
||||
;; Mixin definitions
|
||||
|
||||
(<mixin-defn>
|
||||
[(mixin id <init-slots> COLON <type-id> <init-slots> ARROW <type-id> <imp-clause>
|
||||
O_CURLY <fmidefns> <supernew> <fmidefns> <exports> C_CURLY)
|
||||
(make-ast:defn:mixin
|
||||
(create-src-stx 'ast:defn:mixin source-name $1-start-pos $15-end-pos)
|
||||
$2 $8 $5 #f $9 $3 $6 $12 $11 $13 $14)]
|
||||
[(final mixin id <init-slots> COLON <type-id> <init-slots> ARROW <type-id> <imp-clause>
|
||||
O_CURLY <fmidefns> <supernew> <fmidefns> <exports> C_CURLY)
|
||||
(make-ast:defn:mixin
|
||||
(create-src-stx 'ast:defn:mixin source-name $1-start-pos $16-end-pos)
|
||||
$3 $9 $6 #t $10 $4 $7 $13 $12 $14 $15)])
|
||||
(<with-clause>
|
||||
[(with <args-cd>)
|
||||
$2]
|
||||
[()
|
||||
(list)])
|
||||
(<supernew>
|
||||
[(super O_PAREN <newargs> C_PAREN SEMI_COLON)
|
||||
(make-ast:super-new
|
||||
(create-src-stx 'ast:super-new source-name $1-start-pos $4-end-pos)
|
||||
$3)])
|
||||
(<newargs>
|
||||
[(<newargs-cd>)
|
||||
$1]
|
||||
[()
|
||||
(list)])
|
||||
(<newargs-cd>
|
||||
[(<newarg> COMMA <newargs-cd>)
|
||||
(cons $1 $3)]
|
||||
[(<newarg>)
|
||||
(list $1)])
|
||||
(<newarg>
|
||||
[(id BINDS <expr>)
|
||||
(make-ast:named/arg
|
||||
(create-src-stx 'ast:named/arg source-name $1-start-pos $3-end-pos)
|
||||
$1 $3)])
|
||||
|
||||
;; Expressions
|
||||
|
||||
(<block>
|
||||
[(O_CURLY <block-stmts*> C_CURLY)
|
||||
(if $2
|
||||
$2
|
||||
(raise-read-error-with-stx
|
||||
"Blocks must have at least one expression"
|
||||
(create-src-stx 'honu:block source-name $1-start-pos $3-end-pos)))])
|
||||
(<block-stmts*>
|
||||
[(<expr> SEMI_COLON <block-stmts*>)
|
||||
(if $3
|
||||
(make-ast:expr:sequence
|
||||
(create-src-stx 'ast:expr:sequence source-name $1-start-pos $3-end-pos)
|
||||
(list $1) $3)
|
||||
$1)]
|
||||
[(<binding> <block-stmts*>)
|
||||
(if $2
|
||||
(make-ast:expr:let
|
||||
(create-src-stx 'ast:expr:let source-name $1-start-pos $2-end-pos)
|
||||
(list $1) $2)
|
||||
(raise-read-error-with-stx
|
||||
"Block must end with an expression"
|
||||
(create-src-stx 'honu:block source-name $1-start-pos $1-end-pos)))]
|
||||
[()
|
||||
#f])
|
||||
(<expr>
|
||||
;; unary operators
|
||||
[(selector <expr>)
|
||||
(make-ast:expr:tuple/select
|
||||
(create-src-stx 'ast:expr:tuple/select source-name $1-start-pos $2-end-pos)
|
||||
(syntax-e $1) $2)]
|
||||
[(MINUS <expr>)
|
||||
(prec UMINUS)
|
||||
(make-ast:expr:unary/op
|
||||
(create-src-stx 'ast:expr:unary/op source-name $1-start-pos $2-end-pos)
|
||||
'minus $1 #f $2)]
|
||||
[(NOT <expr>)
|
||||
(make-ast:expr:unary/op
|
||||
(create-src-stx 'ast:expr:unary/op source-name $1-start-pos $2-end-pos)
|
||||
'not $1 #f $2)]
|
||||
;; binary operators
|
||||
[(<expr> OR <expr>)
|
||||
(make-ast:expr:binary/op
|
||||
(create-src-stx 'ast:expr:binary/op source-name $1-start-pos $3-end-pos)
|
||||
'or $2 #f $1 $3)]
|
||||
[(<expr> AND <expr>)
|
||||
(make-ast:expr:binary/op
|
||||
(create-src-stx 'ast:expr:binary/op source-name $1-start-pos $3-end-pos)
|
||||
'and $2 #f $1 $3)]
|
||||
[(<expr> CLS_EQ <expr>)
|
||||
(make-ast:expr:binary/op
|
||||
(create-src-stx 'ast:expr:binary/op source-name $1-start-pos $3-end-pos)
|
||||
'clseq $2 #f $1 $3)]
|
||||
[(<expr> NEQ <expr>)
|
||||
(make-ast:expr:binary/op
|
||||
(create-src-stx 'ast:expr:binary/op source-name $1-start-pos $3-end-pos)
|
||||
'neq $2 #f $1 $3)]
|
||||
[(<expr> EQUALS <expr>)
|
||||
(make-ast:expr:binary/op
|
||||
(create-src-stx 'ast:expr:binary/op source-name $1-start-pos $3-end-pos)
|
||||
'equal $2 #f $1 $3)]
|
||||
[(<expr> LT <expr>)
|
||||
(make-ast:expr:binary/op
|
||||
(create-src-stx 'ast:expr:binary/op source-name $1-start-pos $3-end-pos)
|
||||
'lt $2 #f $1 $3)]
|
||||
[(<expr> LE <expr>)
|
||||
(make-ast:expr:binary/op
|
||||
(create-src-stx 'ast:expr:binary/op source-name $1-start-pos $3-end-pos)
|
||||
'le $2 #f $1 $3)]
|
||||
[(<expr> GT <expr>)
|
||||
(make-ast:expr:binary/op
|
||||
(create-src-stx 'ast:expr:binary/op source-name $1-start-pos $3-end-pos)
|
||||
'gt $2 #f $1 $3)]
|
||||
[(<expr> GE <expr>)
|
||||
(make-ast:expr:binary/op
|
||||
(create-src-stx 'ast:expr:binary/op source-name $1-start-pos $3-end-pos)
|
||||
'ge $2 #f $1 $3)]
|
||||
[(<expr> PLUS <expr>)
|
||||
(make-ast:expr:binary/op
|
||||
(create-src-stx 'ast:expr:binary/op source-name $1-start-pos $3-end-pos)
|
||||
'plus $2 #f $1 $3)]
|
||||
[(<expr> MINUS <expr>)
|
||||
(make-ast:expr:binary/op
|
||||
(create-src-stx 'ast:expr:binary/op source-name $1-start-pos $3-end-pos)
|
||||
'minus $2 #f $1 $3)]
|
||||
[(<expr> TIMES <expr>)
|
||||
(make-ast:expr:binary/op
|
||||
(create-src-stx 'ast:expr:binary/op source-name $1-start-pos $3-end-pos)
|
||||
'times $2 #f $1 $3)]
|
||||
[(<expr> DIV <expr>)
|
||||
(make-ast:expr:binary/op
|
||||
(create-src-stx 'ast:expr:binary/op source-name $1-start-pos $3-end-pos)
|
||||
'div $2 #f $1 $3)]
|
||||
[(<expr> MOD <expr>)
|
||||
(make-ast:expr:binary/op
|
||||
(create-src-stx 'ast:expr:binary/op source-name $1-start-pos $3-end-pos)
|
||||
'mod $2 #f $1 $3)]
|
||||
;; member access
|
||||
[(<expr> DOT id)
|
||||
(make-ast:expr:member
|
||||
(create-src-stx 'honu-member source-name $1-start-pos $3-end-pos)
|
||||
$1 #f $3 #f)]
|
||||
[(my DOT id)
|
||||
(make-ast:expr:member
|
||||
(create-src-stx 'ast:expr:member source-name $1-start-pos $3-end-pos)
|
||||
'my #f $3 #f)]
|
||||
[(<any-type> fun O_PAREN <args> C_PAREN <block>)
|
||||
(make-ast:expr:function
|
||||
(create-src-stx 'ast:expr:function source-name $1-start-pos $6-end-pos)
|
||||
$1 $4 $6)]
|
||||
[(<literal>)
|
||||
$1]
|
||||
[(this)
|
||||
(make-ast:expr:self $1)]
|
||||
[(id)
|
||||
(make-ast:expr:var $1 $1)]
|
||||
[(<expr> BINDS <expr>)
|
||||
(make-ast:expr:assign
|
||||
(create-src-stx 'ast:expr:assign source-name $1-start-pos $3-end-pos)
|
||||
$1 $3)]
|
||||
;; application
|
||||
[(<expr> <tuple>)
|
||||
(make-ast:expr:apply
|
||||
(create-src-stx 'ast:expr:apply source-name $1-start-pos $2-end-pos)
|
||||
$1 $2)]
|
||||
[(new id COLON <type-id> O_PAREN <newargs> C_PAREN)
|
||||
(make-ast:expr:new
|
||||
(create-src-stx 'ast:expr:new source-name $1-start-pos $7-end-pos)
|
||||
$2 $4 $6)]
|
||||
[(new id O_PAREN <newargs> C_PAREN)
|
||||
(make-ast:expr:new
|
||||
(create-src-stx 'ast:expr:new source-name $1-start-pos $5-end-pos)
|
||||
$2 #f $4)]
|
||||
[(<expr> COLON <type-id>)
|
||||
(make-ast:expr:cast
|
||||
(create-src-stx 'ast:expr:cast source-name $1-start-pos $3-end-pos)
|
||||
$1 $3)]
|
||||
[(<expr> isa <type-id>)
|
||||
(make-ast:expr:isa
|
||||
(create-src-stx 'ast:expr:isa source-name $1-start-pos $3-end-pos)
|
||||
$1 $3)]
|
||||
[(if <expr> <block>)
|
||||
(make-ast:expr:if
|
||||
(create-src-stx 'ast:expr:if source-name $1-start-pos $3-end-pos)
|
||||
$2 $3 #f)]
|
||||
[(if <expr> <block> else <block>)
|
||||
(make-ast:expr:if
|
||||
(create-src-stx 'ast:expr:if source-name $1-start-pos $5-end-pos)
|
||||
$2 $3 $5)]
|
||||
[(cond O_CURLY <cond-clauses> C_CURLY)
|
||||
(make-ast:expr:cond
|
||||
(create-src-stx 'ast:expr:cond source-name $1-start-pos $4-end-pos)
|
||||
(car $3) (cadr $3))]
|
||||
[(while <expr> <block>)
|
||||
(make-ast:expr:while
|
||||
(create-src-stx 'ast:expr:while source-name $1-start-pos $3-end-pos)
|
||||
$2 $3)]
|
||||
[(<tuple>)
|
||||
$1]
|
||||
[(return <expr>)
|
||||
(make-ast:expr:return
|
||||
(create-src-stx 'ast:expr:return source-name $1-start-pos $2-end-pos)
|
||||
$2)]
|
||||
[(<block>)
|
||||
$1])
|
||||
(<tuple>
|
||||
[(O_PAREN C_PAREN)
|
||||
(make-ast:expr:tuple
|
||||
(create-src-stx 'ast:expr:tuple source-name $1-start-pos $2-end-pos)
|
||||
(list))]
|
||||
[(O_PAREN <exprs-cd> C_PAREN)
|
||||
(if (null? (cdr $2))
|
||||
(car $2)
|
||||
(make-ast:expr:tuple
|
||||
(create-src-stx 'ast:expr:tuple source-name $1-start-pos $3-end-pos)
|
||||
$2))])
|
||||
(<literal>
|
||||
[(true)
|
||||
(make-ast:expr:literal $1 (make-bool-type $1) $1)]
|
||||
[(false)
|
||||
(make-ast:expr:literal $1 (make-bool-type $1) $1)]
|
||||
[(integer)
|
||||
(make-ast:expr:literal $1 (make-int-type $1) $1)]
|
||||
[(floatnum)
|
||||
(make-ast:expr:literal $1 (make-float-type $1) $1)]
|
||||
[(character)
|
||||
(make-ast:expr:literal $1 (make-char-type $1) $1)]
|
||||
[(string-lit)
|
||||
(make-ast:expr:literal $1 (make-string-type $1) $1)]
|
||||
[(null)
|
||||
(make-ast:expr:literal $1 (make-null-type $1) (datum->syntax-object $1 'null-obj $1))])
|
||||
(<cond-clauses>
|
||||
[(<expr> THICK_ARROW <expr> SEMI_COLON <cond-clauses>)
|
||||
(list (cons (make-ast:cond/clause
|
||||
(create-src-stx 'ast:cond/clause source-name $1-start-pos $4-end-pos)
|
||||
$1 $3)
|
||||
(car $5))
|
||||
(cadr $5))]
|
||||
[(<expr> THICK_ARROW <expr> SEMI_COLON)
|
||||
(list (list (make-ast:cond/clause
|
||||
(create-src-stx 'ast:cond/clause source-name $1-start-pos $4-end-pos)
|
||||
$1 $3))
|
||||
#f)]
|
||||
[(else <expr> SEMI_COLON)
|
||||
(list '() $2)])
|
||||
(<exprs-cd>
|
||||
[(<expr> COMMA <exprs-cd>)
|
||||
(cons $1 $3)]
|
||||
[(<expr>)
|
||||
(list $1)])
|
||||
(<binding>
|
||||
[(<bind> BINDS <expr> SEMI_COLON)
|
||||
(make-ast:defn:binding
|
||||
(create-src-stx 'ast:defn:binding source-name $1-start-pos $4-end-pos)
|
||||
(list (ast:formal-name $1)) (list (ast:formal-type $1)) $3)]
|
||||
[(O_PAREN <binds-cd> C_PAREN BINDS <expr> SEMI_COLON)
|
||||
(let-values ([(names types) (map-two-values (lambda (f)
|
||||
(values (ast:formal-name f)
|
||||
(ast:formal-type f)))
|
||||
$2)])
|
||||
(make-ast:defn:binding
|
||||
(create-src-stx 'ast:defn:binding source-name $1-start-pos $6-end-pos)
|
||||
names types $5))])
|
||||
(<interact>
|
||||
[(<binding-defn>)
|
||||
$1]
|
||||
[(<expr>)
|
||||
$1]))))
|
||||
honu-parser)
|
||||
|
||||
(define (parse-interaction port file)
|
||||
(let ([lexer (generate-honu-lexer file)]
|
||||
[parser (cadr (generate-honu-parser file))])
|
||||
(port-count-lines! port)
|
||||
(parser
|
||||
(lambda ()
|
||||
(lexer port)))))
|
||||
|
||||
(define (parse-port port file)
|
||||
(let ([lexer (generate-honu-lexer file)]
|
||||
[parser (car (generate-honu-parser file))])
|
||||
(port-count-lines! port)
|
||||
(parser
|
||||
(lambda ()
|
||||
(lexer port)))))
|
||||
|
||||
(define (parse-file file)
|
||||
(with-input-from-file file
|
||||
(lambda ()
|
||||
(parse-port (current-input-port)
|
||||
(simplify-path (path->complete-path file))))))
|
||||
|
||||
(define (parse-stdin)
|
||||
(parse-port (current-input-port) #f))
|
||||
|
||||
(define (parse-string string)
|
||||
(parse-port (open-input-string string) #f))
|
||||
|
||||
(define (read-cm port)
|
||||
(let loop ((filenames '())
|
||||
(val (read port)))
|
||||
(if (eof-object? val)
|
||||
(reverse filenames)
|
||||
(loop (cons (string-append val ".honu") filenames)
|
||||
(read port)))))
|
||||
|
||||
(define (parse-group port name)
|
||||
(let ([filenames (read-cm port)])
|
||||
(if (null? filenames)
|
||||
(list)
|
||||
(let loop ((filenames filenames)
|
||||
(defns '()))
|
||||
(let ((parsed (parse-file
|
||||
(simplify-path
|
||||
(path->complete-path (car filenames))))))
|
||||
(if (null? (cdr filenames))
|
||||
(append parsed defns)
|
||||
(loop (cdr filenames)
|
||||
(append parsed defns))))))))
|
||||
|
||||
(define (parse-group-file dirname filename)
|
||||
(let ([filenames (call-with-input-file
|
||||
(string-append dirname "/" filename)
|
||||
read-cm)])
|
||||
(if (null? filenames)
|
||||
(list)
|
||||
(let loop ((filenames filenames)
|
||||
(defns '()))
|
||||
(let ((parsed (parse-file (string-append dirname "/"
|
||||
(car filenames)))))
|
||||
(if (null? (cdr filenames))
|
||||
(append parsed defns)
|
||||
(loop (cdr filenames)
|
||||
(append parsed defns))))))))
|
||||
|
||||
(provide parse-file parse-port parse-stdin parse-string parse-group parse-group-file parse-interaction)
|
||||
)
|
||||
|
|
@ -1,818 +0,0 @@
|
|||
(module post-parsing mzscheme
|
||||
|
||||
(require (lib "list.ss" "srfi" "1")
|
||||
(lib "plt-match.ss")
|
||||
(lib "struct.ss")
|
||||
"../ast.ss"
|
||||
"../parameters.ss"
|
||||
"../readerr.ss"
|
||||
"../tenv.ss"
|
||||
"../private/tools/general.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.
|
||||
|
||||
;;;; add-defns-to-tenv (from tenv-utils.ss) must be run before
|
||||
;;;; post-parse-program. This means that ast:defn:structure and
|
||||
;;;; ast:defn:substructure structures will not appear in the defns,
|
||||
;;;; and so we no longer need to cover them.
|
||||
|
||||
(provide post-parse-program post-parse-interaction)
|
||||
(define (post-parse-program defns)
|
||||
(convert-slots (convert-static (check-this (simplify-ast defns)))))
|
||||
|
||||
(define (post-parse-interaction ast)
|
||||
(cond
|
||||
[(ast:expr? ast)
|
||||
(convert-static-expression (check-this-expression (simplify-expression ast) #f) '())]
|
||||
[(ast:defn:binding? ast)
|
||||
(convert-static-defn (check-this-defn (simplify-defn ast)))]))
|
||||
|
||||
;
|
||||
;
|
||||
; @
|
||||
; @ @ @
|
||||
; $@+@ $@$ @@:@@: @@@ @@@ -@@$ @@-$+ @@@@@ :@@+@ @@@@@ $@$: @@@@@ -@@ $@+@
|
||||
; $+ -@ $- -$ @+ :@ $ $ $ -$ @$ : @ @$ -@ @ -@ @ @ $+ -@
|
||||
; @ @ @ @ @ +: ++ @@@@@ @ @ @@@@@ :@@$- @ -$@$@ @ @ @
|
||||
; @ @ @ @ @ $ $ $ @ @ *@ @ $* @ @ @ @
|
||||
; $* -$ $- -$ @ @ $:+ +: @ @: :$ @ :@ @: :$ @- *@ @: :$ @ $* -$
|
||||
; $@$- $@$ @@@ @@@ :@ $@@+ @@@@@ :@@$- $+@@: :@@$- -$$-@@ :@@$- @@@@@ $@$-
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
|
||||
(define (convert-static defns)
|
||||
(map convert-static-defn defns))
|
||||
|
||||
(define (convert-static-defn defn)
|
||||
(match defn
|
||||
[(struct ast:defn:iface (_ _ _ _))
|
||||
defn]
|
||||
[(struct ast:defn:class (_ _ _ _ _ inits members _))
|
||||
(let-values ([(members _)
|
||||
(convert-static-members members (map ast:formal-name inits))])
|
||||
(copy-struct ast:defn:class defn
|
||||
[ast:defn:class-members members]))]
|
||||
[(struct ast:defn:mixin (_ _ _ arg-type _ _ inits _ super-new members-before members-after _))
|
||||
(let*-values ([(members-before env)
|
||||
(convert-static-members members-before (map ast:formal-name inits))]
|
||||
[(super-new)
|
||||
(convert-static-super-new super-new env)]
|
||||
[(env)
|
||||
(extend-env-with-type-members env arg-type)]
|
||||
[(members-after _)
|
||||
(convert-static-members members-after env)])
|
||||
(copy-struct ast:defn:mixin defn
|
||||
[ast:defn:mixin-super-new super-new]
|
||||
[ast:defn:mixin-pre-members members-before]
|
||||
[ast:defn:mixin-post-members members-after]))]
|
||||
[(struct ast:defn:subclass (_ _ _ _))
|
||||
defn]
|
||||
[(struct ast:defn:function (_ _ _ _ _))
|
||||
defn]
|
||||
[(struct ast:defn:binding (_ _ _ _))
|
||||
defn]))
|
||||
|
||||
(define (extend-env-with-type-members env type)
|
||||
(let ([type-entry (get-type-entry type)])
|
||||
(fold (lambda (m e)
|
||||
(cons (tenv:member-name m) e))
|
||||
env
|
||||
(tenv:type-members type-entry))))
|
||||
|
||||
(define (convert-static-members members env)
|
||||
(let loop ([members members]
|
||||
[env env]
|
||||
[results '()])
|
||||
(cond
|
||||
[(null? members) (values (reverse results) env)]
|
||||
[(ast:class/member:method? (car members))
|
||||
(let-values ([(methods remaining) (span ast:class/member:method? members)])
|
||||
(let ([env (append (map ast:class/member-name methods) env)])
|
||||
(loop remaining
|
||||
env
|
||||
;; reverse is here just to keep the order
|
||||
(append (reverse (map (lambda (m)
|
||||
(convert-static-member m env))
|
||||
members))
|
||||
results))))]
|
||||
[else
|
||||
(let ([name (ast:class/member-name (car members))])
|
||||
(loop (cdr members)
|
||||
(cons name env)
|
||||
(cons (convert-static-member (car members) env) results)))])))
|
||||
|
||||
(define (convert-static-member member env)
|
||||
(match member
|
||||
[(struct ast:class/member:field/formal (_ name _ value))
|
||||
(if value
|
||||
(copy-struct ast:class/member:field/formal member
|
||||
[ast:class/member:field/formal-default (convert-static-expression value env)])
|
||||
member)]
|
||||
[(struct ast:class/member:field (_ name _ value))
|
||||
(copy-struct ast:class/member:field member
|
||||
[ast:class/member:field-default (convert-static-expression value env)])]
|
||||
[(struct ast:class/member:method (_ name _ args body))
|
||||
;; remember to remove lexical bindings!
|
||||
(let ([env (fold (lambda (name env)
|
||||
(delete name env bound-identifier=?))
|
||||
env (map ast:formal-name args))])
|
||||
(copy-struct ast:class/member:method member
|
||||
[ast:class/member:method-body (convert-static-expression body env)]))]))
|
||||
|
||||
(define (convert-static-super-new snew env)
|
||||
(match snew
|
||||
[(struct ast:super-new (_ args))
|
||||
(copy-struct ast:super-new snew
|
||||
[ast:super-new-args (map (lambda (a)
|
||||
(convert-static-name-arg a env))
|
||||
args)])]))
|
||||
|
||||
(define (convert-static-name-arg arg env)
|
||||
(match arg
|
||||
[(struct ast:named/arg (_ _ value))
|
||||
(copy-struct ast:named/arg arg
|
||||
[ast:named/arg-actual (convert-static-expression value env)])]))
|
||||
|
||||
(define (convert-static-expression expr env)
|
||||
(match expr
|
||||
[(struct ast:expr:self (_))
|
||||
expr]
|
||||
[(struct ast:expr:tuple/select (_ _ arg))
|
||||
(copy-struct ast:expr:tuple/select expr
|
||||
[ast:expr:tuple/select-arg (convert-static-expression arg env)])]
|
||||
[(struct ast:expr:var (stx name))
|
||||
(if (s:member name env bound-identifier=?)
|
||||
(make-ast:expr:member stx 'my #f name #f)
|
||||
expr)]
|
||||
[(struct ast:expr:assign (_ lhs rhs))
|
||||
(copy-struct ast:expr:assign expr
|
||||
[ast:expr:assign-lhs (convert-static-expression lhs env)]
|
||||
[ast:expr:assign-rhs (convert-static-expression rhs env)])]
|
||||
[(struct ast:expr:apply (_ func arg))
|
||||
(copy-struct ast:expr:apply expr
|
||||
[ast:expr:apply-func (convert-static-expression func env)]
|
||||
[ast:expr:apply-arg (convert-static-expression arg env)])]
|
||||
[(struct ast:expr:literal (_ _ _))
|
||||
expr]
|
||||
[(struct ast:expr:unary/op (_ _ _ _ arg))
|
||||
(copy-struct ast:expr:unary/op expr
|
||||
[ast:expr:unary/op-arg (convert-static-expression arg env)])]
|
||||
[(struct ast:expr:binary/op (_ _ _ _ larg rarg))
|
||||
(copy-struct ast:expr:binary/op expr
|
||||
[ast:expr:binary/op-left (convert-static-expression larg env)]
|
||||
[ast:expr:binary/op-right (convert-static-expression rarg env)])]
|
||||
;; originally forgot to remove the identifiers bound by
|
||||
;; the lambda from the environment
|
||||
[(struct ast:expr:function (_ _ args body))
|
||||
(let ([env (fold (lambda (name env)
|
||||
(delete name env bound-identifier=?))
|
||||
env (map ast:formal-name args))])
|
||||
(copy-struct ast:expr:function expr
|
||||
[ast:expr:function-body (convert-static-expression body env)]))]
|
||||
[(struct ast:expr:if (_ cond then else))
|
||||
(copy-struct ast:expr:if expr
|
||||
[ast:expr:if-test (convert-static-expression cond env)]
|
||||
[ast:expr:if-then (convert-static-expression then env)]
|
||||
[ast:expr:if-else (if else (convert-static-expression else env) #f)])]
|
||||
[(struct ast:expr:cast (_ obj _))
|
||||
(copy-struct ast:expr:cast expr
|
||||
[ast:expr:cast-object (convert-static-expression obj env)])]
|
||||
[(struct ast:expr:isa (_ obj _))
|
||||
(copy-struct ast:expr:isa expr
|
||||
[ast:expr:isa-object (convert-static-expression obj env)])]
|
||||
[(struct ast:expr:member (_ 'my _ _ _))
|
||||
expr]
|
||||
[(struct ast:expr:member (_ obj _ _ _))
|
||||
(copy-struct ast:expr:member expr
|
||||
[ast:expr:member-object (convert-static-expression obj env)])]
|
||||
[(struct ast:expr:new (_ _ _ args))
|
||||
(copy-struct ast:expr:new expr
|
||||
[ast:expr:new-args (map (lambda (a)
|
||||
(convert-static-name-arg a env))
|
||||
args)])]
|
||||
[(struct ast:expr:while (_ cond body))
|
||||
(copy-struct ast:expr:while expr
|
||||
[ast:expr:while-test (convert-static-expression cond env)]
|
||||
[ast:expr:while-body (convert-static-expression body env)])]
|
||||
[(struct ast:expr:cond (_ clauses else))
|
||||
(copy-struct ast:expr:cond expr
|
||||
[ast:expr:cond-clauses (map (lambda (c)
|
||||
(convert-static-cond-clause c env))
|
||||
clauses)]
|
||||
[ast:expr:cond-else (if else (convert-static-expression else env) #f)])]
|
||||
[(struct ast:expr:return (_ body))
|
||||
(copy-struct ast:expr:return expr
|
||||
[ast:expr:return-result (convert-static-expression body env)])]
|
||||
[(struct ast:expr:tuple (_ vals))
|
||||
(copy-struct ast:expr:tuple expr
|
||||
[ast:expr:tuple-elems (map (lambda (e)
|
||||
(convert-static-expression e env))
|
||||
vals)])]
|
||||
[(struct ast:expr:let (_ bindings body))
|
||||
(let*-values ([(bindings env) (map-and-fold convert-static-binding env bindings)]
|
||||
[(body) (convert-static-expression body env)])
|
||||
(copy-struct ast:expr:let expr
|
||||
[ast:expr:let-bindings bindings]
|
||||
[ast:expr:let-body body]))]
|
||||
[(struct ast:expr:sequence (_ effects value))
|
||||
(let ([effects (map (lambda (e)
|
||||
(convert-static-expression e env))
|
||||
effects)]
|
||||
[value (convert-static-expression value env)])
|
||||
(copy-struct ast:expr:sequence expr
|
||||
[ast:expr:sequence-statements effects]
|
||||
[ast:expr:sequence-result value]))]))
|
||||
|
||||
(define (convert-static-binding binding env)
|
||||
(match binding
|
||||
[(struct ast:defn:binding (_ names _ value))
|
||||
(values
|
||||
(copy-struct ast:defn:binding binding
|
||||
[ast:defn:binding-init (convert-static-expression value env)])
|
||||
(fold (lambda (name env)
|
||||
(if name
|
||||
(delete name env bound-identifier=?)
|
||||
env))
|
||||
env names))]))
|
||||
|
||||
(define (convert-static-cond-clause clause env)
|
||||
(match clause
|
||||
[(struct ast:cond/clause (_ pred rhs))
|
||||
(copy-struct ast:cond/clause clause
|
||||
[ast:cond/clause-test (convert-static-expression pred env)]
|
||||
[ast:cond/clause-result (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 ast:defn:iface (_ _ _ _))
|
||||
defn]
|
||||
[(struct ast:defn:class (_ _ _ _ _ inits members exports))
|
||||
(let* ([env (map ast: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 ast:defn:class defn
|
||||
[ast:defn:class-formals (reverse kept-inits)]
|
||||
[ast:defn:class-members (append (reverse new-fields) members)])
|
||||
(if (s:member (ast:formal-name (car inits)) used-slots bound-identifier=?)
|
||||
(loop (cdr inits)
|
||||
kept-inits
|
||||
(cons (make-ast:class/member:field/formal (ast-syntax (car inits))
|
||||
(ast:formal-name (car inits))
|
||||
(ast:formal-type (car inits))
|
||||
#f)
|
||||
new-fields))
|
||||
(loop (cdr inits)
|
||||
(cons (car inits) kept-inits)
|
||||
new-fields)))))]
|
||||
[(struct ast:defn:mixin (_ _ _ _ _ _ inits _ _ members-before members-after exports))
|
||||
(let* ([env (map ast: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 ast:defn:mixin defn
|
||||
[ast:defn:mixin-formals (reverse kept-inits)]
|
||||
[ast:defn:mixin-pre-members (append (reverse new-fields) members-before)])
|
||||
(if (s:member (ast:formal-name (car inits)) used-slots bound-identifier=?)
|
||||
(loop (cdr inits)
|
||||
kept-inits
|
||||
(cons (make-ast:class/member:field/formal (ast-syntax (car inits))
|
||||
(ast:formal-name (car inits))
|
||||
(ast:formal-type (car inits))
|
||||
#f)
|
||||
new-fields))
|
||||
(loop (cdr inits)
|
||||
(cons (car inits) kept-inits)
|
||||
new-fields)))))]
|
||||
[(struct ast:defn:subclass (_ _ _ _))
|
||||
defn]
|
||||
[(struct ast:defn:function (_ _ _ _ _))
|
||||
defn]
|
||||
[(struct ast:defn:binding (_ _ _ _))
|
||||
defn]))
|
||||
|
||||
(define (convert-slots-member member env)
|
||||
(match member
|
||||
;; init fields and fields do not necessitate converting init slots into init fields
|
||||
[(struct ast:class/member:field/formal (_ name _ value))
|
||||
(list)]
|
||||
[(struct ast:class/member:field (_ name _ value))
|
||||
(list)]
|
||||
;; methods do, though.
|
||||
[(struct ast:class/member:method (_ name _ _ body))
|
||||
(convert-slots-expression body env)]))
|
||||
|
||||
(define (convert-slots-export export env)
|
||||
(match export
|
||||
[(struct ast:export (_ _ binds))
|
||||
(filter (lambda (old)
|
||||
(s:member old env bound-identifier=?))
|
||||
(map ast:export/member-internal binds))]))
|
||||
|
||||
(define (convert-slots-name-arg arg env)
|
||||
(match arg
|
||||
[(struct ast:named/arg (_ _ value))
|
||||
(convert-slots-expression value env)]))
|
||||
|
||||
(define (convert-slots-expression expr env)
|
||||
(match expr
|
||||
[(struct ast:expr:self (_))
|
||||
(list)]
|
||||
[(struct ast:expr:tuple/select (_ _ arg))
|
||||
(convert-slots-expression arg env)]
|
||||
[(struct ast:expr:var (_ _))
|
||||
(list)]
|
||||
[(struct ast:expr:assign (_ lhs rhs))
|
||||
(append (convert-slots-expression lhs env)
|
||||
(convert-slots-expression rhs env))]
|
||||
[(struct ast:expr:apply (_ func arg))
|
||||
(append (convert-slots-expression func env)
|
||||
(convert-slots-expression arg env))]
|
||||
[(struct ast:expr:literal (_ _ _))
|
||||
(list)]
|
||||
[(struct ast:expr:unary/op (_ _ _ _ arg))
|
||||
(convert-slots-expression arg env)]
|
||||
[(struct ast:expr:binary/op (_ _ _ _ larg rarg))
|
||||
(append (convert-slots-expression larg env)
|
||||
(convert-slots-expression rarg env))]
|
||||
[(struct ast:expr:function (_ _ _ body))
|
||||
(convert-slots-expression body env)]
|
||||
[(struct ast:expr:if (_ cond then else))
|
||||
(append (convert-slots-expression cond env)
|
||||
(convert-slots-expression then env)
|
||||
(if else (convert-slots-expression else env) (list)))]
|
||||
[(struct ast:expr:cast (_ obj _))
|
||||
(convert-slots-expression obj env)]
|
||||
[(struct ast:expr:isa (_ obj _))
|
||||
(convert-slots-expression obj env)]
|
||||
[(struct ast:expr: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 ast:expr:member (_ obj _ _ _))
|
||||
(convert-slots-expression obj env)]
|
||||
[(struct ast:expr:new (_ _ _ args))
|
||||
(apply append
|
||||
(map (lambda (a)
|
||||
(convert-slots-name-arg a env))
|
||||
args))]
|
||||
[(struct ast:expr:while (_ cond body))
|
||||
(append (convert-slots-expression cond env)
|
||||
(convert-slots-expression body env))]
|
||||
[(struct ast:expr: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 ast:expr:return (_ body))
|
||||
(convert-slots-expression body env)]
|
||||
[(struct ast:expr:tuple (_ vals))
|
||||
(apply append
|
||||
(map (lambda (e)
|
||||
(convert-slots-expression e env))
|
||||
vals))]
|
||||
[(struct ast:expr: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 ast:expr:sequence (_ 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 ast:defn:binding (_ _ _ value))
|
||||
(convert-slots-expression value env)]))
|
||||
|
||||
(define (convert-slots-cond-clause clause env)
|
||||
(match clause
|
||||
[(struct ast: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 ast:defn:iface (_ _ _ _))
|
||||
defn]
|
||||
[(struct ast:defn:class (_ _ type _ _ _ members _))
|
||||
(let ([members (map (lambda (m) (check-this-member m type)) members)])
|
||||
(copy-struct ast:defn:class defn
|
||||
[ast:defn:class-members members]))]
|
||||
[(struct ast:defn: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 ast:defn:mixin defn
|
||||
[ast:defn:mixin-super-new super-new]
|
||||
[ast:defn:mixin-pre-members members-before]
|
||||
[ast:defn:mixin-post-members members-after]))]
|
||||
[(struct ast:defn:subclass (_ _ _ _))
|
||||
defn]
|
||||
[(struct ast:defn: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 ast:defn:binding (_ _ _ rhs))
|
||||
;; same check as in ast:defn:function.
|
||||
(begin
|
||||
(check-this-expression rhs #f)
|
||||
defn)]))
|
||||
|
||||
(define (check-this-member member type)
|
||||
(match member
|
||||
[(struct ast:class/member:field/formal (_ name _ value))
|
||||
(if value
|
||||
(copy-struct ast:class/member:field/formal member
|
||||
[ast:class/member:field/formal-default (check-this-expression value type)])
|
||||
member)]
|
||||
[(struct ast:class/member:field (_ name _ value))
|
||||
(copy-struct ast:class/member:field member
|
||||
[ast:class/member:field-default (check-this-expression value type)])]
|
||||
[(struct ast:class/member:method (_ name _ args body))
|
||||
(copy-struct ast:class/member:method member
|
||||
[ast:class/member:method-body (check-this-expression body type)])]))
|
||||
|
||||
(define (check-this-super-new snew type)
|
||||
(match snew
|
||||
[(struct ast:super-new (_ args))
|
||||
(copy-struct ast:super-new snew
|
||||
[ast:super-new-args (map (lambda (a)
|
||||
(check-this-name-arg a type))
|
||||
args)])]))
|
||||
|
||||
(define (check-this-name-arg arg type)
|
||||
(match arg
|
||||
[(struct ast:named/arg (_ _ value))
|
||||
(copy-struct ast:named/arg arg
|
||||
[ast:named/arg-actual (check-this-expression value type)])]))
|
||||
|
||||
(define (check-this-expression expr type)
|
||||
(match expr
|
||||
[(struct ast:expr:self (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 ast:expr:tuple/select (_ _ arg))
|
||||
(copy-struct ast:expr:tuple/select expr
|
||||
[ast:expr:tuple/select-arg (check-this-expression arg type)])]
|
||||
[(struct ast:expr:var (_ _))
|
||||
expr]
|
||||
[(struct ast:expr:assign (_ lhs rhs))
|
||||
(copy-struct ast:expr:assign expr
|
||||
[ast:expr:assign-lhs (check-this-expression lhs type)]
|
||||
[ast:expr:assign-rhs (check-this-expression rhs type)])]
|
||||
[(struct ast:expr:apply (_ func arg))
|
||||
(copy-struct ast:expr:apply expr
|
||||
[ast:expr:apply-func (check-this-expression func type)]
|
||||
[ast:expr:apply-arg (check-this-expression arg type)])]
|
||||
[(struct ast:expr:literal (_ _ _))
|
||||
expr]
|
||||
[(struct ast:expr:unary/op (_ _ _ _ arg))
|
||||
(copy-struct ast:expr:unary/op expr
|
||||
[ast:expr:unary/op-arg (check-this-expression arg type)])]
|
||||
[(struct ast:expr:binary/op (_ _ _ _ larg rarg))
|
||||
(copy-struct ast:expr:binary/op expr
|
||||
[ast:expr:binary/op-left (check-this-expression larg type)]
|
||||
[ast:expr:binary/op-right (check-this-expression rarg type)])]
|
||||
[(struct ast:expr:function (_ _ _ body))
|
||||
(copy-struct ast:expr:function expr
|
||||
[ast:expr:function-body (check-this-expression body type)])]
|
||||
[(struct ast:expr:if (_ cond then else))
|
||||
(copy-struct ast:expr:if expr
|
||||
[ast:expr:if-test (check-this-expression cond type)]
|
||||
[ast:expr:if-then (check-this-expression then type)]
|
||||
[ast:expr:if-else (if else (check-this-expression else type) #f)])]
|
||||
[(struct ast:expr:cast (_ obj _))
|
||||
(if (ast:expr:self? obj)
|
||||
(if type
|
||||
expr
|
||||
(raise-read-error-with-stx
|
||||
"Use of this keyword found outside of a class or mixin"
|
||||
(ast-syntax obj)))
|
||||
(copy-struct ast:expr:cast expr
|
||||
[ast:expr:cast-object (check-this-expression obj type)]))]
|
||||
[(struct ast:expr:isa (_ obj _))
|
||||
(if (ast:expr:self? obj)
|
||||
(if type
|
||||
expr
|
||||
(raise-read-error-with-stx
|
||||
"Use of this keyword found outside of a class or mixin"
|
||||
(ast-syntax obj)))
|
||||
(copy-struct ast:expr:isa expr
|
||||
[ast:expr:isa-object (check-this-expression obj type)]))]
|
||||
[(struct ast:expr:member (_ 'my _ _ _))
|
||||
expr]
|
||||
[(struct ast:expr:member (_ obj _ _ _))
|
||||
(if (ast:expr:self? 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 ast:expr:member expr
|
||||
[ast:expr:member-object (make-ast:expr:cast (ast-syntax obj)
|
||||
obj
|
||||
type)])
|
||||
(raise-read-error-with-stx
|
||||
"Use of this keyword found outside of a class or mixin"
|
||||
(ast-syntax obj)))
|
||||
(copy-struct ast:expr:member expr
|
||||
[ast:expr:member-object (check-this-expression obj type)]))]
|
||||
[(struct ast:expr:new (_ _ _ args))
|
||||
(copy-struct ast:expr:new expr
|
||||
[ast:expr:new-args (map (lambda (a)
|
||||
(check-this-name-arg a type))
|
||||
args)])]
|
||||
[(struct ast:expr:while (_ cond body))
|
||||
(copy-struct ast:expr:while expr
|
||||
[ast:expr:while-test (check-this-expression cond type)]
|
||||
[ast:expr:while-body (check-this-expression body type)])]
|
||||
[(struct ast:expr:cond (_ clauses else))
|
||||
(copy-struct ast:expr:cond expr
|
||||
[ast:expr:cond-clauses (map (lambda (c)
|
||||
(check-this-cond-clause c type))
|
||||
clauses)]
|
||||
[ast:expr:cond-else (if else (check-this-expression else type) #f)])]
|
||||
[(struct ast:expr:return (_ body))
|
||||
(copy-struct ast:expr:return expr
|
||||
[ast:expr:return-result (check-this-expression body type)])]
|
||||
[(struct ast:expr:tuple (_ vals))
|
||||
(copy-struct ast:expr:tuple expr
|
||||
[ast:expr:tuple-elems (map (lambda (e)
|
||||
(check-this-expression e type))
|
||||
vals)])]
|
||||
[(struct ast:expr:let (_ bindings body))
|
||||
(let ([bindings (map (lambda (b)
|
||||
(check-this-binding b type))
|
||||
bindings)]
|
||||
[body (check-this-expression body type)])
|
||||
(copy-struct ast:expr:let expr
|
||||
[ast:expr:let-bindings bindings]
|
||||
[ast:expr:let-body body]))]
|
||||
[(struct ast:expr:sequence (_ effects value))
|
||||
(let ([effects (map (lambda (e)
|
||||
(check-this-expression e type))
|
||||
effects)]
|
||||
[value (check-this-expression value type)])
|
||||
(copy-struct ast:expr:sequence expr
|
||||
[ast:expr:sequence-statements effects]
|
||||
[ast:expr:sequence-result value]))]))
|
||||
|
||||
(define (check-this-binding binding type)
|
||||
(match binding
|
||||
[(struct ast:defn:binding (_ names _ value))
|
||||
(copy-struct ast:defn:binding binding
|
||||
[ast:defn:binding-init (check-this-expression value type)])]))
|
||||
|
||||
(define (check-this-cond-clause clause type)
|
||||
(match clause
|
||||
[(struct ast:cond/clause (_ pred rhs))
|
||||
(copy-struct ast:cond/clause clause
|
||||
[ast:cond/clause-test (check-this-expression pred type)]
|
||||
[ast:cond/clause-result (check-this-expression rhs type)])]))
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
; @ @@ @ :@@$
|
||||
; @ @: @
|
||||
; :@@+@ -@@ @@+-$: @@:@$- @ -@@ @@@@@ @@@ @@@ $@$: :@@+@ @@@@@
|
||||
; @$ -@ @ @+@$@ @: -$ @ @ @ $- $- -@ @$ -@ @
|
||||
; :@@$- @ @ @ @ @ @ @ @ @ -$ $ @@@@@ -$@$@ :@@$- @
|
||||
; *@ @ @ @ @ @ @ @ @ @ $*$: $* @ *@ @
|
||||
; @ :@ @ @ @ @ @: -$ @ @ @ $$ @- *@ @ :@ @: :$
|
||||
; $+@@: @@@@@ @@@@@@@ @-@$ @@@@@ @@@@@ @@@@@ $* -$$-@@ $+@@: :@@$-
|
||||
; @ $
|
||||
; @@@ @@@@
|
||||
;
|
||||
;
|
||||
|
||||
(define (simplify-ast defns)
|
||||
(map simplify-defn defns))
|
||||
|
||||
(define (simplify-defn defn)
|
||||
(match defn
|
||||
[(struct ast:defn:iface (_ _ _ _))
|
||||
defn]
|
||||
[(struct ast:defn:class (_ _ _ _ _ _ members _))
|
||||
(copy-struct ast:defn:class defn
|
||||
[ast:defn:class-members (map simplify-member members)])]
|
||||
[(struct ast:defn:mixin (_ _ _ _ _ _ _ _ super-new members-before members-after _))
|
||||
(copy-struct ast:defn:mixin defn
|
||||
[ast:defn:mixin-super-new (simplify-super-new super-new)]
|
||||
[ast:defn:mixin-pre-members (map simplify-member members-before)]
|
||||
[ast:defn:mixin-post-members (map simplify-member members-after)])]
|
||||
[(struct ast:defn:subclass (_ _ _ _))
|
||||
defn]
|
||||
[(struct ast:defn:function (_ _ _ _ body))
|
||||
(copy-struct ast:defn:function defn
|
||||
[ast:defn:function-body (simplify-expression body)])]
|
||||
[(struct ast:defn:binding (_ _ _ value))
|
||||
(copy-struct ast:defn:binding defn
|
||||
[ast:defn:binding-init (simplify-expression value)])]))
|
||||
|
||||
(define (simplify-member member)
|
||||
(match member
|
||||
[(struct ast:class/member:field/formal (_ _ _ value))
|
||||
(if value
|
||||
(copy-struct ast:class/member:field/formal member
|
||||
[ast:class/member:field/formal-default (simplify-expression value)])
|
||||
member)]
|
||||
[(struct ast:class/member:field (_ _ _ value))
|
||||
(copy-struct ast:class/member:field member
|
||||
[ast:class/member:field-default (simplify-expression value)])]
|
||||
[(struct ast:class/member:method (_ _ _ _ body))
|
||||
(copy-struct ast:class/member:method member
|
||||
[ast:class/member:method-body (simplify-expression body)])]))
|
||||
|
||||
(define (simplify-super-new snew)
|
||||
(match snew
|
||||
[(struct ast:super-new (_ args))
|
||||
(copy-struct ast:super-new snew
|
||||
[ast:super-new-args (map simplify-name-arg args)])]))
|
||||
|
||||
(define (simplify-name-arg arg)
|
||||
(match arg
|
||||
[(struct ast:named/arg (_ _ value))
|
||||
(copy-struct ast:named/arg arg
|
||||
[ast:named/arg-actual (simplify-expression value)])]))
|
||||
|
||||
(define (simplify-expression expr)
|
||||
(match expr
|
||||
[(struct ast:expr:self (_))
|
||||
expr]
|
||||
[(struct ast:expr:tuple/select (_ _ arg))
|
||||
(copy-struct ast:expr:tuple/select expr
|
||||
[ast:expr:tuple/select-arg (simplify-expression arg)])]
|
||||
[(struct ast:expr:var (_ _))
|
||||
expr]
|
||||
[(struct ast:expr:assign (_ lhs rhs))
|
||||
(copy-struct ast:expr:assign expr
|
||||
[ast:expr:assign-lhs (simplify-expression lhs)]
|
||||
[ast:expr:assign-rhs (simplify-expression rhs)])]
|
||||
[(struct ast:expr:apply (_ func arg))
|
||||
(copy-struct ast:expr:apply expr
|
||||
[ast:expr:apply-func (simplify-expression func)]
|
||||
[ast:expr:apply-arg (simplify-expression arg)])]
|
||||
[(struct ast:expr:literal (_ _ _))
|
||||
expr]
|
||||
[(struct ast:expr:unary/op (_ _ _ _ arg))
|
||||
(copy-struct ast:expr:unary/op expr
|
||||
[ast:expr:unary/op-arg (simplify-expression arg)])]
|
||||
[(struct ast:expr:binary/op (_ _ _ _ larg rarg))
|
||||
(copy-struct ast:expr:binary/op expr
|
||||
[ast:expr:binary/op-left (simplify-expression larg)]
|
||||
[ast:expr:binary/op-right (simplify-expression rarg)])]
|
||||
[(struct ast:expr:function (_ _ _ body))
|
||||
(copy-struct ast:expr:function expr
|
||||
[ast:expr:function-body (simplify-expression body)])]
|
||||
[(struct ast:expr:if (_ cond then else))
|
||||
(copy-struct ast:expr:if expr
|
||||
[ast:expr:if-test (simplify-expression cond)]
|
||||
[ast:expr:if-then (simplify-expression then)]
|
||||
[ast:expr:if-else (if else (simplify-expression else) #f)])]
|
||||
[(struct ast:expr:cast (_ obj _))
|
||||
(copy-struct ast:expr:cast expr
|
||||
[ast:expr:cast-object (simplify-expression obj)])]
|
||||
[(struct ast:expr:isa (_ obj _))
|
||||
(copy-struct ast:expr:isa expr
|
||||
[ast:expr:isa-object (simplify-expression obj)])]
|
||||
[(struct ast:expr:member (_ 'my _ _ _))
|
||||
expr]
|
||||
[(struct ast:expr:member (_ obj _ _ _))
|
||||
(copy-struct ast:expr:member expr
|
||||
[ast:expr:member-object (simplify-expression obj)])]
|
||||
[(struct ast:expr:new (_ _ _ args))
|
||||
(copy-struct ast:expr:new expr
|
||||
[ast:expr:new-args (map simplify-name-arg args)])]
|
||||
[(struct ast:expr:cond (_ clauses else))
|
||||
(copy-struct ast:expr:cond expr
|
||||
[ast:expr:cond-clauses (map simplify-cond-clause clauses)]
|
||||
[ast:expr:cond-else (if else (simplify-expression else) #f)])]
|
||||
[(struct ast:expr:while (_ cond body))
|
||||
(copy-struct ast:expr:while expr
|
||||
[ast:expr:while-test (simplify-expression cond)]
|
||||
[ast:expr:while-body (simplify-expression body)])]
|
||||
[(struct ast:expr:return (_ body))
|
||||
(copy-struct ast:expr:return expr
|
||||
[ast:expr:return-result (simplify-expression body)])]
|
||||
[(struct ast:expr:tuple (_ vals))
|
||||
(copy-struct ast:expr:tuple expr
|
||||
[ast:expr:tuple-elems (map simplify-expression vals)])]
|
||||
[(struct ast:expr:let (stx bindings body))
|
||||
(let ([bindings (map simplify-binding bindings)]
|
||||
[body (simplify-expression body)])
|
||||
(match body
|
||||
[(struct ast:expr:let (_ sub-bindings sub-body))
|
||||
(make-ast:expr:let stx (append bindings sub-bindings) sub-body)]
|
||||
[_
|
||||
(copy-struct ast:expr:let expr
|
||||
[ast:expr:let-bindings bindings]
|
||||
[ast:expr:let-body body])]))]
|
||||
[(struct ast:expr:sequence (stx effects value))
|
||||
(let ([effects (map simplify-expression effects)]
|
||||
[value (simplify-expression value)])
|
||||
(match value
|
||||
[(struct ast:expr:sequence (_ sub-effects sub-value))
|
||||
(make-ast:expr:sequence stx (append effects sub-effects) sub-value)]
|
||||
[_
|
||||
(copy-struct ast:expr:sequence expr
|
||||
[ast:expr:sequence-statements effects]
|
||||
[ast:expr:sequence-result value])]))]))
|
||||
|
||||
(define (simplify-binding binding)
|
||||
(match binding
|
||||
[(struct ast:defn:binding (_ _ _ value))
|
||||
(copy-struct ast:defn:binding binding
|
||||
[ast:defn:binding-init (simplify-expression value)])]))
|
||||
|
||||
(define (simplify-cond-clause clause)
|
||||
(match clause
|
||||
[(struct ast:cond/clause (_ pred rhs))
|
||||
(copy-struct ast:cond/clause clause
|
||||
[ast:cond/clause-test (simplify-expression pred)]
|
||||
[ast:cond/clause-result (simplify-expression rhs)])]))
|
||||
)
|
||||
|
|
@ -1,184 +0,0 @@
|
|||
(module translate-class-utils mzscheme
|
||||
|
||||
(require (lib "list.ss" "srfi" "1")
|
||||
(only (lib "list.ss") quicksort)
|
||||
(lib "plt-match.ss")
|
||||
"../../ast.ss"
|
||||
"../../readerr.ss"
|
||||
"../../tenv.ss"
|
||||
"../tools/general.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 exports)
|
||||
(let ([exports (filter-exports (generate-exports exports))])
|
||||
(map (lambda (e)
|
||||
(translate-export #f e))
|
||||
exports)))
|
||||
|
||||
(define (translate-subclass-exports super-types exports)
|
||||
(let ([exports (filter-exports (generate-exports exports))])
|
||||
(map (lambda (e)
|
||||
(if (ormap (lambda (t)
|
||||
(<:_P t (comp:export-type e)))
|
||||
super-types)
|
||||
(translate-export #t e)
|
||||
(translate-export #f e)))
|
||||
exports)))
|
||||
|
||||
|
||||
|
||||
(define (generate-super-exports 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 (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 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 exports)
|
||||
(let loop ([exports exports]
|
||||
[comp-exps '()])
|
||||
(if (null? exports)
|
||||
comp-exps
|
||||
(let* ([export (car exports)]
|
||||
[type-entry (get-type-entry (ast:export-type export))])
|
||||
(let loop2 ([exp-binds (ast:export-members 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 type-entry comp-binds)])
|
||||
(loop (cdr exports)
|
||||
(cons (make-comp:export (ast-syntax export)
|
||||
(ast:export-type export)
|
||||
comp-binds)
|
||||
(append super-exports comp-exps))))
|
||||
(let-values ([(matched non-matches) (partition-first (lambda (m)
|
||||
(tenv-key=? (ast:export/member-external (car exp-binds))
|
||||
(tenv:member-name m)))
|
||||
members)])
|
||||
(loop2 (cdr exp-binds)
|
||||
non-matches
|
||||
(cons (make-comp:exp-bind (ast:export/member-internal (car exp-binds))
|
||||
(ast:export/member-external (car exp-binds))
|
||||
(ast:type:method? (tenv:member-type matched)))
|
||||
comp-binds)))))))))
|
||||
|
||||
(define (sort-binds export)
|
||||
(quicksort (comp:export-binds export)
|
||||
(lambda (b1 b2)
|
||||
(tenv-key<? (comp:exp-bind-new b1)
|
||||
(comp:exp-bind-new b2)))))
|
||||
|
||||
|
||||
(define (check-exports exports)
|
||||
(let* ([main-export (car exports)]
|
||||
[main-export-binds (sort-binds main-export)])
|
||||
(let loop ([exports (cdr exports)])
|
||||
(if (null? exports)
|
||||
(void)
|
||||
(let loop2 ([binds-1 main-export-binds]
|
||||
[binds-2 (sort-binds (car exports))])
|
||||
;; if one's empty, both must be since we passed the typechecker
|
||||
(cond
|
||||
[(null? binds-1)
|
||||
(loop (cdr exports))]
|
||||
[(tenv-key=? (comp:exp-bind-old (car binds-1))
|
||||
(comp:exp-bind-old (car binds-2)))
|
||||
(loop2 (cdr binds-1) (cdr binds-2))]
|
||||
[else
|
||||
(raise-read-error-with-stx
|
||||
(format "Different local names exported for member ~a of type ~a: ~a here and ~a elsewhere"
|
||||
(printable-type (comp:export-type main-export))
|
||||
(printable-key (comp:exp-bind-new (car binds-1)))
|
||||
(printable-key (comp:exp-bind-old (car binds-1)))
|
||||
(printable-key (comp:exp-bind-old (car binds-2))))
|
||||
(comp:exp-bind-old (car binds-1)))]))))))
|
||||
|
||||
(define (filter-exports exports)
|
||||
(let loop ([exports exports]
|
||||
[kept-exps '()])
|
||||
(if (null? exports)
|
||||
kept-exps
|
||||
(let-values ([(matches non-matches) (partition (lambda (exp)
|
||||
(type-equal?
|
||||
(comp:export-type (car exports))
|
||||
(comp:export-type exp)))
|
||||
exports)])
|
||||
(check-exports matches)
|
||||
(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 in-super? export)
|
||||
(cons 'begin
|
||||
(map (lambda (b)
|
||||
(translate-exp-bind in-super? (comp:export-type export) b))
|
||||
(comp:export-binds export))))
|
||||
|
||||
(define (translate-exp-bind in-super? 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) arg-tuple)
|
||||
,(translate-static-method old-name 'arg-tuple)))]
|
||||
[(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 old-name))
|
||||
(,right-defn (,(translate-field-setter-name type new-name) set-arg)
|
||||
,(translate-static-field-setter old-name 'set-arg))))])))
|
||||
|
||||
(provide translate-super-new translate-inits translate-member)
|
||||
(define (translate-super-new super-new)
|
||||
(at (ast-syntax super-new)
|
||||
(cons 'super-new (map (lambda (a)
|
||||
(list (at-ctxt (ast:named/arg-name a))
|
||||
(translate-expression (ast:named/arg-actual a))))
|
||||
(ast:super-new-args super-new)))))
|
||||
|
||||
(define (translate-inits inits)
|
||||
(cons 'init (map (lambda (i)
|
||||
(at-ctxt (ast:formal-name i)))
|
||||
inits)))
|
||||
|
||||
(define (mangle-init-name name)
|
||||
(at name (string->symbol (string-append "init-" (symbol->string (syntax-e name))))))
|
||||
|
||||
(define (translate-member member)
|
||||
(match member
|
||||
[(struct ast:class/member:field/formal (stx name type value))
|
||||
(if value
|
||||
(at stx`(begin (init ([,(mangle-init-name name) ,(at-ctxt name)]
|
||||
,(translate-expression value)))
|
||||
(define ,(at-ctxt name) ,(mangle-init-name name))))
|
||||
(at stx `(begin (init ([,(mangle-init-name name) ,(at-ctxt name)]))
|
||||
(define ,(at-ctxt name) ,(mangle-init-name name)))))]
|
||||
[(struct ast:class/member:field (stx name type value))
|
||||
(at stx `(define ,(at-ctxt name) ,(translate-expression value)))]
|
||||
[(struct ast:class/member:method (stx name type formals body))
|
||||
(translate-function stx name formals (translate-expression body))]))
|
||||
|
||||
|
||||
)
|
||||
|
|
@ -1,308 +0,0 @@
|
|||
(module translate-expression mzscheme
|
||||
|
||||
(require (lib "contract.ss")
|
||||
(lib "plt-match.ss")
|
||||
"../../ast.ss"
|
||||
"../../readerr.ss"
|
||||
"../../tenv.ss"
|
||||
"../typechecker/type-utils.ss"
|
||||
"translate-utils.ss")
|
||||
|
||||
(provide/contract [translate-expression (ast:expr?
|
||||
. -> .
|
||||
(syntax/c any/c))])
|
||||
(define (translate-expression expr)
|
||||
(match expr
|
||||
[(struct ast:expr:literal (stx _ value))
|
||||
(at stx value)]
|
||||
[(struct ast:expr:var (stx name))
|
||||
(at-ctxt name)]
|
||||
[(struct ast:expr:tuple (stx args))
|
||||
;; list is a bindable name in Honu, so... we use list*, which isn't.
|
||||
(at stx `(list* ,@(map translate-expression args) ()))]
|
||||
[(struct ast:expr:function (stx _ formals body))
|
||||
(translate-function stx #f formals (translate-expression body))]
|
||||
[(struct ast:expr:apply (stx func arg))
|
||||
(match func
|
||||
[(struct ast:expr:member (stx 'my _ name #t))
|
||||
(at stx (translate-static-method name (translate-expression arg)))]
|
||||
[(struct ast:expr:member (stx obj elab name #t))
|
||||
(at stx `(honu:send ,(translate-expression obj)
|
||||
,(translate-method-name elab name)
|
||||
,(translate-expression arg)))]
|
||||
[else
|
||||
(at stx `(,(translate-expression func)
|
||||
,(translate-expression arg)))])]
|
||||
[(struct ast:expr:tuple/select (stx slot arg))
|
||||
(at stx `(list-ref ,(translate-expression arg)
|
||||
(- ,slot 1)))]
|
||||
[(struct ast:expr:if (stx test then else))
|
||||
(if else
|
||||
(at stx `(if ,(translate-expression test)
|
||||
,(translate-expression then)
|
||||
,(translate-expression else)))
|
||||
(at stx `(if ,(translate-expression test)
|
||||
,(translate-expression then)
|
||||
,void-value)))]
|
||||
[(struct ast:expr:cond (stx clauses else))
|
||||
(if else
|
||||
(at stx `(cond ,@(map (lambda (c)
|
||||
`(,(translate-expression (ast:cond/clause-test c))
|
||||
,(translate-expression (ast:cond/clause-result c))))
|
||||
clauses)
|
||||
(else ,(translate-expression else))))
|
||||
(at stx `(cond ,@(map (lambda (c)
|
||||
`(,(translate-expression (ast:cond/clause-test c))
|
||||
,(translate-expression (ast:cond/clause-result c))))
|
||||
clauses)
|
||||
(else ,void-value))))]
|
||||
[(struct ast:expr:unary/op (stx op op-stx op-type arg))
|
||||
(case op
|
||||
[(not)
|
||||
(at stx
|
||||
`(,(at op-stx 'not) ,(translate-expression arg)))]
|
||||
[(minus)
|
||||
(at stx
|
||||
`(,(at op-stx '-) ,(translate-expression arg)))]
|
||||
[else (raise-read-error-with-stx
|
||||
"Haven't translated unary operator yet."
|
||||
op-stx)])]
|
||||
[(struct ast:expr:binary/op (stx op op-stx op-type larg rarg))
|
||||
(case op
|
||||
[(equal)
|
||||
(if (and (ast:type:primitive? op-type)
|
||||
(eqv? (ast:type:primitive-name op-type) 'string))
|
||||
(at stx
|
||||
`(,(at op-stx 'string=?)
|
||||
,(translate-expression larg)
|
||||
,(translate-expression rarg)))
|
||||
(at stx
|
||||
`(,(at op-stx 'eqv?)
|
||||
,(translate-expression larg)
|
||||
,(translate-expression rarg))))]
|
||||
[(neq)
|
||||
(if (and (ast:type:primitive? op-type)
|
||||
(eqv? (ast:type:primitive-name op-type) 'string))
|
||||
(at stx
|
||||
`(,(at op-stx 'not)
|
||||
(,(at op-stx 'string=?)
|
||||
,(translate-expression larg)
|
||||
,(translate-expression rarg))))
|
||||
(at stx
|
||||
`(,(at op-stx 'not)
|
||||
(,(at op-stx 'eqv?)
|
||||
,(translate-expression larg)
|
||||
,(translate-expression rarg)))))]
|
||||
[(clseq)
|
||||
(at stx
|
||||
`(,(at op-stx 'equal?)
|
||||
,(translate-expression larg)
|
||||
,(translate-expression rarg)))]
|
||||
[(and)
|
||||
(at stx
|
||||
`(,(at op-stx 'and)
|
||||
,(translate-expression larg)
|
||||
,(translate-expression rarg)))]
|
||||
[(or)
|
||||
(at stx
|
||||
`(,(at op-stx 'or)
|
||||
,(translate-expression larg)
|
||||
,(translate-expression rarg)))]
|
||||
[(lt)
|
||||
(case (ast:type:primitive-name op-type)
|
||||
[(int float)
|
||||
(at stx
|
||||
`(,(at op-stx '<)
|
||||
,(translate-expression larg)
|
||||
,(translate-expression rarg)))]
|
||||
[(string)
|
||||
(at stx
|
||||
`(,(at op-stx 'string<?)
|
||||
,(translate-expression larg)
|
||||
,(translate-expression rarg)))]
|
||||
[(char)
|
||||
(at stx
|
||||
`(,(at op-stx 'char<?)
|
||||
,(translate-expression larg)
|
||||
,(translate-expression rarg)))])]
|
||||
[(le)
|
||||
(case (ast:type:primitive-name op-type)
|
||||
[(int float)
|
||||
(at stx
|
||||
`(,(at op-stx '<=)
|
||||
,(translate-expression larg)
|
||||
,(translate-expression rarg)))]
|
||||
[(string)
|
||||
(at stx
|
||||
`(,(at op-stx 'string<=?)
|
||||
,(translate-expression larg)
|
||||
,(translate-expression rarg)))]
|
||||
[(char)
|
||||
(at stx
|
||||
`(,(at op-stx 'char<=?)
|
||||
,(translate-expression larg)
|
||||
,(translate-expression rarg)))])]
|
||||
[(gt)
|
||||
(case (ast:type:primitive-name op-type)
|
||||
[(int float)
|
||||
(at stx
|
||||
`(,(at op-stx '>)
|
||||
,(translate-expression larg)
|
||||
,(translate-expression rarg)))]
|
||||
[(string)
|
||||
(at stx
|
||||
`(,(at op-stx 'string>?)
|
||||
,(translate-expression larg)
|
||||
,(translate-expression rarg)))]
|
||||
[(char)
|
||||
(at stx
|
||||
`(,(at op-stx 'char>?)
|
||||
,(translate-expression larg)
|
||||
,(translate-expression rarg)))])]
|
||||
[(ge)
|
||||
(case (ast:type:primitive-name op-type)
|
||||
[(int float)
|
||||
(at stx
|
||||
`(,(at op-stx '>=)
|
||||
,(translate-expression larg)
|
||||
,(translate-expression rarg)))]
|
||||
[(string)
|
||||
(at stx
|
||||
`(,(at op-stx 'string>=?)
|
||||
,(translate-expression larg)
|
||||
,(translate-expression rarg)))]
|
||||
[(char)
|
||||
(at stx
|
||||
`(,(at op-stx 'char>=?)
|
||||
,(translate-expression larg)
|
||||
,(translate-expression rarg)))])]
|
||||
[(plus)
|
||||
(case (ast:type:primitive-name op-type)
|
||||
[(int float)
|
||||
(at stx
|
||||
`(,(at op-stx '+)
|
||||
,(translate-expression larg)
|
||||
,(translate-expression rarg)))]
|
||||
[(string)
|
||||
(at stx
|
||||
`(,(at op-stx 'string-append)
|
||||
,(translate-expression larg)
|
||||
,(translate-expression rarg)))])]
|
||||
[(minus)
|
||||
(at stx
|
||||
`(,(at op-stx '-)
|
||||
,(translate-expression larg)
|
||||
,(translate-expression rarg)))]
|
||||
[(times)
|
||||
(at stx
|
||||
`(,(at op-stx '*)
|
||||
,(translate-expression larg)
|
||||
,(translate-expression rarg)))]
|
||||
[(div)
|
||||
(case (ast:type:primitive-name op-type)
|
||||
[(int)
|
||||
(at stx
|
||||
`(,(at op-stx 'quotient)
|
||||
,(translate-expression larg)
|
||||
,(translate-expression rarg)))]
|
||||
[(float)
|
||||
(at stx
|
||||
`(,(at op-stx '/)
|
||||
,(translate-expression larg)
|
||||
,(translate-expression rarg)))])]
|
||||
[(mod)
|
||||
(at stx
|
||||
`(,(at op-stx 'remainder)
|
||||
,(translate-expression larg)
|
||||
,(translate-expression rarg)))]
|
||||
[else (raise-read-error-with-stx
|
||||
"Haven't translated binary operator yet."
|
||||
op-stx)])]
|
||||
[(struct ast:expr:return (stx body))
|
||||
(at stx
|
||||
`(last-k ,(translate-expression body)))]
|
||||
[(struct ast:expr:let (stx bindings body))
|
||||
(at stx
|
||||
`(let*-values ,(map (lambda (b)
|
||||
(let-values ([(bound-names body)
|
||||
(translate-binding-clause (ast:defn:binding-names b)
|
||||
(translate-expression (ast:defn:binding-init b)))])
|
||||
;; make sure to give the let binding the appropriate syntax,
|
||||
;; otherwise errors will highlight the entire let expression.
|
||||
(at (ast-syntax b) `(,bound-names ,body))))
|
||||
bindings)
|
||||
,(translate-expression body)))]
|
||||
[(struct ast:expr:sequence (stx effects value))
|
||||
(at stx
|
||||
`(begin ,@(map translate-expression effects)
|
||||
,(translate-expression value)))]
|
||||
[(struct ast:expr:while (stx test body))
|
||||
(at stx
|
||||
`(let loop ()
|
||||
(if ,(translate-expression test)
|
||||
(begin ,(translate-expression body) (loop))
|
||||
,void-value)))]
|
||||
[(struct ast:expr:assign (stx lhs rhs))
|
||||
(match lhs
|
||||
[(struct ast:expr:var (_ _))
|
||||
(at stx `(begin (set! ,(translate-expression lhs)
|
||||
,(translate-expression rhs))
|
||||
,void-value))]
|
||||
[(struct ast:expr: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 name (translate-expression rhs))))]
|
||||
[(struct ast:expr: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 `(honu:send ,(translate-expression obj)
|
||||
,(translate-field-setter-name elab name)
|
||||
,(translate-expression rhs))))]
|
||||
[else
|
||||
(raise-read-error-with-stx
|
||||
"Left-hand side of assignment is invalid"
|
||||
stx)])]
|
||||
[(struct ast:expr:member (stx 'my _ name method?))
|
||||
(if method?
|
||||
(at stx (translate-static-method name))
|
||||
(at stx (translate-static-field-getter name)))]
|
||||
[(struct ast:expr:member (stx obj elab name method?))
|
||||
(if method?
|
||||
(at stx `(lambda (args)
|
||||
(honu:send ,(translate-expression obj)
|
||||
,(translate-method-name elab name)
|
||||
args)))
|
||||
(at stx `(honu:send ,(translate-expression obj)
|
||||
,(translate-field-getter-name elab name)
|
||||
,void-value)))]
|
||||
[(struct ast:expr:new (stx class _ args))
|
||||
(at stx `(new ,(translate-class-name class)
|
||||
,@(map (lambda (a)
|
||||
`(,(ast:named/arg-name a)
|
||||
,(translate-expression (ast:named/arg-actual a))))
|
||||
args)))]
|
||||
[(struct ast:expr:cast (stx obj type))
|
||||
(at stx `(let ([cast-obj ,(translate-expression obj)])
|
||||
;; you can always cast null to an interface type
|
||||
(if (or (is-a? cast-obj null%)
|
||||
(honu:send cast-obj implements? ,(translate-iface-name type)))
|
||||
cast-obj
|
||||
(error (format "Class ~a does not implement ~a"
|
||||
(honu:send cast-obj format-class-name)
|
||||
(quote ,(syntax-e (iface-name type))))))))]
|
||||
[(struct ast:expr:isa (stx obj type))
|
||||
(at stx `(let ([cast-obj ,(translate-expression obj)])
|
||||
;; null is a member of any interface type
|
||||
(or (is-a? cast-obj null%)
|
||||
(honu:send cast-obj implements? ,(translate-iface-name type)))))]
|
||||
[(struct ast:expr:self (stx))
|
||||
(at stx 'this)]
|
||||
[else (raise-read-error-with-stx
|
||||
"Haven't translated that type of expression yet."
|
||||
(ast-syntax expr))]))
|
||||
|
||||
)
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
(module translate-parameters mzscheme
|
||||
|
||||
(provide (all-defined))
|
||||
|
||||
(define current-mixin-argument-type (make-parameter #f))
|
||||
|
||||
)
|
||||
|
|
@ -1,168 +0,0 @@
|
|||
(module translate-unwanted-types mzscheme
|
||||
|
||||
(require (lib "list.ss" "srfi" "1")
|
||||
(lib "plt-match.ss")
|
||||
"../../ast.ss"
|
||||
"translate-utils.ss")
|
||||
|
||||
(provide build-unwanted-type-syntax)
|
||||
(define (build-unwanted-type-syntax defns)
|
||||
(map build-unwanted-type-syntax-defn defns))
|
||||
|
||||
;; since we're never going to run the result anyway, it doesn't matter
|
||||
;; how we build things -- no need to flatten.
|
||||
(define (build-unwanted-type-syntax-defn defn)
|
||||
(match defn
|
||||
[(struct ast:defn:binding (_ _ types value))
|
||||
(cons (build-unwanted-type-syntax-expression value)
|
||||
;; remember to filter out the top types used whenever _ appears
|
||||
(map translate-type-for-syntax (filter (lambda (t) (not (ast:type:top? t))) types)))]
|
||||
[(struct ast:defn:function (_ _ type formals body))
|
||||
(list (translate-type-for-syntax type)
|
||||
(build-unwanted-type-syntax-expression body)
|
||||
(map (lambda (f)
|
||||
(translate-type-for-syntax (ast:formal-type f)))
|
||||
formals))]
|
||||
[(struct ast:defn:iface (_ _ _ members))
|
||||
(map build-unwanted-type-syntax-member-decl members)]
|
||||
[(struct ast:defn:class (_ _ selftype _ _ inits members exports))
|
||||
(list (translate-type-for-syntax selftype)
|
||||
(map (lambda (f)
|
||||
(translate-type-for-syntax (ast:formal-type f)))
|
||||
inits)
|
||||
(map build-unwanted-type-syntax-member members)
|
||||
(map (lambda (e)
|
||||
(translate-type-for-syntax (ast:export-type e)))
|
||||
exports))]
|
||||
[(struct ast:defn:mixin (_ _ selftype arg-type _ _ inits withs super-new
|
||||
members-before members-after exports))
|
||||
(list (translate-type-for-syntax selftype)
|
||||
(translate-type-for-syntax arg-type)
|
||||
(map (lambda (f)
|
||||
(translate-type-for-syntax (ast:formal-type f)))
|
||||
inits)
|
||||
(map (lambda (f)
|
||||
(translate-type-for-syntax (ast:formal-type f)))
|
||||
withs)
|
||||
(map (lambda (a)
|
||||
(build-unwanted-type-syntax-expression (ast:named/arg-actual a)))
|
||||
(ast:super-new-args super-new))
|
||||
(map build-unwanted-type-syntax-member members-before)
|
||||
(map build-unwanted-type-syntax-member members-after)
|
||||
(map (lambda (e)
|
||||
(translate-type-for-syntax (ast:export-type e)))
|
||||
exports))]
|
||||
[(struct ast:defn:subclass (_ _ _ mixin))
|
||||
;; okay, this isn't a type, but we still want to see it as a use
|
||||
;; until we can translate mixins correctly.
|
||||
(list (translate-mixin-name mixin))]))
|
||||
|
||||
(define (build-unwanted-type-syntax-member-decl member)
|
||||
(match member
|
||||
[(struct ast:iface/member:field (_ _ type))
|
||||
(translate-type-for-syntax type)]
|
||||
[(struct ast:iface/member:method (_ _ type arg-types))
|
||||
(list (translate-type-for-syntax type)
|
||||
(map translate-type-for-syntax arg-types))]))
|
||||
|
||||
(define (build-unwanted-type-syntax-member member)
|
||||
(match member
|
||||
[(struct ast:class/member:field/formal (_ _ type value))
|
||||
(list (translate-type-for-syntax type)
|
||||
(if value (build-unwanted-type-syntax-expression value) '()))]
|
||||
[(struct ast:class/member:field (_ _ type value))
|
||||
(list (translate-type-for-syntax type)
|
||||
(build-unwanted-type-syntax-expression value))]
|
||||
[(struct ast:class/member:method (_ _ type formals body))
|
||||
(list (translate-type-for-syntax type)
|
||||
(map (lambda (f)
|
||||
(translate-type-for-syntax (ast:formal-type f)))
|
||||
formals)
|
||||
(build-unwanted-type-syntax-expression body))]))
|
||||
|
||||
(define (build-unwanted-type-syntax-expression expr)
|
||||
(match expr
|
||||
[(struct ast:expr:function (_ type formals body))
|
||||
(list (translate-type-for-syntax type)
|
||||
(map (lambda (f)
|
||||
(translate-type-for-syntax (ast:formal-type f)))
|
||||
formals)
|
||||
(build-unwanted-type-syntax-expression body))]
|
||||
[(struct ast:expr:let (_ bindings body))
|
||||
(list (map (lambda (b)
|
||||
;; again, make sure to remove types corresponding to _
|
||||
(list (map translate-type-for-syntax (filter (lambda (t)
|
||||
(not (ast:type:top? t)))
|
||||
(ast:defn:binding-types b)))
|
||||
(build-unwanted-type-syntax-expression (ast:defn:binding-init b))))
|
||||
bindings)
|
||||
(build-unwanted-type-syntax-expression body))]
|
||||
[(struct ast:expr:sequence (_ effects result))
|
||||
(list (map (lambda (e)
|
||||
(build-unwanted-type-syntax-expression e))
|
||||
effects)
|
||||
(build-unwanted-type-syntax-expression result))]
|
||||
[(struct ast:expr:apply (_ func arg))
|
||||
(list (build-unwanted-type-syntax-expression func)
|
||||
(build-unwanted-type-syntax-expression arg))]
|
||||
[(struct ast:expr:assign (_ lhs rhs))
|
||||
(list (build-unwanted-type-syntax-expression lhs)
|
||||
(build-unwanted-type-syntax-expression rhs))]
|
||||
[(struct ast:expr:return (_ body))
|
||||
(build-unwanted-type-syntax-expression body)]
|
||||
[(struct ast:expr:tuple/select (_ _ arg))
|
||||
(build-unwanted-type-syntax-expression arg)]
|
||||
[(struct ast:expr:tuple (_ args))
|
||||
(map build-unwanted-type-syntax-expression args)]
|
||||
[(struct ast:expr:member (_ obj _ _ _))
|
||||
(if (ast:expr? obj)
|
||||
(build-unwanted-type-syntax-expression obj)
|
||||
(list))]
|
||||
[(struct ast:expr:new (_ obj type args))
|
||||
(list (build-unwanted-type-syntax-expression obj)
|
||||
(translate-type-for-syntax type)
|
||||
(map (lambda (a)
|
||||
(build-unwanted-type-syntax-expression (ast:named/arg-actual a)))
|
||||
args))]
|
||||
;; here are the two cases where the type already appears in the compiled code
|
||||
[(struct ast:expr:cast (_ obj _))
|
||||
(build-unwanted-type-syntax-expression obj)]
|
||||
[(struct ast:expr:isa (_ obj _))
|
||||
(build-unwanted-type-syntax-expression obj)]
|
||||
[(struct ast:expr:unary/op (_ _ _ _ arg))
|
||||
(build-unwanted-type-syntax-expression arg)]
|
||||
[(struct ast:expr:binary/op (_ _ _ _ larg rarg))
|
||||
(list (build-unwanted-type-syntax-expression larg)
|
||||
(build-unwanted-type-syntax-expression rarg))]
|
||||
[(struct ast:expr:if (_ cond then else))
|
||||
(list (build-unwanted-type-syntax-expression cond)
|
||||
(build-unwanted-type-syntax-expression then)
|
||||
(build-unwanted-type-syntax-expression else))]
|
||||
[(struct ast:expr:cond (_ clauses else))
|
||||
(list (map (lambda (c)
|
||||
(list (build-unwanted-type-syntax-expression (ast:cond/clause-test c))
|
||||
(build-unwanted-type-syntax-expression (ast:cond/clause-result c))))
|
||||
clauses)
|
||||
(if else (build-unwanted-type-syntax-expression else) '()))]
|
||||
[else '()]))
|
||||
|
||||
;; Yes, this is just part of the hack that gives us Check Syntax-correctness on all the types that
|
||||
;; are not otherwise used in the compiled code.
|
||||
(provide translate-type-for-syntax)
|
||||
(define (translate-type-for-syntax type)
|
||||
(define (real-translation type)
|
||||
(match type
|
||||
[(struct ast:type:object:iface (stx name))
|
||||
(translate-iface-name type)]
|
||||
[(struct ast:type:object:any (stx))
|
||||
(translate-iface-name type)]
|
||||
[(struct ast:type:primitive (stx name))
|
||||
'()]
|
||||
[(struct ast:type:function (stx arg ret))
|
||||
(list (real-translation arg)
|
||||
(real-translation ret))]
|
||||
[(struct ast:type:tuple (stx args))
|
||||
(map real-translation args)]))
|
||||
(real-translation type))
|
||||
|
||||
)
|
||||
|
|
@ -1,139 +0,0 @@
|
|||
(module translate-utils mzscheme
|
||||
|
||||
(require (all-except (lib "list.ss" "srfi" "1") any)
|
||||
(lib "contract.ss")
|
||||
"../../ast.ss"
|
||||
"../../parameters.ss"
|
||||
"../../tenv.ss"
|
||||
"translate-parameters.ss")
|
||||
|
||||
(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 (ast:formal-name (car args)))
|
||||
body)
|
||||
(wrapping-syntax (at #f 'arg-tuple)
|
||||
`(let-values ([,(map (lambda (a)
|
||||
(at-ctxt (ast: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-mixin-name translate-method-name
|
||||
translate-field-getter-name translate-field-setter-name)
|
||||
(define (translate-iface-name type)
|
||||
(let ([name (if (ast:type:object:any? type)
|
||||
(datum->syntax-object #f 'Any (ast-syntax type))
|
||||
(ast:type:object: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-mixin-name mixin)
|
||||
(at mixin (string->symbol (string-append (symbol->string (syntax-e mixin)) "-mixin"))))
|
||||
|
||||
(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 name arg)
|
||||
(if (current-mixin-argument-type)
|
||||
(let ([type-entry (get-type-entry (current-mixin-argument-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 (current-mixin-argument-type) name) ,arg)
|
||||
`(lambda (arg-tuple)
|
||||
(super ,(translate-method-name (current-mixin-argument-type) name) arg-tuple)))
|
||||
(if arg
|
||||
`(,(at-ctxt name) ,arg)
|
||||
(at-ctxt name))))
|
||||
(if arg
|
||||
`(,(at-ctxt name) ,arg)
|
||||
(at-ctxt name))))
|
||||
|
||||
(define (translate-static-field-getter name)
|
||||
(if (current-mixin-argument-type)
|
||||
(let ([type-entry (get-type-entry (current-mixin-argument-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 (current-mixin-argument-type) name) ,void-value)
|
||||
(at-ctxt name)))
|
||||
(at-ctxt name)))
|
||||
|
||||
(define (translate-static-field-setter name arg)
|
||||
(if (current-mixin-argument-type)
|
||||
(let ([type-entry (get-type-entry (current-mixin-argument-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 (current-mixin-argument-type) name) ,arg)
|
||||
`(begin (set! ,(at-ctxt name) ,arg)
|
||||
,void-value)))
|
||||
`(begin (set! ,(at-ctxt name) ,arg)
|
||||
,void-value)))
|
||||
|
||||
)
|
||||
|
|
@ -1,159 +0,0 @@
|
|||
(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-parameters.ss"
|
||||
"translate-unwanted-types.ss"
|
||||
"translate-utils.ss")
|
||||
|
||||
(provide/contract [translate (((listof ast:defn?))
|
||||
. ->* .
|
||||
(any/c (listof (syntax/c any/c))))]
|
||||
[translate-defn (ast:defn?
|
||||
. -> .
|
||||
(syntax/c any/c))])
|
||||
(define (translate defns)
|
||||
(let loop ([defns-to-go defns]
|
||||
[syntaxes '()])
|
||||
(cond
|
||||
[(null? defns-to-go)
|
||||
(values (build-unwanted-type-syntax defns)
|
||||
( reverse syntaxes))]
|
||||
[(ast:defn:subclass? (car defns-to-go))
|
||||
(let ([mixin (find (lambda (d)
|
||||
(and (ast:defn:mixin? d)
|
||||
(tenv-key=? (ast:defn:mixin-name d)
|
||||
(ast:defn:subclass-mixin (car defns-to-go)))))
|
||||
defns)])
|
||||
(loop (cdr defns-to-go) (cons (translate-subclass mixin (car defns-to-go)) syntaxes)))]
|
||||
[else
|
||||
(loop (cdr defns-to-go) (cons (translate-defn (car defns-to-go)) syntaxes))])))
|
||||
|
||||
(define (translate-iface-member-names name)
|
||||
(let* ([iface (make-iface-type name name)]
|
||||
[type-entry (get-type-entry iface)])
|
||||
(let loop ([members (append (tenv:type-members type-entry) (tenv:type-inherited type-entry))]
|
||||
[names '()])
|
||||
(if (null? members)
|
||||
(reverse names)
|
||||
(if (ast:type:method? (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 defn)
|
||||
(match defn
|
||||
[(struct ast:defn:binding (stx names types value))
|
||||
(let-values ([(bound-names body) (translate-binding-clause names (translate-expression value))])
|
||||
(at stx `(define-values ,bound-names ,body)))]
|
||||
[(struct ast:defn:function (stx name type args body))
|
||||
(translate-function stx name args (translate-expression body))]
|
||||
[(struct ast:defn: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-iface-member-names name))))]
|
||||
[(struct ast:defn:class (stx name selftype _ impls inits members exports))
|
||||
(at stx `(define ,(translate-class-name name)
|
||||
(class* object% ,(map translate-iface-name impls)
|
||||
(inspect #f)
|
||||
,(translate-inits inits)
|
||||
,@(map translate-member members)
|
||||
,@(translate-class-exports exports)
|
||||
,(translate-impl-method impls)
|
||||
,(translate-formatter name members)
|
||||
(super-new))))]
|
||||
[(struct ast:defn:mixin (stx name _ _ _ _ _ _ _ _ _ _))
|
||||
;; just a dummy definition to get the bindings set up correctly
|
||||
(at stx `(define ,(translate-mixin-name name)
|
||||
'()))]
|
||||
[else (raise-read-error-with-stx
|
||||
"Haven't translated that type of definition yet."
|
||||
(ast-syntax defn))]))
|
||||
|
||||
(define (translate-subclass mixin-defn defn)
|
||||
(match (list mixin-defn defn)
|
||||
[(list (struct ast:defn:mixin (mstx mname selftype arg-type _ impls inits withs super-new members-before members-after exports))
|
||||
(struct ast:defn:subclass (stx name base mixin)))
|
||||
(parameterize ([current-mixin-argument-type arg-type])
|
||||
(let* ([base-entry (get-class-entry 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 translate-member members-before)
|
||||
,(translate-super-new super-new)
|
||||
,@(map translate-member members-after)
|
||||
,@(translate-subclass-exports base-types exports)
|
||||
,(translate-impl-method impls)
|
||||
,(translate-formatter name (append members-before members-after)))))))]))
|
||||
|
||||
(define (translate-impl-method impls)
|
||||
(let ([right-define (if (current-mixin-argument-type) 'define/override 'define/public)])
|
||||
`(,right-define (implements? iface)
|
||||
(mz:ormap (lambda (i)
|
||||
(interface-extension? i iface))
|
||||
(list* ,@(map translate-iface-name impls) '())))))
|
||||
|
||||
(define (translate-formatter name members)
|
||||
(let ([right-define (if (current-mixin-argument-type) 'define/override 'define/public)])
|
||||
`(begin
|
||||
(,right-define (format-class-name)
|
||||
,(format "~a" (syntax-e name)))
|
||||
(,right-define (format-class renderer indent)
|
||||
(format "~a {~a}"
|
||||
(format-class-name)
|
||||
,(cons 'string-append
|
||||
(let ([printable-members (filter (lambda (m)
|
||||
(not (ast:class/member:method? m)))
|
||||
members)]
|
||||
[printable-smembers (if (current-mixin-argument-type)
|
||||
(filter-map (lambda (m)
|
||||
(if (not (ast:type:method? (tenv:member-type m)))
|
||||
(tenv:member-name m)
|
||||
#f))
|
||||
(tenv:type-members (get-type-entry (current-mixin-argument-type))))
|
||||
'())]
|
||||
;; how much more do we want the members indented? Let's try 2 spaces more.
|
||||
[indent-delta 2])
|
||||
(if (and (null? printable-members)
|
||||
(null? printable-smembers))
|
||||
'("")
|
||||
(fold-right (lambda (m l)
|
||||
(list* "\n" (translate-super-member-formatter m indent-delta) l))
|
||||
(fold-right (lambda (m l)
|
||||
(list* "\n" (translate-member-formatter m indent-delta) l))
|
||||
'("\n" (make-string indent #\space))
|
||||
printable-members)
|
||||
printable-smembers)))))))))
|
||||
|
||||
(define (translate-member-formatter member indent-delta)
|
||||
(let ([name (ast:class/member-name member)])
|
||||
`(format "~a~a = ~a;"
|
||||
(make-string (+ indent ,indent-delta) #\space)
|
||||
(quote ,(syntax-e name))
|
||||
;; the 3 is for " = "
|
||||
(renderer ,name (+ indent ,(+ indent-delta (string-length (symbol->string (syntax-e name))) 3))))))
|
||||
|
||||
(define (translate-super-member-formatter name indent-delta)
|
||||
`(format "~a~a = ~a;"
|
||||
(make-string (+ indent ,indent-delta) #\space)
|
||||
(quote ,(syntax-e name))
|
||||
;; as before, the 3 is for " = "
|
||||
(renderer ,(translate-static-field-getter name)
|
||||
(+ indent ,(+ indent-delta (string-length (symbol->string (syntax-e name))) 3)))))
|
||||
)
|
||||
|
|
@ -1,48 +0,0 @@
|
|||
(module program-tests mzscheme
|
||||
|
||||
(require (lib "contract.ss")
|
||||
(planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
|
||||
(prefix srfi1: (lib "1.ss" "srfi"))
|
||||
"../../top.ss"
|
||||
)
|
||||
|
||||
(provide/contract [program-tests test-suite?])
|
||||
|
||||
(define program-files
|
||||
(list "examples/BoundedStack.honu"
|
||||
"examples/EvenOddClass.honu"
|
||||
"examples/List.honu"
|
||||
"examples/Y.honu"
|
||||
"examples/bind-tup-top.honu"
|
||||
"examples/cond-test.honu"
|
||||
"examples/even-odd.honu"
|
||||
"examples/exprs.honu"
|
||||
"examples/point.honu"
|
||||
"examples/struct.honu"
|
||||
"examples/tup-bind.honu"
|
||||
; "examples/types-error.honu"
|
||||
"examples/types.honu"
|
||||
; "examples/nonexistent.honu"
|
||||
))
|
||||
|
||||
(define-assertion (assert-test-file program-file)
|
||||
(let* ([results (test-file program-file)]
|
||||
[indices (srfi1:iota (length results))]
|
||||
[errors
|
||||
(srfi1:filter-map (lambda (result index) (if result #f index))
|
||||
results indices)])
|
||||
(if (null? errors)
|
||||
#t
|
||||
(with-assertion-info
|
||||
(['error-indices errors])
|
||||
(fail-assertion)))))
|
||||
|
||||
(define (make-program-test program-file)
|
||||
(make-test-case program-file (assert-test-file program-file)))
|
||||
|
||||
(define program-tests
|
||||
(apply make-test-suite
|
||||
"Honu"
|
||||
(map make-program-test program-files)))
|
||||
|
||||
)
|
||||
|
|
@ -1,38 +0,0 @@
|
|||
(module typechecker-tests mzscheme
|
||||
|
||||
(require (lib "contract.ss")
|
||||
(planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
|
||||
(prefix srfi13: (lib "13.ss" "srfi"))
|
||||
"../typechecker/typecheck-expression.ss"
|
||||
"../../tenv.ss"
|
||||
"../../ast.ss"
|
||||
)
|
||||
|
||||
(provide/contract [typechecker-tests test-suite?])
|
||||
|
||||
(define non-void-in-sequence-test
|
||||
(make-test-case "Non-void expression in a sequence"
|
||||
(assert-exn
|
||||
(lambda (exn)
|
||||
(srfi13:string-contains (exn-message exn) "void"))
|
||||
(lambda ()
|
||||
(typecheck-expression
|
||||
(wrap-lenv) #f
|
||||
(make-ast:expr:sequence
|
||||
#'()
|
||||
(list (make-ast:expr:literal #'() (make-ast:type:primitive #'() 'int) #'5))
|
||||
(make-ast:expr:literal #'() (make-ast:type:primitive #'() 'int) #'4)))))))
|
||||
|
||||
(define error-message-tests
|
||||
(make-test-suite
|
||||
"Error messages"
|
||||
non-void-in-sequence-test
|
||||
))
|
||||
|
||||
(define typechecker-tests
|
||||
(make-test-suite
|
||||
"Typechecker"
|
||||
error-message-tests
|
||||
))
|
||||
|
||||
)
|
||||
|
|
@ -1,100 +0,0 @@
|
|||
(module general mzscheme
|
||||
|
||||
(require (prefix srfi1: (lib "list.ss" "srfi" "1"))
|
||||
(lib "list.ss"))
|
||||
|
||||
(provide fold-with-rest
|
||||
get-first-non-unique-name
|
||||
map-and-fold
|
||||
map-two-values
|
||||
map-values
|
||||
partition-first
|
||||
unique?
|
||||
curry
|
||||
false?)
|
||||
|
||||
(define (map-values-rev-accs f lists accs)
|
||||
(cond [(andmap empty? lists) (apply values (map reverse accs))]
|
||||
[(ormap empty? lists) (error 'map-values "expects lists of equal length")]
|
||||
[else (call-with-values (lambda () (apply f (map first lists)))
|
||||
(lambda vs (map-values-rev-accs f (map rest lists) (map cons vs accs))))]))
|
||||
|
||||
(define (map-values f . lists)
|
||||
(cond [(empty? lists) (error 'map-values "expects 1 or more input lists")]
|
||||
[(ormap empty? lists) (error 'map-values "expects non-empty lists")]
|
||||
[else
|
||||
(call-with-values (lambda () (apply f (map first lists)))
|
||||
(lambda vs (map-values-rev-accs f (map rest lists) (map list vs))))]))
|
||||
|
||||
(define (identifier<? a b)
|
||||
(string<? (symbol->string (syntax-e a))
|
||||
(symbol->string (syntax-e b))))
|
||||
|
||||
(define (get-first-non-unique-name lst)
|
||||
(let loop ([lst (quicksort lst identifier<?)])
|
||||
(cond
|
||||
[(null? lst) #f]
|
||||
[(null? (cdr lst)) #f]
|
||||
[(bound-identifier=? (car lst) (cadr lst))
|
||||
;; since quicksort isn't stable, just return the first
|
||||
(car lst)]
|
||||
[else #f])))
|
||||
|
||||
(define (fold-with-rest f init l)
|
||||
(if (null? l)
|
||||
init
|
||||
(fold-with-rest f (f (car l) (cdr l) init) (cdr l))))
|
||||
|
||||
(define (unique? cs)
|
||||
(fold-with-rest (lambda (c cs acc)
|
||||
(and acc
|
||||
(not (member c cs))))
|
||||
#t cs))
|
||||
|
||||
(define (get-names ds p f)
|
||||
(srfi1:filter-map (lambda (defn)
|
||||
(and (p defn)
|
||||
(f defn)))
|
||||
ds))
|
||||
|
||||
(define (map-and-fold f i l)
|
||||
(let loop ((l l)
|
||||
(mapped '())
|
||||
(folded i))
|
||||
(if (null? l)
|
||||
(values (reverse mapped) folded)
|
||||
(let-values ([(res folded) (f (car l) folded)])
|
||||
(loop (cdr l)
|
||||
(cons res mapped)
|
||||
folded)))))
|
||||
|
||||
(define (map-two-values f . lists)
|
||||
(let loop ((lists lists)
|
||||
(map1 '())
|
||||
(map2 '()))
|
||||
(if (ormap empty? lists)
|
||||
(values (reverse map1) (reverse map2))
|
||||
(let-values ([(m1 m2) (apply f (map car lists))])
|
||||
(loop (map cdr lists)
|
||||
(cons m1 map1)
|
||||
(cons m2 map2))))))
|
||||
|
||||
(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))])))
|
||||
|
||||
(define (curry f . args)
|
||||
(lambda rest
|
||||
(apply f (append args rest))))
|
||||
|
||||
(define (false? v)
|
||||
(eq? v #f))
|
||||
|
||||
)
|
||||
|
|
@ -1,112 +0,0 @@
|
|||
(module test mzscheme
|
||||
|
||||
(require (lib "list.ss"))
|
||||
|
||||
#|
|
||||
Test case and test suite macros:
|
||||
|
||||
Expressions:
|
||||
(test-case NAME EXPR PREDICATE)
|
||||
(test-suite NAME CASE ...)
|
||||
|
||||
Definitions:
|
||||
(define-test-case NAME EXPR PREDICATE)
|
||||
(define-test-suite NAME CASES ...)
|
||||
|#
|
||||
|
||||
(define (report? obj) (or (void? obj) (list? obj)))
|
||||
|
||||
(define (exn-sexp exn)
|
||||
`(error ,(exn-message exn)))
|
||||
|
||||
(define-for-syntax (syntax-rest stx)
|
||||
(syntax-case stx () [(_ . REST) #'REST]))
|
||||
|
||||
(define-for-syntax (translate-predicate stx)
|
||||
(syntax-case stx (equal: error: pred:)
|
||||
[(equal: VALUE)
|
||||
#`(lambda (name expr thunk)
|
||||
(lambda ()
|
||||
(with-handlers ([(lambda (exn) #t)
|
||||
(lambda (exn) `(,name : ,expr raised ,(exn-sexp exn)))])
|
||||
(let* ([result (thunk)])
|
||||
(with-handlers ([(lambda (exn) #t)
|
||||
(lambda (exn)
|
||||
`(,name : expected value VALUE raised ,(exn-sexp exn)))])
|
||||
(let* ([expected VALUE])
|
||||
(if (equal? result expected)
|
||||
(void)
|
||||
`(,name : ,expr = ,result != ,expected))))))))]
|
||||
[error:
|
||||
#`(lambda (name expr thunk)
|
||||
(lambda ()
|
||||
(with-handlers ([(lambda (exn) #t) (lambda (exn) (void))])
|
||||
(let* ([result (thunk)])
|
||||
`(,name : ,expr = ,result but expected error)))))]
|
||||
[(error: PRED)
|
||||
#`(lambda (name expr thunk)
|
||||
(lambda ()
|
||||
(with-handlers
|
||||
([(lambda (exn) #t)
|
||||
(lambda (exn)
|
||||
(with-handlers
|
||||
([(lambda (exn) #t)
|
||||
(lambda (exn)
|
||||
`(,name : predicate PRED raised ,(exn-sexp exn)))])
|
||||
(if (PRED exn)
|
||||
(void)
|
||||
`(,name : ,expr raised ,(exn-sexp exn) which failed PRED))))])
|
||||
(let* ([result (thunk)])
|
||||
`(,name : ,expr = ,result but expected error)))))]
|
||||
[(pred: PRED)
|
||||
#`(lambda (name expr thunk)
|
||||
(lambda ()
|
||||
(with-handlers ([(lambda (exn) #t)
|
||||
(lambda (exn) `(,name : ,expr raised ,(exn-sexp exn)))])
|
||||
(let* ([result (thunk)])
|
||||
(with-handlers ([(lambda (exn) #t)
|
||||
(lambda (exn)
|
||||
`(,name : predicate PRED raised ,(exn-sexp exn)))])
|
||||
(if (PRED result)
|
||||
(void)
|
||||
`(,name : ,expr = ,result failed PRED)))))))]
|
||||
))
|
||||
|
||||
(define-for-syntax (translate-test-case stx)
|
||||
(syntax-case stx ()
|
||||
[(NAME EXPR PREDICATE)
|
||||
#`(#,(translate-predicate #'PREDICATE) 'NAME 'EXPR (lambda () EXPR))]))
|
||||
|
||||
(define-for-syntax (translate-test-suite stx)
|
||||
(syntax-case stx ()
|
||||
[(NAME CASE ...)
|
||||
#`(let* ([cases (list CASE ...)])
|
||||
(lambda ()
|
||||
(let* ([reports (map (lambda (case) (case)) cases)]
|
||||
[errors (filter (lambda (report) (not (void? report))) reports)])
|
||||
(cond [(null? errors) (void)]
|
||||
[(= (length errors) 1) (cons 'NAME (first errors))]
|
||||
[else (cons 'NAME (cons ': errors))]))))]))
|
||||
|
||||
(define-for-syntax (translate-define-test-case stx)
|
||||
(syntax-case stx ()
|
||||
[(NAME . _) #`(define NAME #,(translate-test-case stx))]))
|
||||
|
||||
(define-for-syntax (translate-define-test-suite stx)
|
||||
(syntax-case stx ()
|
||||
[(NAME . _) #`(define NAME #,(translate-test-suite stx))]))
|
||||
|
||||
(define-syntax (test-case stx)
|
||||
(translate-test-case (syntax-rest stx)))
|
||||
|
||||
(define-syntax (test-suite stx)
|
||||
(translate-test-suite (syntax-rest stx)))
|
||||
|
||||
(define-syntax (define-test-case stx)
|
||||
(translate-define-test-case (syntax-rest stx)))
|
||||
|
||||
(define-syntax (define-test-suite stx)
|
||||
(translate-define-test-suite (syntax-rest stx)))
|
||||
|
||||
(provide report? test-case test-suite define-test-case define-test-suite)
|
||||
)
|
||||
|
|
@ -1,279 +0,0 @@
|
|||
(module type-utils mzscheme
|
||||
(require (prefix srfi1: (lib "list.ss" "srfi" "1"))
|
||||
(lib "contract.ss")
|
||||
(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-ast:type:object:null stx))
|
||||
(define (make-any-type stx)
|
||||
(make-ast:type:object:any stx))
|
||||
;; if you want non-strict void context method bodies, change this to
|
||||
;; (make-ast:type:top stx)
|
||||
;; if you want to make sure that a value of "void" type is returned, do
|
||||
;; (make-ast:type:tuple stx '())
|
||||
(define (make-void-type stx)
|
||||
(make-ast:type:tuple stx (list)))
|
||||
(define (make-error-type stx)
|
||||
(make-ast:type:bot stx))
|
||||
(define (make-top-type stx)
|
||||
(make-ast:type:top stx))
|
||||
(define (make-bottom-type stx)
|
||||
(make-ast: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-ast:type:tuple stx args)))
|
||||
(define (make-func-type stx arg ret)
|
||||
(make-ast:type:function stx arg ret))
|
||||
(define (make-method-type stx disp arg ret)
|
||||
(make-ast:type:method stx disp arg ret))
|
||||
(define (make-iface-type stx name)
|
||||
(make-ast:type:object:iface stx name))
|
||||
(define (make-int-type stx)
|
||||
(make-ast:type:primitive stx 'int))
|
||||
(define (make-string-type stx)
|
||||
(make-ast:type:primitive stx 'string))
|
||||
(define (make-char-type stx)
|
||||
(make-ast:type:primitive stx 'char))
|
||||
(define (make-bool-type stx)
|
||||
(make-ast:type:primitive stx 'bool))
|
||||
(define (make-float-type stx)
|
||||
(make-ast:type:primitive stx 'float))
|
||||
|
||||
(provide printable-type)
|
||||
(define (printable-type t)
|
||||
(match t
|
||||
[(struct ast:type:top (_))
|
||||
"(no info)"]
|
||||
[(struct ast:type:bot (_))
|
||||
"'a"]
|
||||
[(struct ast:type:primitive (_ name))
|
||||
(symbol->string name)]
|
||||
[(struct ast:type:tuple (_ args))
|
||||
(if (null? args)
|
||||
"void"
|
||||
(string-append "<"
|
||||
(srfi1:fold (lambda (t i)
|
||||
(string-append i ", " (printable-type t)))
|
||||
(printable-type (car args))
|
||||
(cdr args))
|
||||
">"))]
|
||||
[(struct ast:type:partial/tuple (_ slot type))
|
||||
(format "tuple of size >= ~a where the type in slot ~a is ~a"
|
||||
slot slot (printable-type type))]
|
||||
[(struct ast:type:function (_ arg ret))
|
||||
(if (ast:type:function? arg)
|
||||
(string-append "<" (printable-type arg) "> -> " (printable-type ret))
|
||||
(string-append (printable-type arg) " -> " (printable-type ret)))]
|
||||
[(struct ast:type:method (_ disp arg ret))
|
||||
(string-append "[" (printable-type disp) "] "
|
||||
(printable-type arg) " -> " (printable-type ret))]
|
||||
[(struct ast:type:object:iface (_ name))
|
||||
(symbol->string (syntax-e name))]
|
||||
[(struct ast:type:object:any (_))
|
||||
"Any"]
|
||||
[(struct ast:type:object:null (_))
|
||||
"null"]))
|
||||
|
||||
(provide type-valid?)
|
||||
(define (type-valid? t)
|
||||
(match t
|
||||
[(struct ast:type:object:any (_)) #t]
|
||||
[(struct ast:type:primitive (stx name))
|
||||
(case name
|
||||
[(int float char string bool) #t]
|
||||
[else (raise-read-error-with-stx
|
||||
(format "Unexpected primitive type ~a" name)
|
||||
stx)])]
|
||||
[(struct ast:type:object:iface (stx name))
|
||||
(let ([tentry (get-tenv-entry name)])
|
||||
(and tentry (tenv:type? tentry)))]
|
||||
[(struct ast:type:tuple (_ args))
|
||||
(andmap (lambda (t)
|
||||
(type-valid? t))
|
||||
args)]
|
||||
[(struct ast:type:function (_ arg ret))
|
||||
(and (type-valid? arg)
|
||||
(type-valid? ret))]
|
||||
[(struct ast:type:method (_ disp arg ret))
|
||||
(and (type-valid? disp)
|
||||
(type-valid? arg)
|
||||
(type-valid? ret))]))
|
||||
|
||||
(provide type-equal?)
|
||||
(define (type-equal? t1 t2)
|
||||
(cond
|
||||
;; first all the easy ones
|
||||
[(and (ast:type:top? t1)
|
||||
(ast:type:top? t2))
|
||||
#t]
|
||||
[(and (ast:type:bot? t1)
|
||||
(ast:type:bot? t2))
|
||||
#t]
|
||||
[(and (ast:type:object:any? t1)
|
||||
(ast:type:object:any? t2))
|
||||
#t]
|
||||
[(and (ast:type:object:null? t1)
|
||||
(ast:type:object:null? t2))
|
||||
#t]
|
||||
;; primitive types are equal if their names are equal.
|
||||
[(and (ast:type:primitive? t1)
|
||||
(ast:type:primitive? t2))
|
||||
(eqv? (ast:type:primitive-name t1)
|
||||
(ast:type:primitive-name t2))]
|
||||
;; same for ifaces
|
||||
[(and (ast:type:object:iface? t1)
|
||||
(ast:type:object:iface? t2))
|
||||
(tenv-key=? (ast:type:object:iface-name t1)
|
||||
(ast:type:object:iface-name t2))]
|
||||
;; function, dispatch types are equal if their component types are.
|
||||
[(and (ast:type:function? t1)
|
||||
(ast:type:function? t2))
|
||||
(and (type-equal? (ast:type:function-input t1) (ast:type:function-input t2))
|
||||
(type-equal? (ast:type:function-output t1) (ast:type:function-output t2)))]
|
||||
[(and (ast:type:method? t1)
|
||||
(ast:type:method? t2))
|
||||
(and (type-equal? (ast:type:method-receiver t1) (ast:type:method-receiver t2))
|
||||
(type-equal? (ast:type:method-input t1) (ast:type:method-input t2))
|
||||
(type-equal? (ast:type:method-output t1) (ast:type:method-output t2)))]
|
||||
;; tuple types are equal if they have the same number of components and
|
||||
;; their components are pairwise equal
|
||||
[(and (ast:type:tuple? t1)
|
||||
(ast:type:tuple? t2))
|
||||
(let ([t1-args (ast:type:tuple-elems t1)]
|
||||
[t2-args (ast:type:tuple-elems t2)])
|
||||
(and (= (length t1-args) (length t2-args))
|
||||
(andmap (lambda (t1 t2)
|
||||
(type-equal? 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 (ast:type:partial/tuple? t1)
|
||||
(ast:type:partial/tuple? t2))
|
||||
(and (= (ast:type:partial/tuple-position t1) (ast:type:partial/tuple-position t2))
|
||||
(type-equal? (ast:type:partial/tuple-elem t1) (ast:type:partial/tuple-elem t2)))]
|
||||
[else #f]))
|
||||
|
||||
;; assumes either Any or some type identifier
|
||||
(define (get-type-name t)
|
||||
(cond
|
||||
[(ast:type:object:iface? t)
|
||||
(ast:type:object:iface-name t)]
|
||||
[(ast:type:object:any? t)
|
||||
#'Any]))
|
||||
|
||||
;; is t1 a _direct_ subtype of t2?
|
||||
(define (Subtype_P t1 t2)
|
||||
(let ([type-entry (get-type-entry t1)])
|
||||
(match type-entry
|
||||
[(struct tenv:type (_ supers _ _))
|
||||
(let ([super-names (map get-type-name supers)])
|
||||
(srfi1:s:member (get-type-name t2) super-names tenv-key=?))])))
|
||||
|
||||
;; is t1 a (ref-trans-closed) subtype of t2?
|
||||
(provide <:_P)
|
||||
(define (<:_P t1 t2)
|
||||
(cond
|
||||
;; if t1 = t2, t1 <:_P t2
|
||||
[(type-equal? t1 t2)
|
||||
#t]
|
||||
;; if t1 is the bottom of the type lattice, then it trivially holds
|
||||
[(ast:type:bot? t1)
|
||||
#t]
|
||||
;; if t2 is the top of the type lattice, then it trivially holds
|
||||
[(ast:type:top? t2)
|
||||
#t]
|
||||
;; if t1 =/= t2 and they're both primitives, then they cannot be equal.
|
||||
[(and (ast:type:primitive? t1)
|
||||
(ast:type:primitive? t2))
|
||||
#f]
|
||||
;; for function types...
|
||||
[(and (ast:type:function? t1)
|
||||
(ast:type:function? t2))
|
||||
;; the arg is contravariant and the ret is covariant
|
||||
(and (<:_P (ast:type:function-input t2) (ast:type:function-input t1))
|
||||
(<:_P (ast:type:function-output t1) (ast:type:function-output t2)))]
|
||||
;; for dispatch types...
|
||||
[(and (ast:type:method? t1)
|
||||
(ast:type:method? t2))
|
||||
;; dispatch args must be co-, regular args contra-, and ret co-
|
||||
(and (<:_P (ast:type:method-receiver t1) (ast:type:method-receiver t2))
|
||||
(<:_P (ast:type:method-input t2) (ast:type:method-input t1))
|
||||
(<:_P (ast:type:method-output t1) (ast:type:method-output t2)))]
|
||||
;; for tuple types...
|
||||
[(and (ast:type:tuple? t1)
|
||||
(ast:type:tuple? t2))
|
||||
(let ([t1-args (ast:type:tuple-elems t1)]
|
||||
[t2-args (ast:type:tuple-elems 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 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 (ast:type:tuple? t1)
|
||||
(ast:type:partial/tuple? t2))
|
||||
(let ([t2-slot (ast:type:partial/tuple-position t2)]
|
||||
[t1-args (ast:type:tuple-elems t1)])
|
||||
(and (<= t2-slot (length t1-args))
|
||||
;; we have to subtract one from t2-slot because list-ref is zero-based
|
||||
(<:_P (list-ref t1-args (- t2-slot 1)) (ast:type:partial/tuple-elem t2))))]
|
||||
;; not sure if this is necessary. Hmm.
|
||||
[(and (ast:type:partial/tuple? t1)
|
||||
(ast:type:partial/tuple? t2))
|
||||
(and (= (ast:type:partial/tuple-position t1) (ast:type:partial/tuple-position t2))
|
||||
(<:_P (ast:type:partial/tuple-elem t1) (ast:type:partial/tuple-elem t2)))]
|
||||
;; the bottom of the iface lattice is <:_P either the iface-top or
|
||||
;; any iface
|
||||
[(and (ast:type:object:null? t1)
|
||||
(or (ast:type:object:iface? t2)
|
||||
(ast:type:object:any? t2)))
|
||||
#t]
|
||||
;; any iface type is <:_P the iface-top (iface-bot already caught above)
|
||||
[(and (ast:type:object:iface? t1)
|
||||
(ast:type:object:any? t2))
|
||||
#t]
|
||||
;; if two (non-equal) iface types...
|
||||
[(and (ast:type:object:iface? t1)
|
||||
(ast:type:object:iface? t2))
|
||||
(if (Subtype_P t1 t2)
|
||||
;; return true if it's a direct subtype relation
|
||||
#t
|
||||
(let ([type-entry (get-type-entry t1)])
|
||||
;; if any of the direct supertypes of t1 is a subtype of t2,
|
||||
;; then t1 is also
|
||||
(ormap (lambda (t)
|
||||
(<:_P t t2))
|
||||
(tenv:type-supers type-entry))))]
|
||||
[else #f]))
|
||||
|
||||
(provide/contract [type-member-names (ast:type? . -> . (listof identifier?))])
|
||||
(define (type-member-names type)
|
||||
(let* ([entry (get-type-entry type)])
|
||||
(map tenv:member-name
|
||||
(append (tenv:type-members entry)
|
||||
(tenv:type-inherited entry)))))
|
||||
|
||||
(provide iface-name)
|
||||
(define (iface-name type)
|
||||
(match type
|
||||
[(struct ast:type:object:any (_)) #'Any]
|
||||
[(struct ast:type:object:iface (_ name)) name]))
|
||||
|
||||
(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))
|
||||
)
|
||||
|
|
@ -1,273 +0,0 @@
|
|||
(module typecheck-class-utils mzscheme
|
||||
|
||||
(require (lib "list.ss" "srfi" "1")
|
||||
(lib "plt-match.ss")
|
||||
(lib "struct.ss")
|
||||
"../../ast.ss"
|
||||
"../../readerr.ss"
|
||||
"../../tenv.ss"
|
||||
"../tools/general.ss"
|
||||
"typecheck-expression.ss"
|
||||
"typecheck-parameters.ss"
|
||||
"type-utils.ss")
|
||||
|
||||
(provide extend-lenv-with-type-members typecheck-members typecheck-supernew typecheck-exports)
|
||||
|
||||
(define (typecheck-exports lenv selftype init-impls exports)
|
||||
(let loop ([impls init-impls]
|
||||
[exports exports])
|
||||
(cond
|
||||
[(and (null? exports)
|
||||
(null? impls))
|
||||
(if (not (s:member selftype init-impls (lambda (t1 t2) (type-equal? t1 t2))))
|
||||
(raise-read-error-with-stx
|
||||
(format "No export statement for self type ~a"
|
||||
(printable-type selftype))
|
||||
(ast-syntax 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)))
|
||||
(ast-syntax (car impls)))]
|
||||
[(null? impls)
|
||||
(if (s:member selftype init-impls (lambda (t1 t2) (type-equal? t1 t2)))
|
||||
(raise-read-error-with-stx
|
||||
(format "Extra export statement for unimplemented type ~a"
|
||||
(printable-type (ast:export-type (car exports))))
|
||||
(ast-syntax (car exports)))
|
||||
(let-values ([(matched non-matches) (partition-first (lambda (e)
|
||||
(type-equal? (ast:export-type e) selftype))
|
||||
exports)])
|
||||
(if (not matched)
|
||||
(raise-read-error-with-stx
|
||||
(format "No export statement for self type ~a"
|
||||
(printable-type selftype))
|
||||
(ast-syntax selftype))
|
||||
(let ([type-entry (get-type-entry selftype)])
|
||||
(typecheck-export lenv type-entry matched)
|
||||
(if (not (null? non-matches))
|
||||
(raise-read-error-with-stx
|
||||
(format "Extra export statement for unimplemented type ~a"
|
||||
(printable-type (ast:export-type (car exports))))
|
||||
(ast-syntax (car exports)))
|
||||
(void))))))]
|
||||
[else
|
||||
(let-values ([(matched non-matches) (partition-first (lambda (t)
|
||||
(type-equal? (ast:export-type (car exports)) t))
|
||||
impls)])
|
||||
(if (not matched)
|
||||
(raise-read-error-with-stx
|
||||
(format "Extra export statement for unimplemented type ~a"
|
||||
(ast:export-type (car exports)))
|
||||
(ast-syntax (car exports)))
|
||||
(let* ([type-entry (get-type-entry matched)]
|
||||
[export (car exports)])
|
||||
(typecheck-export lenv type-entry export)
|
||||
(loop non-matches (cdr exports)))))])))
|
||||
|
||||
(define (typecheck-export lenv type-entry export)
|
||||
;; make sure to use both defined members and inherited members here
|
||||
(let loop ([type-members (append (tenv:type-members type-entry) (tenv:type-inherited type-entry))]
|
||||
[export-binds (ast:export-members 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 (ast:export/member-external (car export-binds)))
|
||||
(printable-type (ast:export-type export)))
|
||||
(ast:export/member-external (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 (ast:export-type export)))
|
||||
(ast-syntax export))]
|
||||
[else
|
||||
(let-values ([(matched non-matches) (partition-first (lambda (m)
|
||||
(tenv-key=? (tenv:member-name m)
|
||||
(ast:export/member-external (car export-binds))))
|
||||
type-members)]
|
||||
[(lenv-entry) (lenv (ast:export/member-internal (car export-binds)))])
|
||||
(cond
|
||||
[(not lenv-entry)
|
||||
(raise-read-error-with-stx
|
||||
(format "No static member named ~a"
|
||||
(printable-key (ast:export/member-internal (car export-binds))))
|
||||
(ast:export/member-internal (car export-binds)))]
|
||||
[(not matched)
|
||||
(raise-read-error-with-stx
|
||||
(format "No member named ~a in type ~a"
|
||||
(printable-key (ast:export/member-external (car export-binds)))
|
||||
(printable-type (ast:export-type export)))
|
||||
(ast:export/member-external (car export-binds)))]
|
||||
;; if it's a method, then allow exporting a subtype
|
||||
[(ast:type:method? (tenv:member-type matched))
|
||||
(if (<:_P lenv-entry (tenv:member-type matched))
|
||||
(loop non-matches (cdr export-binds))
|
||||
(raise-read-error-with-stx
|
||||
(format "Exported static member ~a has type ~a which is not a subtype of ~a's type ~a"
|
||||
(printable-key (ast:export/member-internal (car export-binds)))
|
||||
(printable-type lenv-entry)
|
||||
(printable-key (tenv:member-name matched))
|
||||
(printable-type (tenv:member-type matched)))
|
||||
(ast:export/member-internal (car export-binds))))]
|
||||
;; for fields, we just do invariance until we get read-only fields
|
||||
[else
|
||||
(if (type-equal? lenv-entry (tenv:member-type matched))
|
||||
(loop non-matches (cdr export-binds))
|
||||
(raise-read-error-with-stx
|
||||
(format "Exported static member ~a has type ~a which is not the same type as ~a's type ~a"
|
||||
(printable-key (ast:export/member-internal (car export-binds)))
|
||||
(printable-type lenv-entry)
|
||||
(printable-key (tenv:member-name matched))
|
||||
(printable-type (tenv:member-type matched)))
|
||||
(ast:export/member-internal (car export-binds))))]))])))
|
||||
|
||||
|
||||
|
||||
(define (extend-lenv-with-type-members lenv type)
|
||||
(let ([type-entry (get-type-entry type)])
|
||||
(fold (lambda (m e)
|
||||
(extend-fenv (tenv:member-name m)
|
||||
(tenv:member-type m)
|
||||
e))
|
||||
lenv
|
||||
(tenv:type-members type-entry))))
|
||||
|
||||
(define (typecheck-supernew lenv withs supernew)
|
||||
(let loop ([withs withs]
|
||||
[args (ast:super-new-args supernew)]
|
||||
[checked-args '()])
|
||||
(cond
|
||||
[(and (null? withs)
|
||||
(null? args))
|
||||
(copy-struct ast:super-new supernew
|
||||
[ast: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 (ast:named/arg-name (car args))))
|
||||
(ast:named/arg-name (car args)))]
|
||||
[(null? args)
|
||||
(raise-read-error-with-stx
|
||||
(format "Expected init slot ~a not used as super arg"
|
||||
(printable-key (ast:formal-name (car withs))))
|
||||
(ast:formal-name (car withs)))]
|
||||
[else
|
||||
(let-values ([(matched non-matches) (partition-first (lambda (w)
|
||||
(tenv-key=? (ast:formal-name w)
|
||||
(ast:named/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 (ast:named/arg-name (car args))))
|
||||
(ast:named/arg-name (car args)))
|
||||
(let ([first-arg (car args)])
|
||||
(let-values ([(e1 t1) (typecheck-expression lenv
|
||||
(ast:formal-type matched)
|
||||
(ast:named/arg-actual first-arg))])
|
||||
(loop non-matches
|
||||
(cdr args)
|
||||
(cons (copy-struct ast:named/arg first-arg
|
||||
[ast:named/arg-actual e1])
|
||||
checked-args))))))])))
|
||||
|
||||
|
||||
(define (typecheck-members lenv selftype members)
|
||||
(let loop ([members members]
|
||||
[lenv lenv]
|
||||
[ret '()])
|
||||
(cond
|
||||
[(null? members)
|
||||
(values (reverse ret) lenv)]
|
||||
[(or (ast:class/member:field/formal? (car members))
|
||||
(ast:class/member:field? (car members)))
|
||||
(let ([member (typecheck-member lenv selftype (car members))])
|
||||
(loop (cdr members)
|
||||
(extend-fenv (get-class-member-name (car members))
|
||||
(get-class-member-type selftype (car members))
|
||||
lenv)
|
||||
(cons member ret)))]
|
||||
[(ast:class/member:method? (car members))
|
||||
(let-values ([(methods remainder) (span ast:class/member:method? members)])
|
||||
(let ([lenv (fold (lambda (m lenv)
|
||||
(extend-fenv (get-class-member-name m)
|
||||
(get-class-member-type selftype m)
|
||||
lenv))
|
||||
lenv
|
||||
methods)])
|
||||
(loop remainder
|
||||
lenv
|
||||
;; I only through the reverse in to keep the order the same.
|
||||
;; it doesn't really matter.
|
||||
(append (reverse (map (lambda (m)
|
||||
(typecheck-member lenv selftype m))
|
||||
methods))
|
||||
ret))))])))
|
||||
|
||||
(define (typecheck-member lenv selftype member)
|
||||
(match member
|
||||
[(struct ast:class/member:field/formal (stx name type value))
|
||||
(if (not (type-valid? type))
|
||||
(raise-read-error-with-stx
|
||||
"Type of init field is undefined"
|
||||
(ast-syntax type)))
|
||||
(if value
|
||||
(let-values ([(e1 t1) (typecheck-expression lenv type value)])
|
||||
(copy-struct ast:class/member:field/formal member
|
||||
[ast:class/member:field/formal-default e1]))
|
||||
member)]
|
||||
[(struct ast:class/member:field (stx name type value))
|
||||
(if (not (type-valid? type))
|
||||
(raise-read-error-with-stx
|
||||
"Type of field is undefined"
|
||||
(ast-syntax type)))
|
||||
(let-values ([(e1 t1) (typecheck-expression lenv type value)])
|
||||
(copy-struct ast:class/member:field member
|
||||
[ast:class/member:field-default e1]))]
|
||||
[(struct ast:class/member:method (stx name type args body))
|
||||
(if (not (type-valid? type))
|
||||
(raise-read-error-with-stx
|
||||
"Return type of method is undefined"
|
||||
(ast-syntax type)))
|
||||
(for-each (lambda (t)
|
||||
(if (not (type-valid? t))
|
||||
(raise-read-error-with-stx
|
||||
"Type of method argument is undefined"
|
||||
(ast-syntax t))))
|
||||
(map ast:formal-type args))
|
||||
(let-values ([(e1 t1) (parameterize ([current-return-type type])
|
||||
(typecheck-expression (fold (lambda (arg fenv)
|
||||
(extend-fenv (ast:formal-name arg)
|
||||
(ast:formal-type arg)
|
||||
fenv))
|
||||
lenv args)
|
||||
type body))])
|
||||
(copy-struct ast:class/member:method member
|
||||
[ast:class/member:method-body e1]))]))
|
||||
|
||||
(define (get-class-member-name member)
|
||||
(match member
|
||||
[(struct ast:class/member:field/formal (stx name type value)) name]
|
||||
[(struct ast:class/member:field (stx name type value)) name]
|
||||
[(struct ast:class/member:method (stx name type args body)) name]))
|
||||
|
||||
(define (get-class-member-type exptype member)
|
||||
(match member
|
||||
[(struct ast:class/member:field/formal (stx name type value))
|
||||
type]
|
||||
[(struct ast:class/member:field (stx name type value))
|
||||
type]
|
||||
[(struct ast:class/member:method (stx name type args body))
|
||||
(make-method-type stx exptype
|
||||
(make-tuple-type stx (map ast:formal-type args))
|
||||
type)]))
|
||||
|
||||
)
|
||||
|
|
@ -1,677 +0,0 @@
|
|||
(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"
|
||||
"../tools/general.ss"
|
||||
"typecheck-parameters.ss"
|
||||
"type-utils.ss")
|
||||
|
||||
(provide/contract [typecheck-expression ((((syntax/c symbol?) . -> . (union ast:type? false/c))
|
||||
(union ast:type? false/c)
|
||||
ast:expr?)
|
||||
. ->* .
|
||||
(ast:expr?
|
||||
ast:type?))])
|
||||
|
||||
;; lenv : ((syntax/c symbol?) . -> . (union ast:type false/c))
|
||||
;; lexical environment (includes top-level bindings and
|
||||
;; binding for #'this if inside class or mixin)
|
||||
;; ctype : (union ast:type? false/c)
|
||||
;; type of context for expression
|
||||
;; expr : ast:expr?
|
||||
;; expression to typecheck
|
||||
|
||||
(define (typecheck-expression lenv ctype expr)
|
||||
(match expr
|
||||
[(struct ast:expr:self (stx))
|
||||
(cond
|
||||
[(lenv #'this) => (lambda (t)
|
||||
(if (<:_P 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 ast:expr:tuple/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 lenv (make-ast:type:partial/tuple stx slot ctype) arg)])
|
||||
(if (not (ast:type:tuple? t1))
|
||||
(raise-read-error-with-stx "Tried to use select with non-tuple expression" stx))
|
||||
(let ([etype (list-ref (ast:type:tuple-elems t1) (- slot 1))])
|
||||
(values (copy-struct ast:expr:tuple/select expr
|
||||
[ast:expr:tuple/select-arg e1])
|
||||
etype)))]
|
||||
[(struct ast:expr:var (stx name))
|
||||
(cond
|
||||
[(lenv name) => (lambda (t)
|
||||
(if (<:_P 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 ast:expr:assign (stx lhs rhs))
|
||||
;; the context type for the lhs is a vacuous one.
|
||||
(let*-values ([(e1 t1) (typecheck-expression lenv (make-top-type (ast-syntax lhs)) lhs)]
|
||||
[(e2 t2) (typecheck-expression lenv t1 rhs)])
|
||||
(let ([void-type (make-void-type stx)])
|
||||
(if (<:_P void-type ctype)
|
||||
(values (copy-struct ast:expr:assign expr
|
||||
[ast:expr:assign-lhs e1]
|
||||
[ast:expr:assign-rhs e2])
|
||||
void-type)
|
||||
(raise-honu-type-error stx ctype void-type))))]
|
||||
[(struct ast:expr:apply (stx func arg))
|
||||
(let*-values ([(e1 t1) (typecheck-expression lenv (make-func-type (ast-syntax func)
|
||||
(make-bottom-type (ast-syntax func))
|
||||
ctype) func)]
|
||||
[(e2 t2) (typecheck-expression lenv (ast:type:function-input t1) arg)])
|
||||
(let ([ret-type (ast:type:function-output t1)])
|
||||
(if (<:_P ret-type ctype)
|
||||
(values (copy-struct ast:expr:apply expr
|
||||
[ast:expr:apply-func e1]
|
||||
[ast:expr:apply-arg e2])
|
||||
ret-type)
|
||||
(raise-honu-type-error stx ctype ret-type))))]
|
||||
[(struct ast:expr:literal (stx type value))
|
||||
(if (<:_P type ctype)
|
||||
(values expr type)
|
||||
(raise-honu-type-error stx ctype type))]
|
||||
[(struct ast:expr:unary/op (stx op op-stx _ arg))
|
||||
(case op
|
||||
[(not)
|
||||
(let-values ([(e1 t1) (typecheck-expression lenv (make-bool-type (ast-syntax arg)) arg)])
|
||||
(let ([ret-type (make-bool-type stx)])
|
||||
(if (<:_P ret-type ctype)
|
||||
(values (copy-struct ast:expr:unary/op expr
|
||||
[ast:expr:unary/op-rator-type t1]
|
||||
[ast:expr:unary/op-arg e1])
|
||||
ret-type)
|
||||
(raise-honu-type-error stx ctype ret-type))))]
|
||||
[(minus)
|
||||
(let-values ([(e1 t1) (typecheck-expression lenv (make-top-type (ast-syntax arg)) arg)])
|
||||
(if (not (ast:type:primitive? t1))
|
||||
(raise-read-error-with-stx
|
||||
"Invalid type for argument to unary minus"
|
||||
(ast-syntax arg))
|
||||
(let ([ret-type (case (ast:type:primitive-name t1)
|
||||
[(int) (make-int-type (ast-syntax arg))]
|
||||
[(float) (make-float-type (ast-syntax arg))]
|
||||
[else (raise-read-error-with-stx
|
||||
(format "Argument to unary minus must be int or float type, got ~a"
|
||||
(printable-type t1))
|
||||
(ast-syntax arg))])])
|
||||
(if (<:_P ret-type ctype)
|
||||
(values (copy-struct ast:expr:unary/op expr
|
||||
[ast:expr:unary/op-rator-type t1]
|
||||
[ast:expr:unary/op-arg e1])
|
||||
ret-type)
|
||||
(raise-honu-type-error stx ctype ret-type)))))]
|
||||
[else
|
||||
(raise-read-error-with-stx
|
||||
"Unknown operator"
|
||||
op-stx)])]
|
||||
[(struct ast:expr:binary/op (stx op op-stx _ larg rarg))
|
||||
(case op
|
||||
;; binary boolean operators
|
||||
[(or and)
|
||||
(let-values ([(e1 t1) (typecheck-expression lenv (make-bool-type (ast-syntax larg)) larg)]
|
||||
[(e2 t2) (typecheck-expression lenv (make-bool-type (ast-syntax rarg)) rarg)])
|
||||
(let ([ret-type (make-bool-type stx)])
|
||||
(if (<:_P ret-type ctype)
|
||||
(values (copy-struct ast:expr:binary/op expr
|
||||
[ast:expr:binary/op-rator-type (make-bool-type (ast-syntax larg))]
|
||||
[ast:expr:binary/op-left e1]
|
||||
[ast:expr:binary/op-right e2])
|
||||
ret-type)
|
||||
(raise-honu-type-error stx ctype ret-type))))]
|
||||
[(clseq)
|
||||
(let-values ([(e1 t1) (typecheck-expression lenv (make-any-type (ast-syntax larg)) larg)]
|
||||
[(e2 t2) (typecheck-expression lenv (make-any-type (ast-syntax rarg)) rarg)])
|
||||
(let ([ret-type (make-bool-type stx)])
|
||||
(if (<:_P ret-type ctype)
|
||||
(values (copy-struct ast:expr:binary/op expr
|
||||
[ast:expr:binary/op-rator-type (make-any-type (ast-syntax larg))]
|
||||
[ast:expr:binary/op-left e1]
|
||||
[ast:expr:binary/op-right e2])
|
||||
ret-type)
|
||||
(raise-honu-type-error stx ctype ret-type))))]
|
||||
[(equal neq)
|
||||
(let-values ([(e1 t1) (typecheck-expression lenv (make-top-type (ast-syntax larg)) larg)]
|
||||
[(e2 t2) (typecheck-expression lenv (make-top-type (ast-syntax rarg)) rarg)])
|
||||
(let ([ret-type (make-bool-type stx)]
|
||||
[arg-type (cond
|
||||
[(and (<:_P t1 (make-any-type (ast-syntax larg)))
|
||||
(<:_P t2 (make-any-type (ast-syntax rarg))))
|
||||
(make-any-type (ast-syntax larg))]
|
||||
[(check-prim-types-for-binop stx t1 t2) => (lambda (t) t)])])
|
||||
(if (<:_P ret-type ctype)
|
||||
(values (copy-struct ast:expr:binary/op expr
|
||||
[ast:expr:binary/op-rator-type arg-type]
|
||||
[ast:expr:binary/op-left e1]
|
||||
[ast:expr:binary/op-right e2])
|
||||
ret-type)
|
||||
(raise-honu-type-error stx ctype ret-type))))]
|
||||
[(le lt ge gt)
|
||||
(let-values ([(e1 t1) (typecheck-expression lenv (make-top-type (ast-syntax larg)) larg)]
|
||||
[(e2 t2) (typecheck-expression lenv (make-top-type (ast-syntax rarg)) rarg)])
|
||||
(let ([ret-type (make-bool-type stx)]
|
||||
[arg-type (check-prim-types-for-binop stx t1 t2)])
|
||||
(if (<:_P ret-type ctype)
|
||||
(values (copy-struct ast:expr:binary/op expr
|
||||
[ast:expr:binary/op-rator-type arg-type]
|
||||
[ast:expr:binary/op-left e1]
|
||||
[ast:expr:binary/op-right e2])
|
||||
ret-type)
|
||||
(raise-honu-type-error stx ctype ret-type))))]
|
||||
[(plus)
|
||||
(let-values ([(e1 t1) (typecheck-expression lenv (make-top-type (ast-syntax larg)) larg)]
|
||||
[(e2 t2) (typecheck-expression lenv (make-top-type (ast-syntax rarg)) rarg)])
|
||||
(let ([arg-type (check-prim-types-for-binop stx t1 t2)])
|
||||
(case (ast:type:primitive-name arg-type)
|
||||
[(int float string)
|
||||
(if (<:_P arg-type ctype)
|
||||
(values (copy-struct ast:expr:binary/op expr
|
||||
[ast:expr:binary/op-rator-type arg-type]
|
||||
[ast:expr:binary/op-left e1]
|
||||
[ast:expr:binary/op-right 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 lenv (make-top-type (ast-syntax larg)) larg)]
|
||||
[(e2 t2) (typecheck-expression lenv (make-top-type (ast-syntax rarg)) rarg)])
|
||||
(let ([arg-type (check-prim-types-for-binop stx t1 t2)])
|
||||
(case (ast:type:primitive-name arg-type)
|
||||
[(int float)
|
||||
(if (<:_P arg-type ctype)
|
||||
(values (copy-struct ast:expr:binary/op expr
|
||||
[ast:expr:binary/op-rator-type arg-type]
|
||||
[ast:expr:binary/op-left e1]
|
||||
[ast:expr:binary/op-right 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 lenv (make-int-type (ast-syntax larg)) larg)]
|
||||
[(e2 t2) (typecheck-expression lenv (make-int-type (ast-syntax rarg)) rarg)])
|
||||
(let ([ret-type (make-int-type stx)])
|
||||
(if (<:_P ret-type ctype)
|
||||
(values (copy-struct ast:expr:binary/op expr
|
||||
[ast:expr:binary/op-rator-type (make-int-type (ast-syntax larg))]
|
||||
[ast:expr:binary/op-left e1]
|
||||
[ast:expr:binary/op-right e2])
|
||||
ret-type)
|
||||
(raise-honu-type-error stx ctype ret-type))))]
|
||||
[else
|
||||
(raise-read-error-with-stx
|
||||
"Unknown operator"
|
||||
op-stx)])]
|
||||
[(struct ast:expr:function (stx ret-type args body))
|
||||
(if (not (type-valid? ret-type))
|
||||
(raise-read-error-with-stx
|
||||
"Return type of anonymous function is invalid"
|
||||
(ast-syntax ret-type)))
|
||||
(let ([conflicting-name (get-first-non-unique-name (map ast:formal-name args))])
|
||||
(if conflicting-name
|
||||
(raise-read-error-with-stx
|
||||
(format "Variable name ~a used more than once in function arguments"
|
||||
(printable-key conflicting-name))
|
||||
conflicting-name)))
|
||||
(for-each (lambda (t)
|
||||
(if (not (type-valid? t))
|
||||
(raise-read-error-with-stx
|
||||
"Type of argument of anonymous function is invalid"
|
||||
(ast-syntax t))))
|
||||
(map ast:formal-type args))
|
||||
;; 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 (ast:formal-name f)
|
||||
(ast:formal-type f)
|
||||
e))
|
||||
lenv args)])
|
||||
(let-values ([(body _) (parameterize ([current-return-type ret-type])
|
||||
(typecheck-expression body-lenv 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 ast:formal-type args)) ret-type)])
|
||||
(if (<:_P lam-type ctype)
|
||||
(values (copy-struct ast:expr:function expr
|
||||
[ast:expr:function-body body])
|
||||
lam-type)
|
||||
(raise-honu-type-error stx ctype lam-type)))))]
|
||||
[(struct ast:expr:if (stx test then else))
|
||||
(if else
|
||||
(let-values ([(e1 t1) (typecheck-expression lenv (make-bool-type (ast-syntax test)) test)]
|
||||
[(e2 t2) (typecheck-expression lenv ctype then)]
|
||||
[(e3 t3) (typecheck-expression lenv ctype else)])
|
||||
;; this should work, but I get the following:
|
||||
;; -- context expected 1 value, received 2 values: #<struct:ast:expr:if> #<struct:ast:type:primitive>
|
||||
;; 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 ast:expr:if expr
|
||||
;; [ast:expr:if-test e1]
|
||||
;; [ast:expr:if-then e2]
|
||||
;; [ast:expr: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 t2 t3)
|
||||
(values (copy-struct ast:expr:if expr
|
||||
[ast:expr:if-test e1]
|
||||
[ast:expr:if-then e2]
|
||||
[ast:expr:if-else e3])
|
||||
t3)]
|
||||
[(<:_P t3 t2)
|
||||
(values (copy-struct ast:expr:if expr
|
||||
[ast:expr:if-test e1]
|
||||
[ast:expr:if-then e2]
|
||||
[ast:expr: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 lenv (make-bool-type (ast-syntax test)) test)]
|
||||
[(e2 t2) (typecheck-expression lenv (make-void-type (ast-syntax then)) then)])
|
||||
(let ([ret-type (make-void-type stx)])
|
||||
(if (<:_P ret-type ctype)
|
||||
(values (copy-struct ast:expr:if expr
|
||||
[ast:expr:if-test e1]
|
||||
[ast:expr:if-then e2])
|
||||
ret-type)
|
||||
(raise-read-error-with-stx
|
||||
"Found if expression without else branch in non-void context"
|
||||
stx)))))]
|
||||
[(struct ast:expr:cast (stx obj type))
|
||||
(if (not (type-valid? type))
|
||||
(raise-read-error-with-stx
|
||||
"Type argument of cast is not a valid type"
|
||||
(ast-syntax type)))
|
||||
(let-values ([(e1 t1) (typecheck-expression lenv (make-any-type (ast-syntax obj)) obj)])
|
||||
(if (<:_P type ctype)
|
||||
(values (copy-struct ast:expr:cast expr
|
||||
[ast:expr:cast-object e1])
|
||||
type)
|
||||
(raise-honu-type-error stx ctype type)))]
|
||||
[(struct ast:expr:isa (stx obj type))
|
||||
(if (not (type-valid? type))
|
||||
(raise-read-error-with-stx
|
||||
"Type argument of isa is not a valid type"
|
||||
(ast-syntax type)))
|
||||
(let-values ([(e1 t1) (typecheck-expression lenv (make-any-type (ast-syntax obj)) obj)])
|
||||
(let ([ret-type (make-bool-type stx)])
|
||||
(if (<:_P ret-type ctype)
|
||||
(values (copy-struct ast:expr:isa expr
|
||||
[ast:expr:isa-object e1])
|
||||
ret-type)
|
||||
(raise-honu-type-error stx ctype ret-type))))]
|
||||
[(struct ast:expr:member (stx 'my _ name _))
|
||||
(cond
|
||||
[(lenv name)
|
||||
=>
|
||||
(lambda (t)
|
||||
(if (ast:type:method? t)
|
||||
(let ([fun-type (make-func-type (ast-syntax t) (ast:type:method-input t) (ast:type:method-output t))])
|
||||
(if (<:_P fun-type ctype)
|
||||
(values (copy-struct ast:expr:member expr
|
||||
[ast:expr:member-method? #t])
|
||||
fun-type)
|
||||
(raise-honu-type-error stx ctype fun-type)))
|
||||
(if (<:_P 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 ast:expr:member (stx obj _ name _))
|
||||
(let-values ([(e1 t1) (typecheck-expression lenv (make-any-type (ast-syntax obj)) obj)])
|
||||
;; if obj was something like error or return, which do not give us a valid type for
|
||||
;; getting the appropriate member...
|
||||
(if (ast:type:bot? t1)
|
||||
(raise-read-error-with-stx
|
||||
"Attempt to access member of an expression which does not return"
|
||||
stx))
|
||||
;; if obj was null...
|
||||
(if (ast:type:object:null? t1)
|
||||
(raise-read-error-with-stx
|
||||
"Null has no fields or methods"
|
||||
stx))
|
||||
(let ([t (get-member-type t1 name)])
|
||||
(cond
|
||||
[(ast:type:method? t)
|
||||
(let ([fun-type (make-func-type (ast-syntax t) (ast:type:method-input t) (ast:type:method-output t))])
|
||||
(if (<:_P fun-type ctype)
|
||||
(values (copy-struct ast:expr:member expr
|
||||
[ast:expr:member-object e1]
|
||||
[ast:expr:member-object-type t1]
|
||||
[ast:expr:member-method? #t])
|
||||
fun-type)
|
||||
(raise-honu-type-error stx ctype fun-type)))]
|
||||
[t
|
||||
(if (<:_P t ctype)
|
||||
(values (copy-struct ast:expr:member expr
|
||||
[ast:expr:member-object e1]
|
||||
[ast:expr:member-object-type 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 ast:expr:new (stx class type args))
|
||||
(let ([class-entry (get-class-entry class)]
|
||||
[new-type (if type type ctype)])
|
||||
;; the following can only be triggered if the type annontation isn't a type
|
||||
(if (and type (not (type-valid? type)))
|
||||
(raise-read-error-with-stx
|
||||
(format "Type annotation ~a on new statement is not a valid type" (printable-type new-type))
|
||||
(ast-syntax new-type)))
|
||||
;; the following two checks can only be triggered if there is no type annotation
|
||||
(if (ast:type:top? new-type)
|
||||
(raise-read-error-with-stx
|
||||
"type of instantiation must be explicitly annotated"
|
||||
stx))
|
||||
(if (not (<:_P 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 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 stx (lambda (e t)
|
||||
(typecheck-expression lenv t e))
|
||||
(tenv:class-inits class-entry) args)])
|
||||
(if (<:_P new-type ctype)
|
||||
(values (copy-struct ast:expr:new expr
|
||||
[ast:expr:new-type new-type]
|
||||
[ast:expr:new-args args])
|
||||
new-type)
|
||||
(raise-honu-type-error stx ctype new-type))))]
|
||||
[(struct ast:expr:while (stx cond body))
|
||||
(let-values ([(e1 t1) (typecheck-expression lenv (make-bool-type (ast-syntax cond)) cond)]
|
||||
[(e2 t2) (typecheck-expression lenv (make-void-type (ast-syntax body)) body)])
|
||||
(let ([ret-type (make-void-type stx)])
|
||||
(if (<:_P ret-type ctype)
|
||||
(values (copy-struct ast:expr:while expr
|
||||
[ast:expr:while-test e1]
|
||||
[ast:expr:while-body e2])
|
||||
ret-type)
|
||||
(raise-honu-type-error stx ctype ret-type))))]
|
||||
[(struct ast:expr:cond (stx clauses else))
|
||||
(if else
|
||||
(let-values ([(clauses types) (map-two-values (lambda (c)
|
||||
(typecheck-cond-clause lenv ctype c))
|
||||
clauses)]
|
||||
[(else etype) (typecheck-expression lenv ctype else)])
|
||||
(cond
|
||||
;; if ctype exists, just use it
|
||||
;;
|
||||
;; can't do this, see if for reasoning
|
||||
;; [ctype
|
||||
;; (values (copy-struct ast:expr:cond expr
|
||||
;; [ast:expr:cond-clauses clauses])
|
||||
;; ctype)]
|
||||
;; otherwise find the most super type of all the branches
|
||||
[(pick-super-type-from-list (cons etype types))
|
||||
=>
|
||||
(lambda (t)
|
||||
(values (copy-struct ast:expr:cond expr
|
||||
[ast:expr:cond-clauses clauses]
|
||||
[ast:expr: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 lenv
|
||||
(make-void-type (ast-syntax c)) c))
|
||||
clauses)])
|
||||
(let ([ret-type (make-void-type stx)])
|
||||
(if (<:_P ret-type ctype)
|
||||
(values (copy-struct ast:expr:cond expr
|
||||
[ast:expr:cond-clauses clauses])
|
||||
ret-type)
|
||||
(raise-read-error-with-stx
|
||||
"Cond expression without an else branch found in non-void context"
|
||||
stx)))))]
|
||||
[(struct ast:expr: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 (current-return-type)
|
||||
;; we use rtype as the context type here, since that's the type that needs to be returned.
|
||||
(let-values ([(e1 _) (typecheck-expression lenv (current-return-type) body)])
|
||||
;; we don't need to check (bottom-type) <:_P ctype, because that's vacuously true.
|
||||
(values (copy-struct ast:expr:return expr
|
||||
[ast:expr:return-result e1])
|
||||
(make-bottom-type stx)))
|
||||
(raise-read-error-with-stx
|
||||
"Return statement found outside body of method or function"
|
||||
stx))]
|
||||
[(struct ast:expr:tuple (stx vals))
|
||||
(cond
|
||||
[(ast: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 (ast:type:tuple-elems ctype))))
|
||||
(raise-read-error-with-stx
|
||||
(format "Expected tuple of length ~a, got tuple of length ~a"
|
||||
(length vals)
|
||||
(length (ast:type:tuple-elems ctype)))
|
||||
stx))
|
||||
(let-values ([(vals types) (map-two-values (lambda (e t)
|
||||
(typecheck-expression lenv t e))
|
||||
vals (ast:type:tuple-elems ctype))])
|
||||
(values (copy-struct ast:expr:tuple expr
|
||||
[ast:expr:tuple-elems vals])
|
||||
(make-tuple-type stx types)))]
|
||||
;; we must be in hte context of a select expression, so
|
||||
[(ast:type:partial/tuple? ctype)
|
||||
(if (not (<= (ast:type:partial/tuple-position ctype) (length vals)))
|
||||
(raise-read-error-with-stx
|
||||
(format "Expected tuple of length at least ~a, got tuple of length ~a"
|
||||
(ast:type:partial/tuple-position ctype)
|
||||
(length vals))
|
||||
stx))
|
||||
(let-values ([(vals types) (map-two-values (lambda (e t)
|
||||
(typecheck-expression lenv t e))
|
||||
vals (gen-top-except-for (length vals)
|
||||
(ast:type:partial/tuple-position ctype)
|
||||
(ast:type:partial/tuple-elem ctype)))])
|
||||
(values (copy-struct ast:expr:tuple expr
|
||||
[ast:expr:tuple-elems 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.
|
||||
[(ast:type:top? ctype)
|
||||
(let-values ([(vals types) (map-two-values (lambda (e)
|
||||
(typecheck-expression lenv
|
||||
(make-top-type (ast-syntax e)) e))
|
||||
vals)])
|
||||
(values (copy-struct ast:expr:tuple expr
|
||||
[ast:expr:tuple-elems vals])
|
||||
(make-tuple-type stx types)))]
|
||||
[else (raise-read-error-with-stx
|
||||
"Expected non-tuple expression (or tuple of length 1) here"
|
||||
stx)])]
|
||||
[(struct ast:expr:let (_ bindings body))
|
||||
(let*-values ([(bindings lenv) (map-and-fold (lambda (bind lenv)
|
||||
(typecheck-binding lenv bind))
|
||||
lenv
|
||||
bindings)]
|
||||
[(e1 t1) (typecheck-expression lenv ctype body)])
|
||||
(values (copy-struct ast:expr:let expr
|
||||
[ast:expr:let-bindings bindings]
|
||||
[ast:expr:let-body e1])
|
||||
t1))]
|
||||
[(struct ast:expr:sequence (_ effects value))
|
||||
(let-values ([(effects _)
|
||||
(map-two-values
|
||||
(lambda (e)
|
||||
(typecheck-expression lenv (make-void-type (ast-syntax e)) e))
|
||||
effects)]
|
||||
[(e1 t1) (typecheck-expression lenv ctype value)])
|
||||
(values (copy-struct ast:expr:sequence expr
|
||||
[ast:expr:sequence-statements effects]
|
||||
[ast:expr:sequence-result 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 lenv binding)
|
||||
(match binding
|
||||
[(struct ast:defn:binding (stx names types value))
|
||||
;; make sure to remove all the #f for don't care arguments.
|
||||
(let ([conflicting-name (get-first-non-unique-name (filter (lambda (n) n) names))])
|
||||
(if conflicting-name
|
||||
(raise-read-error-with-stx
|
||||
(format "Variable name ~a used more than once in binding form"
|
||||
(printable-key conflicting-name))
|
||||
conflicting-name)))
|
||||
(for-each (lambda (n t)
|
||||
(if (and (not (and (not n)
|
||||
(ast:type:top? t)))
|
||||
(not (type-valid? t)))
|
||||
(raise-read-error-with-stx
|
||||
"Type of locally bound variable is undefined"
|
||||
(ast-syntax t))))
|
||||
names types)
|
||||
(let-values ([(e1 t1) (typecheck-expression lenv (make-tuple-type (ast-syntax value) types) value)])
|
||||
(values (copy-struct ast:defn:binding binding
|
||||
[ast:defn:binding-init e1])
|
||||
(fold (lambda (name type lenv)
|
||||
(if name
|
||||
(extend-fenv name type lenv)
|
||||
lenv))
|
||||
lenv names types)))]))
|
||||
|
||||
(define (typecheck-cond-clause lenv ctype clause)
|
||||
(match clause
|
||||
[(struct ast:cond/clause (stx pred rhs))
|
||||
(let-values ([(e1 t1) (typecheck-expression lenv (make-bool-type (ast-syntax pred)) pred)]
|
||||
[(e2 t2) (typecheck-expression lenv ctype rhs)])
|
||||
(values (copy-struct ast:cond/clause clause
|
||||
[ast:cond/clause-test e1]
|
||||
[ast:cond/clause-result e2])
|
||||
t2))]))
|
||||
|
||||
(define (check-prim-types-for-binop stx t1 t2)
|
||||
(cond
|
||||
[(and (ast:type:bot? t1)
|
||||
(ast:type:primitive? t2))
|
||||
t2]
|
||||
[(and (ast:type:primitive? t1)
|
||||
(ast:type:bot? t2))
|
||||
t1]
|
||||
[(and (ast:type:primitive? t1)
|
||||
(ast:type:primitive? t2)
|
||||
(type-equal? 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 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 (ast:named/arg-name arg))]
|
||||
[(e1 t1)
|
||||
(type-fun (ast:named/arg-actual arg) (tenv:init-type init))])
|
||||
(values (copy-struct ast:named/arg arg
|
||||
[ast:named/arg-actual 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 ts)
|
||||
(define (pick-super-type-with-acc ts t)
|
||||
(cond
|
||||
;; t is a super-type of all the other branches
|
||||
[(andmap (lambda (t2)
|
||||
(<:_P 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? t t2))
|
||||
(<:_P 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))]))
|
||||
|
||||
)
|
||||
|
|
@ -1,13 +0,0 @@
|
|||
(module typecheck-parameters mzscheme
|
||||
|
||||
(provide (all-defined))
|
||||
|
||||
;; since the return type only changes when we go into a lambda in typecheck-expression, we
|
||||
;; make it a parameter also.
|
||||
;;
|
||||
;; rtype : (union ast:type? false/c)
|
||||
;; return type for method/function
|
||||
|
||||
(define current-return-type (make-parameter #f))
|
||||
|
||||
)
|
||||
|
|
@ -1,28 +0,0 @@
|
|||
(module typecheck-utils mzscheme
|
||||
|
||||
(require (lib "contract.ss")
|
||||
"../../ast.ss"
|
||||
"../tools/general.ss"
|
||||
"../../readerr.ss"
|
||||
"type-utils.ss"
|
||||
)
|
||||
|
||||
(provide/contract
|
||||
[check-valid-type! (string? ast:type? . -> . void?)]
|
||||
[check-valid-types! (string? (listof ast:type?) . -> . void?)]
|
||||
)
|
||||
|
||||
;; check-valid-type! : Name Type -> Void
|
||||
;; Raises an error if named type is not valid.
|
||||
(define (check-valid-type! name type)
|
||||
(if (not (type-valid? type))
|
||||
(raise-read-error-with-stx
|
||||
(format "~s is undefined" name)
|
||||
(ast-syntax type))))
|
||||
|
||||
;; check-valid-types! : Name [Listof Type] -> Void
|
||||
;; Raises an error if any of the named types are not valid.
|
||||
(define (check-valid-types! name types)
|
||||
(for-each (curry check-valid-type! name) types))
|
||||
|
||||
)
|
||||
|
|
@ -1,251 +0,0 @@
|
|||
(module typechecker mzscheme
|
||||
|
||||
(require (lib "contract.ss")
|
||||
(lib "plt-match.ss")
|
||||
(lib "struct.ss")
|
||||
(prefix srfi1: (lib "list.ss" "srfi" "1"))
|
||||
"../../ast.ss"
|
||||
"../../readerr.ss"
|
||||
"../../tenv.ss"
|
||||
"../tools/general.ss"
|
||||
"typecheck-utils.ss"
|
||||
"typecheck-class-utils.ss"
|
||||
"typecheck-expression.ss"
|
||||
"typecheck-parameters.ss"
|
||||
"type-utils.ss")
|
||||
|
||||
(provide/contract [typecheck ((listof ast:defn?)
|
||||
. -> .
|
||||
(listof ast:defn?))]
|
||||
[typecheck-defn (ast:defn?
|
||||
. -> .
|
||||
ast:defn?)])
|
||||
(define (typecheck defns)
|
||||
(let loop ([defns defns]
|
||||
[results '()])
|
||||
(cond
|
||||
[(null? defns) (reverse results)]
|
||||
;; we allow functions to be mutually recursive in Algol-like fashion
|
||||
;; (i.e. if they are no intervening non-function definitions)
|
||||
[(ast:defn:function? (car defns))
|
||||
(let-values ([(funcs remaining) (srfi1:span ast:defn:function? defns)])
|
||||
(loop remaining (append (typecheck-functions funcs) results)))]
|
||||
[else (loop (cdr defns) (cons (typecheck-defn (car defns)) results))])))
|
||||
|
||||
(define (typecheck-functions funcs)
|
||||
(define (check-function-type func)
|
||||
(match func
|
||||
[(struct ast:defn:function (stx name type args body))
|
||||
(check-valid-type! "function return type" type)
|
||||
(let ([conflicting-name (get-first-non-unique-name (map ast:formal-name args))])
|
||||
(if conflicting-name
|
||||
(raise-read-error-with-stx
|
||||
(format "Argument name ~a used more than once"
|
||||
(printable-key conflicting-name))
|
||||
conflicting-name)))
|
||||
(check-valid-types! "function argument type" (map ast:formal-type args))
|
||||
(make-func-type stx (make-tuple-type stx (map ast:formal-type args)) type)]))
|
||||
;; first we add the functions to the lexical environment so that when we typecheck
|
||||
;; the bodies, they'll be in scope.
|
||||
(for-each (lambda (f)
|
||||
(extend-lenv (ast:defn:function-name f)
|
||||
(make-tenv:value (ast-syntax f) (check-function-type f))))
|
||||
funcs)
|
||||
(let loop ([funcs funcs]
|
||||
[new-funcs '()])
|
||||
(if (null? funcs)
|
||||
;; don't reverse it, because we want to keep these in the same order in typecheck,
|
||||
;; which will eventually reverse everything
|
||||
new-funcs
|
||||
(match (car funcs)
|
||||
[(struct ast:defn:function (stx name type args body))
|
||||
(let-values
|
||||
([(e1 t1)
|
||||
(parameterize ([current-return-type type])
|
||||
(typecheck-expression (srfi1:fold (lambda (a e)
|
||||
(extend-fenv (ast:formal-name a)
|
||||
(ast:formal-type a)
|
||||
e))
|
||||
(wrap-lenv)
|
||||
args)
|
||||
type body))])
|
||||
(loop (cdr funcs)
|
||||
(cons (copy-struct ast:defn:function (car funcs)
|
||||
[ast:defn:function-body e1])
|
||||
new-funcs)))]))))
|
||||
|
||||
;; typecheck-bind-top : BindTop -> BindTop
|
||||
;; Typechecks a top-level binding and produces the annotated version.
|
||||
(define (typecheck-bind-top bind-top)
|
||||
(match bind-top
|
||||
[(struct ast:defn:binding (stx names types value))
|
||||
(for-each (lambda (n t)
|
||||
(if (not (and (not n)
|
||||
(ast:type:top? t)))
|
||||
(check-valid-type! "top-level bound variable type" t)))
|
||||
names types)
|
||||
(let-values ([(e1 t1) (typecheck-expression (wrap-lenv) (make-tuple-type stx types) value)])
|
||||
(for-each (lambda (n t)
|
||||
(if n (extend-lenv n (make-tenv:value stx t))))
|
||||
names types)
|
||||
(copy-struct ast:defn:binding bind-top
|
||||
[ast:defn:binding-init e1]))]))
|
||||
|
||||
;; typecheck-iface : IFace -> IFace
|
||||
;; Typechecks an interface definition and produces the annotated version.
|
||||
(define (typecheck-iface iface)
|
||||
(match iface
|
||||
[(struct ast:defn:iface (stx name supers members))
|
||||
(check-valid-types! "interface supertype" supers)
|
||||
(let ([conflicting-name (get-first-non-unique-name (map ast:iface/member-name members))])
|
||||
(if conflicting-name
|
||||
(raise-read-error-with-stx
|
||||
(format "Field/method name ~a used more than once"
|
||||
(printable-key conflicting-name))
|
||||
conflicting-name)))
|
||||
(for-each (lambda (m)
|
||||
(typecheck-member-decl m))
|
||||
members)
|
||||
iface]))
|
||||
|
||||
;; typecheck-class : Class -> Class
|
||||
;; Typechecks a class definition and produces the annotated version.
|
||||
(define (typecheck-class class)
|
||||
(match class
|
||||
[(struct ast:defn:class (stx name type final? impls inits members exports))
|
||||
(check-valid-type! "class self-type" type)
|
||||
(check-valid-types! "implemented type of class" impls)
|
||||
(let ([conflicting-name (get-first-non-unique-name (append (map ast:formal-name inits)
|
||||
(map ast:class/member-name members)))])
|
||||
(if conflicting-name
|
||||
(raise-read-error-with-stx
|
||||
(format "Init/field/method name ~a used more than once"
|
||||
(printable-key conflicting-name))
|
||||
conflicting-name)))
|
||||
(check-valid-types! "init slot type" (map ast:formal-type inits))
|
||||
(let ([lenv (srfi1:fold (lambda (a e)
|
||||
(extend-fenv (ast:formal-name a)
|
||||
(ast:formal-type a)
|
||||
e))
|
||||
(lambda (n) #f)
|
||||
inits)])
|
||||
(let*-values ([(lenv) (extend-fenv #'this type (wrap-lenv))]
|
||||
[(members lenv) (typecheck-members lenv type members)])
|
||||
(typecheck-exports lenv type impls exports)
|
||||
(copy-struct ast:defn:class class
|
||||
[ast:defn:class-members members])))]))
|
||||
|
||||
;; check-mixin-internal-names! : Mixin -> Void
|
||||
;; Raises an error if defined names in a mixin conflict with each other.
|
||||
(define (check-mixin-internal-names! mixin)
|
||||
(match mixin
|
||||
[(struct ast:defn:mixin (stx name type arg-type final? impls inits withs
|
||||
supernew members-before members-after exports))
|
||||
(let* ([arg-tentry (get-type-entry arg-type)]
|
||||
[conflicting-name (get-first-non-unique-name (append (map tenv:member-name
|
||||
(append (tenv:type-members arg-tentry)
|
||||
(tenv:type-inherited arg-tentry)))
|
||||
(map ast:formal-name inits)
|
||||
(map ast:class/member-name
|
||||
(append members-before
|
||||
members-after))))])
|
||||
(if conflicting-name
|
||||
(raise-read-error-with-stx
|
||||
(format "Init/field/method name ~a used more than once in mixin or conflicts with members of argument type"
|
||||
(printable-key conflicting-name))
|
||||
(ast-syntax mixin))))]))
|
||||
|
||||
;; check-mixin-expected-init-names! : Mixin -> Void
|
||||
;; Raises an error if init arguments expected of mixin's argument contain conflicts
|
||||
(define (check-mixin-expected-init-names! mixin)
|
||||
(match mixin
|
||||
[(struct ast:defn:mixin (stx name type arg-type final? impls inits withs
|
||||
supernew members-before members-after exports))
|
||||
(let ([conflicting-name (get-first-non-unique-name (map ast:formal-name withs))])
|
||||
(if conflicting-name
|
||||
(raise-read-error-with-stx
|
||||
(format "Init name ~a used more than once in expected init slots"
|
||||
(printable-key conflicting-name))
|
||||
conflicting-name)))]))
|
||||
|
||||
;; check-distinct-names! : String [Listof Identifier] -> Void
|
||||
;; Raises an error if any of the names are the same.
|
||||
(define (check-distinct-names! desc names)
|
||||
(cond
|
||||
[(check-duplicate-identifier names) =>
|
||||
(lambda (name)
|
||||
(raise-read-error-with-stx (format "Duplicate name ~s found in ~s." name desc) name))]
|
||||
[else (void)]))
|
||||
|
||||
;; check-distinct-types! : String [Listof Honu:Type] -> Void
|
||||
;; Raises an error if any of the types are the same.
|
||||
(define (check-distinct-types! desc types)
|
||||
(check-distinct-names! desc (map ast:type:object:iface-name types)))
|
||||
|
||||
;; typecheck-mixin : Mixin -> Mixin
|
||||
;; Typechecks a mixin definition and produces the annotated version.
|
||||
(define (typecheck-mixin mixin)
|
||||
(match mixin
|
||||
[(struct ast:defn:mixin (stx name type arg-type final? impls inits withs
|
||||
supernew members-before members-after exports))
|
||||
|
||||
(define members (append members-before members-after))
|
||||
(define member-names (map ast:class/member-name members))
|
||||
(define init-names (map ast:formal-name inits))
|
||||
(define super-member-names (type-member-names arg-type))
|
||||
|
||||
(check-valid-type! "mixin argument type" arg-type)
|
||||
(check-valid-type! "mixin result type" type)
|
||||
(check-valid-types! "mixin implemented type" impls)
|
||||
(check-valid-types! "init slot type" (map ast:formal-type inits))
|
||||
(check-valid-types! "superclass init slot type" (map ast:formal-type withs))
|
||||
(check-distinct-types! "mixin implemented types" impls)
|
||||
(check-distinct-names! "internally visible member/init names"
|
||||
(append super-member-names init-names member-names))
|
||||
(check-distinct-names! "superclass init slot names"
|
||||
(map ast:formal-name withs))
|
||||
|
||||
(let*-values ([(lenv) (wrap-lenv)]
|
||||
[(lenv) (extend-fenv #'this type lenv)]
|
||||
[(lenv) (srfi1:fold extend-fenv-ast:formal lenv inits)]
|
||||
[(members-before lenv) (typecheck-members lenv type members-before)]
|
||||
[(supernew) (typecheck-supernew lenv withs supernew)]
|
||||
[(lenv) (extend-lenv-with-type-members lenv arg-type)]
|
||||
[(members-after lenv) (typecheck-members lenv type members-after)])
|
||||
(typecheck-exports lenv type impls exports)
|
||||
(copy-struct ast:defn:mixin mixin
|
||||
[ast:defn:mixin-pre-members members-before]
|
||||
[ast:defn:mixin-super-new supernew]
|
||||
[ast:defn:mixin-post-members members-after]))]))
|
||||
|
||||
;; typecheck-subclass : Subclass -> Subclass
|
||||
;; Typechecks a subclass definition and produces the annotated version.
|
||||
(define (typecheck-subclass subclass)
|
||||
(match subclass
|
||||
;; 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 ast:defn:subclass (_ _ _ _))
|
||||
subclass]))
|
||||
|
||||
;; typecheck-defn : Defn -> Defn
|
||||
;; Typechecks a top-level definition and produces the annotated version.
|
||||
(define (typecheck-defn defn)
|
||||
(cond
|
||||
[(ast:defn:binding? defn) (typecheck-bind-top defn)]
|
||||
[(ast:defn:iface? defn) (typecheck-iface defn)]
|
||||
[(ast:defn:class? defn) (typecheck-class defn)]
|
||||
[(ast:defn:mixin? defn) (typecheck-mixin defn)]
|
||||
[(ast:defn:subclass? defn) (typecheck-subclass defn)]
|
||||
[else (raise-read-error-with-stx
|
||||
"Haven't implemented typechecking for that type of definition yet."
|
||||
(ast-syntax defn))]))
|
||||
|
||||
(define (typecheck-member-decl member)
|
||||
(match member
|
||||
[(struct ast:iface/member:field (stx name type))
|
||||
(check-valid-type! "field type" type)]
|
||||
[(struct ast:iface/member:method (stx name type args))
|
||||
(check-valid-type! "method return type" type)
|
||||
(check-valid-types! "method argument type" args)]))
|
||||
|
||||
)
|
||||
|
|
@ -1,20 +0,0 @@
|
|||
(module readerr mzscheme
|
||||
|
||||
(require (lib "readerr.ss" "syntax"))
|
||||
|
||||
(provide raise-read-error-with-stx)
|
||||
;; Yes, this is misleading for now. I'll rename it later.
|
||||
;; (define (raise-read-error-with-stx str stx)
|
||||
;; (raise-syntax-error #f str stx))
|
||||
|
||||
;; Forget it, this gives you less extra crap with your error message.
|
||||
;; I'd need to decide what to put in those places instead, so at the
|
||||
;; moment we'll keep it a read error.
|
||||
(define (raise-read-error-with-stx str stx)
|
||||
(raise-read-error str
|
||||
(syntax-source stx)
|
||||
(syntax-line stx)
|
||||
(syntax-column stx)
|
||||
(syntax-position stx)
|
||||
(syntax-span stx)))
|
||||
)
|
||||
|
|
@ -1,21 +0,0 @@
|
|||
(module run-tests mzscheme
|
||||
|
||||
(require "honu-tests.ss"
|
||||
)
|
||||
|
||||
(provide test/text test/graphical)
|
||||
|
||||
(define (test/text)
|
||||
((dynamic-require '(planet "text-ui.ss" ("schematics" "schemeunit.plt" 1 1)) 'test/text-ui)
|
||||
honu-tests))
|
||||
|
||||
(define (test/graphical)
|
||||
((dynamic-require '(planet "graphical-ui.ss" ("schematics" "schemeunit.plt" 1 1)) 'test/graphical-ui)
|
||||
honu-tests))
|
||||
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,561 +0,0 @@
|
|||
(module tenv-utils mzscheme
|
||||
|
||||
(require "readerr.ss"
|
||||
"ast.ss"
|
||||
"parameters.ss"
|
||||
"tenv.ss"
|
||||
"private/tools/general.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
|
||||
[(ast:formal? d)
|
||||
(make-ast:iface/member:field (ast-syntax d)
|
||||
(ast:formal-name d)
|
||||
(ast:formal-type d))]
|
||||
;; can come from mdidefns
|
||||
[(ast:class/member:field/formal? d)
|
||||
(make-ast:iface/member:field (ast-syntax d)
|
||||
(ast:class/member-name d)
|
||||
(ast:class/member:field/formal-type d))]
|
||||
[(ast:class/member:field? d)
|
||||
(make-ast:iface/member:field (ast-syntax d)
|
||||
(ast:class/member-name d)
|
||||
(ast:class/member:field-type d))]
|
||||
[(ast:class/member:method? d)
|
||||
(make-ast:iface/member:method (ast-syntax d)
|
||||
(ast:class/member-name d)
|
||||
(ast:class/member:method-return-type d)
|
||||
(map ast:formal-type (ast:class/member: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
|
||||
[(ast:formal? d) (ast:formal-name d)]
|
||||
;; can come from mdidefns
|
||||
[(ast:class/member? d) (ast:class/member-name d)]))
|
||||
(let ([binds (map (lambda (m)
|
||||
(let ([name (grab-name m)])
|
||||
(make-ast:export/member #f name name))) (append inits mdidefns members))])
|
||||
(make-ast: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 (ast:defn:iface? (car skipped))
|
||||
(let ([supers (ast:defn:iface-supers (car skipped))])
|
||||
(if (find (lambda (d)
|
||||
(cond
|
||||
[(ast:defn:iface? d) (s:member (ast:defn: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 (ast:defn:iface-name (car skipped))))
|
||||
(ast:defn:iface-name (car skipped)))
|
||||
(raise-read-error-with-stx
|
||||
(format "At least one supertype of type ~a is missing"
|
||||
(printable-key (ast:defn:iface-name (car skipped))))
|
||||
(ast:defn:iface-name (car skipped)))))
|
||||
(let ([class-name (cond
|
||||
[(ast:defn:subclass? (car skipped)) (ast:defn:subclass-name (car skipped))]
|
||||
[(ast:defn:substructure? (car skipped)) (ast:defn:substructure-name (car skipped))])]
|
||||
[base-name (cond
|
||||
[(ast:defn:subclass? (car skipped)) (ast:defn:subclass-base (car skipped))]
|
||||
[(ast:defn:substructure? (car skipped)) (ast:defn:substructure-super-class (car skipped))])])
|
||||
(if (find (lambda (d)
|
||||
(cond
|
||||
[(ast:defn:subclass? d) (tenv-key=? base-name (ast:defn:subclass-name d))]
|
||||
[(ast:defn:substructure? d) (tenv-key=? base-name (ast:defn:substructure-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)
|
||||
(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 (ast:defn:function? (car defns))
|
||||
(ast:defn:binding? (car defns)))
|
||||
(loop (cdr defns) skipped #t (cons (car defns) new-defns))]
|
||||
[(ast:defn:iface? (car defns))
|
||||
(let loop2 ([supers (map ast:type:object:iface-name (ast:defn: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)) 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 (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 (ast:defn:class? (car defns))
|
||||
(ast:defn:mixin? (car defns)))
|
||||
(loop (cdr defns) skipped #t (cons (add-defn-to-tenv (car defns)) 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
|
||||
[(ast:defn:structure? (car defns))
|
||||
(match (car defns)
|
||||
[(struct ast:defn:structure (stx name type final? impls inits members exports))
|
||||
(let ([new-iface (make-ast:defn:iface stx (ast:type:object:iface-name type) (list)
|
||||
(make-struct-type-decls inits members))]
|
||||
[new-class (make-ast:defn: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)
|
||||
(cons (add-defn-to-tenv new-iface) 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.
|
||||
[(ast:defn:subclass? (car defns))
|
||||
(let* ([base (get-tenv-entry (ast:defn:subclass-base (car defns)))]
|
||||
[selftype (if (and base (tenv:class? base))
|
||||
(get-tenv-entry (ast:type:object:iface-name (tenv:class-sub-type base)))
|
||||
#f)]
|
||||
[mixin (get-tenv-entry (ast:defn:subclass-mixin (car defns)))]
|
||||
[argtype (if (and mixin (tenv:mixin? mixin))
|
||||
(get-tenv-entry (ast:type:object: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"
|
||||
(ast:defn:subclass-base (car defns)))]
|
||||
[(and selftype (not (tenv:type? selftype)))
|
||||
(raise-read-error-with-stx
|
||||
"Selftype for class is not a type"
|
||||
(ast-syntax (tenv:class-sub-type base)))]
|
||||
[(and mixin (not (tenv:mixin? mixin)))
|
||||
(raise-read-error-with-stx
|
||||
"Mixin for subclass definition is not a mixin"
|
||||
(ast:defn:subclass-mixin (car defns)))]
|
||||
[(and argtype (not (tenv:type? argtype)))
|
||||
(raise-read-error-with-stx
|
||||
"Argument type for mixin is not a type"
|
||||
(ast-syntax (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: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 (ast:defn:subclass-base (car defns)))
|
||||
(printable-type (tenv:class-sub-type base))
|
||||
(printable-type (tenv:mixin-arg-type mixin))
|
||||
(printable-key (ast:defn:subclass-mixin (car defns))))
|
||||
(ast:defn:subclass-base (car defns))))
|
||||
(loop (cdr defns) skipped #t (cons (add-defn-to-tenv (car defns)) 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.
|
||||
[(ast:defn:substructure? (car defns))
|
||||
(match (car defns)
|
||||
[(struct ast:defn:substructure (stx name type base arg-type final? impls inits withs super-new
|
||||
members-before members-after exports))
|
||||
(let ([argtype (get-tenv-entry (ast:type:object: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"
|
||||
(ast-syntax arg-type))]
|
||||
[argtype
|
||||
(let* ([new-iface (make-ast:defn:iface stx (ast:type:object: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-ast:defn: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-ast:defn:subclass stx name base mixin-name)])
|
||||
(loop (cons new-sclass (cdr defns)) skipped #t (cons (add-defn-to-tenv new-mixin)
|
||||
(cons (add-defn-to-tenv new-iface) new-defns))))]
|
||||
[else
|
||||
(loop (cdr defns) (cons (car defns) skipped) changed? new-defns)]))])])))
|
||||
|
||||
(define (check-super-for-members name members super-name)
|
||||
(match (get-tenv-entry 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 (ast:type:method? (tenv:member-type (car super-members)))
|
||||
(if (<:_P (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: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 (ast:type:method? member-type)
|
||||
(copy-struct tenv:member member
|
||||
[tenv:member-type (make-method-type (ast-syntax member-type)
|
||||
iface
|
||||
(ast:type:method-input member-type)
|
||||
(ast:type:method-output member-type))])
|
||||
member)))
|
||||
|
||||
(define (type-equal-modulo-disp? t1 t2)
|
||||
(let ([t1 (if (ast:type:method? t1)
|
||||
(make-func-type (ast-syntax t1)
|
||||
(ast:type:method-input t1)
|
||||
(ast:type:method-output t1))
|
||||
t1)]
|
||||
[t2 (if (ast:type:method? t2)
|
||||
(make-func-type (ast-syntax t2)
|
||||
(ast:type:method-input t2)
|
||||
(ast:type:method-output t2))
|
||||
t2)])
|
||||
(type-equal? t1 t2)))
|
||||
|
||||
(define (check-and-remove-duplicate-members 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: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)
|
||||
(match defn
|
||||
;; 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 ast:defn:iface (src-stx name supers members))
|
||||
;; we have to do this because members of the type can refer to the type itself.
|
||||
;; this is only for <:_P checks.
|
||||
(extend-tenv name
|
||||
(make-tenv:type src-stx supers '() '()))
|
||||
(let* ([tenv-members (convert-members (make-iface-type name name) members)]
|
||||
[inherited-decls
|
||||
(apply append (map (lambda (n) (check-super-for-members name tenv-members n))
|
||||
(map ast:type:object:iface-name supers)))]
|
||||
[unique-inherited
|
||||
;; remove duplicate entries for the same member name, making sure they match.
|
||||
(check-and-remove-duplicate-members name inherited-decls)])
|
||||
|
||||
(extend-tenv-without-checking name
|
||||
(make-tenv:type src-stx supers tenv-members unique-inherited))
|
||||
defn)]
|
||||
;; for classes and mixins, just add a new appropriate entry.
|
||||
[(struct ast:defn: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))
|
||||
defn]
|
||||
[(struct ast:defn: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))
|
||||
withs final?))
|
||||
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 ast:defn:subclass (src-stx name base mixin))
|
||||
(extend-tenv name (generate-subclass-tenv defn))
|
||||
defn]))
|
||||
|
||||
(define (convert-members iface members)
|
||||
(let loop ([members members]
|
||||
[converted '()])
|
||||
(if (null? members)
|
||||
(reverse converted)
|
||||
(match (car members)
|
||||
[(struct ast:iface/member:field (stx name type))
|
||||
(loop (cdr members)
|
||||
(cons (make-tenv:member stx name type) converted))]
|
||||
[(struct ast:iface/member:method (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)
|
||||
(ast:class/member:field/formal? d))
|
||||
defns)])
|
||||
(append (map (lambda (i)
|
||||
(make-tenv:init (ast:formal-name i)
|
||||
(ast:formal-type i)
|
||||
#f))
|
||||
inits)
|
||||
(map (lambda (d)
|
||||
(make-tenv:init (ast:class/member-name d)
|
||||
(ast:class/member:field/formal-type d)
|
||||
(not (false? (ast:class/member:field/formal-default d)))))
|
||||
init-fields))))
|
||||
|
||||
(define (generate-subclass-tenv defn)
|
||||
(let ([base (get-class-entry (ast:defn:subclass-base defn))]
|
||||
[mixin (get-mixin-entry (ast:defn:subclass-mixin defn))])
|
||||
(let ([new-inits (remove-used-inits defn
|
||||
(tenv:class-inits base)
|
||||
(tenv:mixin-withs mixin))])
|
||||
(make-tenv:class (ast-syntax defn)
|
||||
(tenv:mixin-sub-type mixin)
|
||||
(tenv:mixin-impls mixin)
|
||||
(append (tenv:mixin-inits mixin)
|
||||
new-inits)
|
||||
(tenv:mixin-final? mixin)
|
||||
(ast:defn:subclass-base defn)))))
|
||||
|
||||
(define (remove-used-inits defn old-inits withs)
|
||||
(let loop ([old-inits old-inits]
|
||||
[withs withs]
|
||||
[new-inits '()])
|
||||
(if (null? old-inits)
|
||||
(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 (ast:defn:subclass-base defn))
|
||||
(printable-key (ast:formal-name (car withs))))
|
||||
(ast:defn:subclass-base defn))
|
||||
(reverse new-inits))
|
||||
(let* ([curr (car old-inits)]
|
||||
[index (list-index (lambda (w)
|
||||
(tenv-key=? (ast:formal-name w) (tenv:init-name curr)))
|
||||
withs)])
|
||||
(if index
|
||||
(if (<:_P (ast:formal-type (list-ref withs index)) (tenv:init-type curr))
|
||||
(loop (cdr old-inits)
|
||||
(append (take withs index)
|
||||
(drop withs (+ index 1)))
|
||||
new-inits)
|
||||
(raise-read-error-with-stx
|
||||
(format "Mixin ~a needs an incompatible type for init arg ~a"
|
||||
(printable-key (ast:defn:subclass-mixin defn))
|
||||
(printable-key (ast:formal-name (car withs))))
|
||||
(ast:defn:subclass-mixin defn)))
|
||||
(loop (cdr old-inits)
|
||||
withs
|
||||
(cons curr new-inits)))))))
|
||||
|
||||
(provide display-lenv display-current-lenv display-tenv display-current-tenv)
|
||||
(define (display-current-lenv)
|
||||
(display-lenv (current-lexical-environment)))
|
||||
(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-current-tenv)
|
||||
(display-lenv (current-type-environment)))
|
||||
(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 "}~%"))]))
|
||||
)
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user