suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Several bugs found, the biggest being using <:_P to compare members

Browse Source 
of a supertype and subtype, where the subtype was not yet added to
the tenv.  Had to hack to get around that one.

Also little problems like the fact that list can be captured by the
user program, so we can't use that -- used list* (with a null at the
end) and null (for empty lists) instead.

Since the power was down and I couldn't get the earlier stuff committed,
I have even more changes.  Bug-fixes, mostly, though now top-level
functions that are defined consecutively are mutually recursive as they
should be.

svn: r300
This commit is contained in:
Stevie Strickland 2005-07-03 00:28:59 +00:00
parent 39a7f8feff
commit 439c1ecd24
15 changed files with 577 additions and 166 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/honu/base.ss
View File

@ -2,8 +2,16 @@
(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%))

323
collects/honu/examples/BoundedStack.honu Normal file
View File

@ -0,0 +1,323 @@
//
//
// -$@:@ @@
// @ -@ @ @
// $: @@@@@ $@$: $@+@ @ @@@
// -$@$ @ -@ $+ -@ @ *$
// *$ @ -$@$@ @ @$$
// @ @ $* @ @ @$$
// @+ -$ @: :$ @- *@ $* -$ @ -$
// @:@$- :@@$- -$$-@@ $@$- @@ @@@-
//
//
//
//
type Stack {
Stack push(Any x);
<Stack, Any> pop();
}
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());
}
export Stack : push, pop;
}
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);
}
export BoundedStack : push, pop, isFull, spaceRemaining;
}
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);
}
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); }
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;
}
// 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);
};
}
export List : addToFront, addToEnd, first, atIndex, last, reverse,
rest, drop, take, appendToEnd, appendToFront, length, empty,
map, foldl, foldr, filter;
}
//
//
//@@@@@@ @@
// @ @ @
// @ @ @@ @@ $@$: @@+-$: @@:@$- @ -@@$ :@@+@
// @@@ $ -$- -@ @+@$@ @: -$ @ $ -$ @$ -@
// @ @ $$- -$@$@ @ @ @ @ @ @ @@@@@ :@@$-
// @ -$$ $* @ @ @ @ @ @ @ $ *@
// @ @ -$- $ @- *@ @ @ @ @: -$ @ +: @ :@
//@@@@@@ @@ @@ -$$-@@@@@@@@@ @-@$ @@@@@ $@@+ $+@@:
// @
// @@@
//
//
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));
// Now try adding something to s5!
Stack s6 = s5.push(new IntegerC(value = 50));

24
collects/honu/examples/EvenOddClass.honu Normal file
View File

@ -0,0 +1,24 @@
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;
}

11
collects/honu/examples/List.honu
View File

@ -7,6 +7,7 @@ type List {
Any atIndex(int);
Any last();
List rest();
List drop(int);
List take(int);
@ -39,6 +40,10 @@ class MTList() : List impl List {
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;
@ -71,7 +76,7 @@ class MTList() : List impl List {
export List : add as addToFront, add as addToEnd,
no_elt as first, no_elts as atIndex, no_elt as last,
drop, take, reverse,
rest, drop, take, reverse,
ret_other as appendToEnd, ret_other as appendToFront,
length, empty,
map, fold as foldl, fold as foldr, filter;
@ -100,6 +105,8 @@ class ConsList(Any car, List cdr) : List impl List {
};
}
List rest() { return cdr; }
List drop(int n) {
if n == 0 {
this : List;
@ -165,6 +172,6 @@ class ConsList(Any car, List cdr) : List impl List {
}
export List : addToFront, addToEnd, first, atIndex, last, reverse,
drop, take, appendToEnd, appendToFront, length, empty,
rest, drop, take, appendToEnd, appendToFront, length, empty,
map, foldl, foldr, filter;
}

23
collects/honu/examples/even-odd.honu Normal file
View File

@ -0,0 +1,23 @@
// 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);
};
}

137
collects/honu/parsers/post-parsing.ss
View File

@ -26,6 +26,11 @@
;;;; 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 honu:struct and
;;;; honu:substruct 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 tenv defns)
@ -62,42 +67,24 @@
defn]
[(struct honu:class (_ _ _ _ _ inits members _))
(let-values ([(members _)
(map-and-fold convert-static-member (map honu:formal-name inits) members)])
(convert-static-members members (map honu:formal-name inits))])
(copy-struct honu:class defn
[honu:class-members members]))]
[(struct honu:mixin (_ _ _ arg-type _ _ inits _ super-new members-before members-after _))
(let*-values ([(members-before env)
(map-and-fold convert-static-member (map honu:formal-name inits) members-before)]
(convert-static-members members-before (map honu:formal-name inits))]
[(super-new)
(convert-static-super-new super-new env)]
[(env)
(extend-env-with-type-members tenv env arg-type)]
[(members-after _)
(map-and-fold convert-static-member env members-after)])
(convert-static-members members-after env)])
(copy-struct honu:mixin defn
[honu:mixin-super-new super-new]
[honu:mixin-members-before members-before]
[honu:mixin-members-after members-after]))]
[(struct honu:subclass (_ _ _ _))
defn]
[(struct honu:struct (_ _ _ _ _ inits members _))
(let-values ([(members _)
(map-and-fold convert-static-member (map honu:formal-name inits) members)])
(copy-struct honu:struct defn
[honu:struct-members members]))]
[(struct honu:substruct (_ _ _ _ arg-type _ _ inits _ super-new members-before members-after _))
(let*-values ([(members-before env)
(map-and-fold convert-static-member (map honu:formal-name inits) members-before)]
[(super-new)
(convert-static-super-new super-new env)]
[(env)
(extend-env-with-type-members tenv env arg-type)]
[(members-after _)
(map-and-fold convert-static-member env members-after)])
(copy-struct honu:substruct defn
[honu:substruct-super-new super-new]
[honu:substruct-members-before members-before]
[honu:substruct-members-after members-after]))]
[(struct honu:function (_ _ _ _ _))
defn]
[(struct honu:bind-top (_ _ _ _))
@ -110,29 +97,47 @@
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)]
[(honu:method? (car members))
(let-values ([(methods remaining) (span honu:method? members)])
(let ([env (append (map honu:method-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 (if (honu:field? (car members))
(honu:field-name (car members))
(honu:init-field-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 honu:init-field (_ name _ value))
(if value
(values
(copy-struct honu:init-field member
[honu:init-field-value (convert-static-expression value env)])
(cons name env))
(values member (cons name env)))]
(copy-struct honu:init-field member
[honu:init-field-value (convert-static-expression value env)])
member)]
[(struct honu:field (_ name _ value))
(values
(copy-struct honu:field member
[honu:field-value (convert-static-expression value env)])
(cons name env))]
(copy-struct honu:field member
[honu:field-value (convert-static-expression value env)])]
[(struct honu:method (_ name _ args body))
(values
;; remember to remove lexical bindings!
(let ([env (fold (lambda (name env)
(delete name env bound-identifier=?))
env (map honu:formal-name args))])
(copy-struct honu:method member
[honu:method-body (convert-static-expression body env)]))
(cons name env))]))
;; remember to remove lexical bindings!
(let ([env (fold (lambda (name env)
(delete name env bound-identifier=?))
env (map honu:formal-name args))])
(copy-struct honu:method member
[honu:method-body (convert-static-expression body env)]))]))
(define (convert-static-super-new snew env)
(match snew
@ -212,8 +217,8 @@
[(struct honu:cond (_ clauses else))
(copy-struct honu:cond expr
[honu:cond-clauses (map (lambda (c)
(convert-static-cond-clause c env)
clauses))]
(convert-static-cond-clause c env))
clauses)]
[honu:cond-else (if else (convert-static-expression else env) #f)])]
[(struct honu:return (_ body))
(copy-struct honu:return expr
@ -245,7 +250,9 @@
(copy-struct honu:binding binding
[honu:binding-value (convert-static-expression value env)])
(fold (lambda (name env)
(delete name env bound-identifier=?))
(if name
(delete name env bound-identifier=?)
env))
env names))]))
(define (convert-static-cond-clause clause env)
@ -331,26 +338,6 @@
new-fields)))))]
[(struct honu:subclass (_ _ _ _))
defn]
[(struct honu:struct (_ _ _ _ _ inits members _))
(copy-struct honu:struct defn
[honu:struct-inits '()]
[honu:struct-members (append (map (lambda (i)
(make-honu:init-field (honu:ast-stx i)
(honu:formal-name i)
(honu:formal-type i)
#f))
inits)
members)])]
[(struct honu:substruct (_ _ _ _ _ _ _ inits _ _ members-before _ _))
(copy-struct honu:substruct defn
[honu:substruct-inits '()]
[honu:substruct-members-before (append (map (lambda (i)
(make-honu:init-field (honu:ast-stx i)
(honu:formal-name i)
(honu:formal-type i)
#f))
inits)
members-before)])]
[(struct honu:function (_ _ _ _ _))
defn]
[(struct honu:bind-top (_ _ _ _))
@ -432,8 +419,8 @@
[(struct honu:cond (_ clauses else))
(apply append (cons (if else (convert-slots-expression else env) (list))
(map (lambda (c)
(convert-slots-cond-clause c env)
clauses))))]
(convert-slots-cond-clause c env))
clauses)))]
[(struct honu:return (_ body))
(convert-slots-expression body env)]
[(struct honu:tuple (_ vals))
@ -501,18 +488,6 @@
[honu:mixin-members-after members-after]))]
[(struct honu:subclass (_ _ _ _))
defn]
[(struct honu:struct (_ _ type _ _ _ members _))
(let ([members (map (lambda (m) (check-this-member m type)) members)])
(copy-struct honu:struct defn
[honu:struct-members members]))]
[(struct honu:substruct (_ _ type _ _ _ _ _ _ super-new members-before members-after _))
(let ([members-before (map (lambda (m) (check-this-member m type)) members-before)]
[super-new (check-this-super-new super-new type)]
[members-after (map (lambda (m) (check-this-member m type)) members-after)])
(copy-struct honu:substruct defn
[honu:substruct-super-new super-new]
[honu:substruct-members-before members-before]
[honu:substruct-members-after members-after]))]
[(struct honu:function (_ _ _ _ body))
;; we only use check-this-expression here for side-effects (we should not get
;; a changed AST if this passes, only an exception if the this keyword occurs here).
@ -639,8 +614,8 @@
[(struct honu:cond (_ clauses else))
(copy-struct honu:cond expr
[honu:cond-clauses (map (lambda (c)
(check-this-cond-clause c type)
clauses))]
(check-this-cond-clause c type))
clauses)]
[honu:cond-else (if else (check-this-expression else type) #f)])]
[(struct honu:return (_ body))
(copy-struct honu:return expr
@ -713,14 +688,6 @@
[honu:mixin-members-after (map simplify-member members-after)])]
[(struct honu:subclass (_ _ _ _))
defn]
[(struct honu:struct (_ _ _ _ _ _ members _))
(copy-struct honu:struct defn
[honu:struct-members (map simplify-member members)])]
[(struct honu:substruct (_ _ _ _ _ _ _ _ _ super-new members-before members-after _))
(copy-struct honu:substruct defn
[honu:substruct-super-new (simplify-super-new super-new)]
[honu:substruct-members-before (map simplify-member members-before)]
[honu:substruct-members-after (map simplify-member members-after)])]
[(struct honu:function (_ _ _ _ body))
(copy-struct honu:function defn
[honu:function-body (simplify-expression body)])]

10
collects/honu/private/compiler/translate-class-utils.ss
View File

@ -107,14 +107,14 @@
(let ([right-defn (if in-super? 'define/override 'define/public)])
(match binding
[(struct comp:exp-bind (old-name new-name #t))
(at #f `(,right-defn (,(translate-method-name type new-name) args)
,(translate-static-method tenv arg-type old-name 'args)))]
(at #f `(,right-defn (,(translate-method-name type new-name) arg-tuple)
,(translate-static-method tenv arg-type 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 tenv arg-type old-name))
(,right-defn (,(translate-field-setter-name type new-name) arg)
,(translate-static-field-setter tenv arg-type old-name 'arg))))])))
(,right-defn (,(translate-field-setter-name type new-name) set-arg)
,(translate-static-field-setter tenv arg-type old-name 'set-arg))))])))
(provide translate-super-new translate-inits translate-member)
(define (translate-super-new tenv arg-type super-new)
@ -148,4 +148,4 @@
(translate-expression tenv arg-type body))]))
)
)

52
collects/honu/private/compiler/translate-expression.ss
View File

@ -5,6 +5,7 @@
"../../ast.ss"
"../../readerr.ss"
"../../tenv.ss"
"../typechecker/type-utils.ss"
"translate-utils.ss")
(provide/contract [translate-expression (tenv? (union honu:type? false/c) honu:expr?
@ -17,9 +18,11 @@
[(struct honu:var (stx name))
(at-ctxt name)]
[(struct honu:tuple (stx args))
(at stx `(list ,@(map (lambda (e)
(translate-expression tenv arg-type e))
args)))]
;; list is a bindable name in Honu, so... we use list*, which isn't.
(at stx `(list* ,@(map (lambda (e)
(translate-expression tenv arg-type e))
args)
()))]
[(struct honu:lambda (stx _ formals body))
(translate-function stx #f formals (translate-expression tenv arg-type body))]
[(struct honu:call (stx func arg))
@ -28,9 +31,9 @@
(at stx (translate-static-method tenv arg-type name
(translate-expression tenv arg-type arg)))]
[(struct honu:member (stx obj elab name #t))
(at stx `(send ,(translate-expression tenv arg-type obj)
,(translate-method-name elab name)
,(translate-expression tenv arg-type arg)))]
(at stx `(honu:send ,(translate-expression tenv arg-type obj)
,(translate-method-name elab name)
,(translate-expression tenv arg-type arg)))]
[else
(at stx `(,(translate-expression tenv arg-type func)
,(translate-expression tenv arg-type arg)))])]
@ -228,7 +231,9 @@
(let-values ([(bound-names body)
(translate-binding-clause (honu:binding-names b)
(translate-expression tenv arg-type (honu:binding-value b)))])
`(,bound-names ,body)))
;; make sure to give the let binding the appropriate syntax,
;; otherwise errors will highlight the entire let expression.
(at (honu:ast-stx b) `(,bound-names ,body))))
bindings)
,(translate-expression tenv arg-type body)))]
[(struct honu:seq (stx effects value))
@ -261,9 +266,9 @@
(raise-read-error-with-stx
"Left-hand side of assignment cannot be a method name"
mstx)
(at stx `(send ,(translate-expression tenv arg-type obj)
,(translate-field-setter-name elab name)
,(translate-expression tenv arg-type rhs))))]
(at stx `(honu:send ,(translate-expression tenv arg-type obj)
,(translate-field-setter-name elab name)
,(translate-expression tenv arg-type rhs))))]
[else
(raise-read-error-with-stx
"Left-hand side of assignment is invalid"
@ -275,12 +280,12 @@
[(struct honu:member (stx obj elab name method?))
(if method?
(at stx `(lambda (args)
(send ,(translate-expression tenv arg-type obj)
,(translate-method-name elab name)
args)))
(at stx `(send ,(translate-expression tenv arg-type obj)
,(translate-field-getter-name elab name)
(list))))]
(honu:send ,(translate-expression tenv arg-type obj)
,(translate-method-name elab name)
args)))
(at stx `(honu:send ,(translate-expression tenv arg-type obj)
,(translate-field-getter-name elab name)
,void-value)))]
[(struct honu:new (stx class _ args))
(at stx `(new ,(translate-class-name class)
,@(map (lambda (a)
@ -289,16 +294,23 @@
args)))]
[(struct honu:cast (stx obj type))
(at stx `(let ([cast-obj ,(translate-expression tenv arg-type obj)])
(if (is-a? cast-obj ,(translate-iface-name type))
;; you can always cast null to an interface type
(if (or (is-a? cast-obj null%)
(is-a? cast-obj ,(translate-iface-name type)))
cast-obj
;; we can use object-info and class-info since we always set (inspect #f)
;; we have to do that for the moment anyway for "extensional" class equality.
(let*-values ([(class dc-1) (object-info cast-obj)]
[(class-name dc-1 dc-2 dc-3 dc-4 dc-5 dc-6) (class-info class)])
(error (format "Class ~a does not implement ~a"
class-name
(quote ,(translate-iface-name type))))))))]
(let ([class-string (symbol->string class-name)])
(string->symbol (substring class-string 0 (- (string-length class-string) 1))))
(quote ,(printable-type type))))))))]
[(struct honu:isa (stx obj type))
(at stx `(let ([cast-obj ,(translate-expression tenv arg-type obj)])
(is-a? cast-obj ,(translate-iface-name type))))]
;; null is a member of any interface type
(or (is-a? cast-obj null%)
(is-a? cast-obj ,(translate-iface-name type)))))]
[(struct honu:this (stx))
(at stx 'this)]
[else (raise-read-error-with-stx

6
collects/honu/private/compiler/translate-utils.ss
View File

@ -102,8 +102,8 @@
tenv-key=?)
(if arg
`(super ,(translate-method-name arg-type name) ,arg)
`(lambda (arg)
(super ,(translate-method-name arg-type name) arg)))
`(lambda (arg-tuple)
(super ,(translate-method-name arg-type name) arg-tuple)))
(if arg
`(,(at-ctxt name) ,arg)
(at-ctxt name))))
@ -118,7 +118,7 @@
(map tenv:member-name (append (tenv:type-members type-entry)
(tenv:type-inherited type-entry)))
tenv-key=?)
`(super ,(translate-field-getter-name arg-type name) (list))
`(super ,(translate-field-getter-name arg-type name) ,void-value)
(at-ctxt name)))
(at-ctxt name)))

13
collects/honu/private/typechecker/typecheck-class-utils.ss
View File

@ -195,7 +195,7 @@
cenv)
(cons member ret)))]
[(honu:method? (car members))
(let-values ([(methods remainder) (get-murec-methods members)])
(let-values ([(methods remainder) (span honu:method? members)])
(let ([cenv (fold (lambda (m cenv)
(extend-fenv (get-class-member-name m)
(get-class-member-type selftype m)
@ -211,17 +211,6 @@
methods))
ret))))])))
(define (get-murec-methods members)
(let loop ([members members]
[ret '()])
(cond
[(null? members) (values (reverse ret) members)]
[(or (honu:init-field? (car members))
(honu:field? (car members)))
(values (reverse ret) members)]
[(honu:method? (car members))
(loop (cdr members) (cons (car members) ret))])))
(define (typecheck-member tenv cenv lenv selftype member)
(match member
[(struct honu:init-field (stx name type value))

30
collects/honu/private/typechecker/typecheck-expression.ss
View File

@ -296,13 +296,21 @@
"Found if expression without else branch in non-void context"
stx)))))]
[(struct honu:cast (stx obj type))
(if (not (type-valid? tenv type))
(raise-read-error-with-stx
"Type argument of cast is not a valid type"
(honu:ast-stx type)))
(let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-any-type (honu:ast-stx obj)) rtype obj)])
(if (<:_P tenv type ctype)
(values (copy-struct honu:cast expr
[honu:cast-obj e1])
type)
(raise-honu-type-error stx ctype type)))]
[(struct honu:isa (stx obj _))
[(struct honu:isa (stx obj type))
(if (not (type-valid? tenv type))
(raise-read-error-with-stx
"Type argument of isa is not a valid type"
(honu:ast-stx type)))
(let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-any-type (honu:ast-stx obj)) rtype obj)])
(let ([ret-type (make-bool-type stx)])
(if (<:_P tenv ret-type ctype)
@ -314,7 +322,7 @@
(cond
[(cenv name) => (lambda (t)
(if (honu:type-disp? t)
(let ([fun-type (make-func-type (honu:type-disp-arg t) (honu:type-disp-ret t))])
(let ([fun-type (make-func-type (honu:ast-stx t) (honu:type-disp-arg t) (honu:type-disp-ret t))])
(if (<:_P tenv fun-type ctype)
(values (copy-struct honu:member expr
[honu:member-method? #t])
@ -328,6 +336,17 @@
stx)])]
[(struct honu:member (stx obj _ name _))
(let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-any-type (honu:ast-stx obj)) rtype obj)])
;; if obj was something like error or return, which do not give us a valid type for
;; getting the appropriate member...
(if (honu: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 (honu:type-iface-bot? t1)
(raise-read-error-with-stx
"Null has no fields or methods"
stx))
(let ([t (get-member-type tenv t1 name)])
(cond
[(honu:type-disp? t)
@ -352,6 +371,11 @@
[(struct honu:new (stx class type args))
(let ([class-entry (get-class-entry tenv class)]
[new-type (if type type ctype)])
;; the following can only be triggered if the type annontation isn't a type
(if (not (type-valid? tenv new-type))
(raise-read-error-with-stx
(format "Type annotation ~a on new statement is not a valid type" (printable-type new-type))
(honu:ast-stx new-type)))
;; the following two checks can only be triggered if there is no type annotation
(if (honu:type-top? new-type)
(raise-read-error-with-stx
@ -631,4 +655,4 @@
[(= 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))]))
)
)

81
collects/honu/private/typechecker/typechecker.ss
View File

@ -25,35 +25,62 @@
;; since lenv is a hashtable and thus will be mutated, we don't need to return it from
;; typecheck or typecheck-defn.
(define (typecheck tenv lenv defns)
(map (lambda (d)
(typecheck-defn tenv lenv d))
defns))
(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)
[(honu:function? (car defns))
(let-values ([(funcs remaining) (span honu:function? defns)])
(loop remaining (append (typecheck-functions tenv lenv funcs) results)))]
[else (loop (cdr defns) (cons (typecheck-defn tenv lenv (car defns)) results))])))
(define (typecheck-functions tenv lenv funcs)
(define (check-function-type func)
(match func
[(struct honu:function (stx name type args body))
(if (not (type-valid? tenv type))
(raise-read-error-with-stx
"Return type of function is undefined"
(honu:ast-stx type)))
(for-each (lambda (t)
(if (not (type-valid? tenv t))
(raise-read-error-with-stx
"Type of function argument is undefined"
(honu:ast-stx type))))
(map honu:formal-type args))
(make-func-type stx (make-tuple-type stx (map honu:formal-type args)) type)]))
;; first we add the functions to the lexical environment so that when we typecheck
;; the bodies, they'll be in scope.
(for-each (lambda (f)
(extend-tenv (honu:function-name f)
(make-tenv:value (honu:ast-stx f) (check-function-type f))
lenv))
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 honu:function (stx name type args body))
(let-values ([(e1 t1) (typecheck-expression tenv (lambda (name) #f)
(fold (lambda (a e)
(extend-fenv (honu:formal-name a)
(honu:formal-type a)
e))
(wrap-as-function lenv)
args)
type type body)])
(loop (cdr funcs)
(cons (copy-struct honu:function (car funcs)
[honu:function-body e1])
new-funcs)))]))))
(define (typecheck-defn tenv lenv defn)
(match defn
[(struct honu:function (stx name type args body))
(if (not (type-valid? tenv type))
(raise-read-error-with-stx
"Return type of function is undefined"
(honu:ast-stx type)))
(for-each (lambda (t)
(if (not (type-valid? tenv t))
(raise-read-error-with-stx
"Type of function argument is undefined"
(honu:ast-stx type))))
(map honu:formal-type args))
(let ([func-type (make-func-type stx (make-tuple-type stx (map honu:formal-type args)) type)])
(extend-tenv name (make-tenv:value stx func-type) lenv)
(let-values ([(e1 t1) (typecheck-expression tenv (lambda (name) #f)
(fold (lambda (a e)
(extend-fenv (honu:formal-name a)
(honu:formal-type a)
e))
(wrap-as-function lenv)
args)
type type body)])
(copy-struct honu:function defn
[honu:function-body e1])))]
[(struct honu:bind-top (stx names types value))
(for-each (lambda (n t)
(if (and (not (and (not n)

12
collects/honu/tenv-utils.ss
View File

@ -355,6 +355,11 @@
;; If we get here, we know that all the supers are in the tenv and are type entries, so we can use
;; get-type-entry safely.
[(struct honu:iface (src-stx name supers members))
;; 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 '() '())
tenv)
(let* ([tenv-members (convert-members (make-iface-type name name) members)]
[inherited-decls
(apply append (map (lambda (n) (check-super-for-members tenv name tenv-members n))
@ -362,9 +367,10 @@
[unique-inherited
;; remove duplicate entries for the same member name, making sure they match.
(check-and-remove-duplicate-members tenv name inherited-decls)])
(extend-tenv name
(make-tenv:type src-stx supers tenv-members unique-inherited)
tenv)
(extend-tenv-without-checking name
(make-tenv:type src-stx supers tenv-members unique-inherited)
tenv)
defn)]
;; for classes and mixins, just add a new appropriate entry.
[(struct honu:class (src-stx name t f? impls inits defns _))

3
collects/honu/tenv.ss
View File

@ -100,6 +100,7 @@
(provide/contract [empty-tenv (-> tenv?)]
[get-builtin-lenv (-> tenv?)]
[extend-tenv (identifier? tenv:entry? tenv? . -> . void?)]
[extend-tenv-without-checking (identifier? tenv:entry? tenv? . -> . void?)]
[create-tenv ((listof identifier?)
(listof tenv:entry?)
. -> .
@ -123,6 +124,8 @@
(format "~a already bound by top-level definition" (printable-key key))
key))
(bound-identifier-mapping-put! tenv key val)))
(define (extend-tenv-without-checking key val tenv)
(bound-identifier-mapping-put! tenv key val))
(define (create-tenv keys vals)
(let ((table (empty-tenv)))
(begin (for-each extend-tenv table keys vals)

10
collects/honu/tool.ss
View File

@ -84,12 +84,10 @@
(drscheme:debug:make-debug-error-display-handler (error-display-handler)))
(let ([old-current-eval (drscheme:debug:make-debug-eval-handler (current-eval))])
(current-eval
(with-handlers ([(lambda (x) #t) (lambda (x) (printf "~a~n" (exn-message x)))])
(lambda (exp)
(old-current-eval (syntax-as-top exp))))))
(with-handlers ([(lambda (x) #t) (lambda (x) (printf "~a~n" (exn-message x)))])
(namespace-attach-module n path)
(namespace-require path))))))
(lambda (exp)
(old-current-eval (syntax-as-top exp)))))
(namespace-attach-module n path)
(namespace-require path)))))
(define/public (render-value value settings port) (display (format-honu value settings #t) port))
(define/public (render-value/format value settings port width) (render-value value settings port) (if (not (null? value)) (newline port)))
(define/public (unmarshall-settings x) x)