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")) (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% (define null%
(class object% (class object%
(inspect #f)
(super-new))) (super-new)))
(define null-obj (new null%)) (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 atIndex(int);
Any last(); Any last();
List rest();
List drop(int); List drop(int);
List take(int); List take(int);
@ -39,6 +40,10 @@ class MTList() : List impl List {
error("The empty list has no elements!"); error("The empty list has no elements!");
} }
List rest() {
error("Cannot get the rest of an empty list!");
}
List drop(int n) { List drop(int n) {
if n == 0 { if n == 0 {
this : List; this : List;
@ -71,7 +76,7 @@ class MTList() : List impl List {
export List : add as addToFront, add as addToEnd, export List : add as addToFront, add as addToEnd,
no_elt as first, no_elts as atIndex, no_elt as last, 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, ret_other as appendToEnd, ret_other as appendToFront,
length, empty, length, empty,
map, fold as foldl, fold as foldr, filter; 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) { List drop(int n) {
if n == 0 { if n == 0 {
this : List; this : List;
@ -165,6 +172,6 @@ class ConsList(Any car, List cdr) : List impl List {
} }
export List : addToFront, addToEnd, first, atIndex, last, reverse, 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; 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);
};
}

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

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

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

@ -107,14 +107,14 @@
(let ([right-defn (if in-super? 'define/override 'define/public)]) (let ([right-defn (if in-super? 'define/override 'define/public)])
(match binding (match binding
[(struct comp:exp-bind (old-name new-name #t)) [(struct comp:exp-bind (old-name new-name #t))
(at #f `(,right-defn (,(translate-method-name type new-name) args) (at #f `(,right-defn (,(translate-method-name type new-name) arg-tuple)
,(translate-static-method tenv arg-type old-name 'args)))] ,(translate-static-method tenv arg-type old-name 'arg-tuple)))]
[(struct comp:exp-bind (old-name new-name #f)) [(struct comp:exp-bind (old-name new-name #f))
(at #f `(begin (at #f `(begin
(,right-defn (,(translate-field-getter-name type new-name) args) (,right-defn (,(translate-field-getter-name type new-name) args)
,(translate-static-field-getter tenv arg-type old-name)) ,(translate-static-field-getter tenv arg-type old-name))
(,right-defn (,(translate-field-setter-name type new-name) arg) (,right-defn (,(translate-field-setter-name type new-name) set-arg)
,(translate-static-field-setter tenv arg-type old-name 'arg))))]))) ,(translate-static-field-setter tenv arg-type old-name 'set-arg))))])))
(provide translate-super-new translate-inits translate-member) (provide translate-super-new translate-inits translate-member)
(define (translate-super-new tenv arg-type super-new) (define (translate-super-new tenv arg-type super-new)

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

@ -5,6 +5,7 @@
"../../ast.ss" "../../ast.ss"
"../../readerr.ss" "../../readerr.ss"
"../../tenv.ss" "../../tenv.ss"
"../typechecker/type-utils.ss"
"translate-utils.ss") "translate-utils.ss")
(provide/contract [translate-expression (tenv? (union honu:type? false/c) honu:expr? (provide/contract [translate-expression (tenv? (union honu:type? false/c) honu:expr?
@ -17,9 +18,11 @@
[(struct honu:var (stx name)) [(struct honu:var (stx name))
(at-ctxt name)] (at-ctxt name)]
[(struct honu:tuple (stx args)) [(struct honu:tuple (stx args))
(at stx `(list ,@(map (lambda (e) ;; 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)) (translate-expression tenv arg-type e))
args)))] args)
()))]
[(struct honu:lambda (stx _ formals body)) [(struct honu:lambda (stx _ formals body))
(translate-function stx #f formals (translate-expression tenv arg-type body))] (translate-function stx #f formals (translate-expression tenv arg-type body))]
[(struct honu:call (stx func arg)) [(struct honu:call (stx func arg))
@ -28,7 +31,7 @@
(at stx (translate-static-method tenv arg-type name (at stx (translate-static-method tenv arg-type name
(translate-expression tenv arg-type arg)))] (translate-expression tenv arg-type arg)))]
[(struct honu:member (stx obj elab name #t)) [(struct honu:member (stx obj elab name #t))
(at stx `(send ,(translate-expression tenv arg-type obj) (at stx `(honu:send ,(translate-expression tenv arg-type obj)
,(translate-method-name elab name) ,(translate-method-name elab name)
,(translate-expression tenv arg-type arg)))] ,(translate-expression tenv arg-type arg)))]
[else [else
@ -228,7 +231,9 @@
(let-values ([(bound-names body) (let-values ([(bound-names body)
(translate-binding-clause (honu:binding-names b) (translate-binding-clause (honu:binding-names b)
(translate-expression tenv arg-type (honu:binding-value 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) bindings)
,(translate-expression tenv arg-type body)))] ,(translate-expression tenv arg-type body)))]
[(struct honu:seq (stx effects value)) [(struct honu:seq (stx effects value))
@ -261,7 +266,7 @@
(raise-read-error-with-stx (raise-read-error-with-stx
"Left-hand side of assignment cannot be a method name" "Left-hand side of assignment cannot be a method name"
mstx) mstx)
(at stx `(send ,(translate-expression tenv arg-type obj) (at stx `(honu:send ,(translate-expression tenv arg-type obj)
,(translate-field-setter-name elab name) ,(translate-field-setter-name elab name)
,(translate-expression tenv arg-type rhs))))] ,(translate-expression tenv arg-type rhs))))]
[else [else
@ -275,12 +280,12 @@
[(struct honu:member (stx obj elab name method?)) [(struct honu:member (stx obj elab name method?))
(if method? (if method?
(at stx `(lambda (args) (at stx `(lambda (args)
(send ,(translate-expression tenv arg-type obj) (honu:send ,(translate-expression tenv arg-type obj)
,(translate-method-name elab name) ,(translate-method-name elab name)
args))) args)))
(at stx `(send ,(translate-expression tenv arg-type obj) (at stx `(honu:send ,(translate-expression tenv arg-type obj)
,(translate-field-getter-name elab name) ,(translate-field-getter-name elab name)
(list))))] ,void-value)))]
[(struct honu:new (stx class _ args)) [(struct honu:new (stx class _ args))
(at stx `(new ,(translate-class-name class) (at stx `(new ,(translate-class-name class)
,@(map (lambda (a) ,@(map (lambda (a)
@ -289,16 +294,23 @@
args)))] args)))]
[(struct honu:cast (stx obj type)) [(struct honu:cast (stx obj type))
(at stx `(let ([cast-obj ,(translate-expression tenv arg-type obj)]) (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 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)] (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)]) [(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" (error (format "Class ~a does not implement ~a"
class-name (let ([class-string (symbol->string class-name)])
(quote ,(translate-iface-name type))))))))] (string->symbol (substring class-string 0 (- (string-length class-string) 1))))
(quote ,(printable-type type))))))))]
[(struct honu:isa (stx obj type)) [(struct honu:isa (stx obj type))
(at stx `(let ([cast-obj ,(translate-expression tenv arg-type obj)]) (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)) [(struct honu:this (stx))
(at stx 'this)] (at stx 'this)]
[else (raise-read-error-with-stx [else (raise-read-error-with-stx

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

@ -102,8 +102,8 @@
tenv-key=?) tenv-key=?)
(if arg (if arg
`(super ,(translate-method-name arg-type name) ,arg) `(super ,(translate-method-name arg-type name) ,arg)
`(lambda (arg) `(lambda (arg-tuple)
(super ,(translate-method-name arg-type name) arg))) (super ,(translate-method-name arg-type name) arg-tuple)))
(if arg (if arg
`(,(at-ctxt name) ,arg) `(,(at-ctxt name) ,arg)
(at-ctxt name)))) (at-ctxt name))))
@ -118,7 +118,7 @@
(map tenv:member-name (append (tenv:type-members type-entry) (map tenv:member-name (append (tenv:type-members type-entry)
(tenv:type-inherited type-entry))) (tenv:type-inherited type-entry)))
tenv-key=?) 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)))
(at-ctxt name))) (at-ctxt name)))

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

@ -195,7 +195,7 @@
cenv) cenv)
(cons member ret)))] (cons member ret)))]
[(honu:method? (car members)) [(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) (let ([cenv (fold (lambda (m cenv)
(extend-fenv (get-class-member-name m) (extend-fenv (get-class-member-name m)
(get-class-member-type selftype m) (get-class-member-type selftype m)
@ -211,17 +211,6 @@
methods)) methods))
ret))))]))) 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) (define (typecheck-member tenv cenv lenv selftype member)
(match member (match member
[(struct honu:init-field (stx name type value)) [(struct honu:init-field (stx name type value))

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

@ -296,13 +296,21 @@
"Found if expression without else branch in non-void context" "Found if expression without else branch in non-void context"
stx)))))] stx)))))]
[(struct honu:cast (stx obj type)) [(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)]) (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-any-type (honu:ast-stx obj)) rtype obj)])
(if (<:_P tenv type ctype) (if (<:_P tenv type ctype)
(values (copy-struct honu:cast expr (values (copy-struct honu:cast expr
[honu:cast-obj e1]) [honu:cast-obj e1])
type) type)
(raise-honu-type-error stx ctype 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-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-any-type (honu:ast-stx obj)) rtype obj)])
(let ([ret-type (make-bool-type stx)]) (let ([ret-type (make-bool-type stx)])
(if (<:_P tenv ret-type ctype) (if (<:_P tenv ret-type ctype)
@ -314,7 +322,7 @@
(cond (cond
[(cenv name) => (lambda (t) [(cenv name) => (lambda (t)
(if (honu:type-disp? 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) (if (<:_P tenv fun-type ctype)
(values (copy-struct honu:member expr (values (copy-struct honu:member expr
[honu:member-method? #t]) [honu:member-method? #t])
@ -328,6 +336,17 @@
stx)])] stx)])]
[(struct honu:member (stx obj _ name _)) [(struct honu:member (stx obj _ name _))
(let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-any-type (honu:ast-stx obj)) rtype obj)]) (let-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)]) (let ([t (get-member-type tenv t1 name)])
(cond (cond
[(honu:type-disp? t) [(honu:type-disp? t)
@ -352,6 +371,11 @@
[(struct honu:new (stx class type args)) [(struct honu:new (stx class type args))
(let ([class-entry (get-class-entry tenv class)] (let ([class-entry (get-class-entry tenv class)]
[new-type (if type type ctype)]) [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 ;; the following two checks can only be triggered if there is no type annotation
(if (honu:type-top? new-type) (if (honu:type-top? new-type)
(raise-read-error-with-stx (raise-read-error-with-stx

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

@ -25,12 +25,20 @@
;; since lenv is a hashtable and thus will be mutated, we don't need to return it from ;; since lenv is a hashtable and thus will be mutated, we don't need to return it from
;; typecheck or typecheck-defn. ;; typecheck or typecheck-defn.
(define (typecheck tenv lenv defns) (define (typecheck tenv lenv defns)
(map (lambda (d) (let loop ([defns defns]
(typecheck-defn tenv lenv d)) [results '()])
defns)) (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-defn tenv lenv defn) (define (typecheck-functions tenv lenv funcs)
(match defn (define (check-function-type func)
(match func
[(struct honu:function (stx name type args body)) [(struct honu:function (stx name type args body))
(if (not (type-valid? tenv type)) (if (not (type-valid? tenv type))
(raise-read-error-with-stx (raise-read-error-with-stx
@ -42,8 +50,22 @@
"Type of function argument is undefined" "Type of function argument is undefined"
(honu:ast-stx type)))) (honu:ast-stx type))))
(map honu:formal-type args)) (map honu:formal-type args))
(let ([func-type (make-func-type stx (make-tuple-type stx (map honu:formal-type args)) 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) ;; 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) (let-values ([(e1 t1) (typecheck-expression tenv (lambda (name) #f)
(fold (lambda (a e) (fold (lambda (a e)
(extend-fenv (honu:formal-name a) (extend-fenv (honu:formal-name a)
@ -52,8 +74,13 @@
(wrap-as-function lenv) (wrap-as-function lenv)
args) args)
type type body)]) type type body)])
(copy-struct honu:function defn (loop (cdr funcs)
[honu:function-body e1])))] (cons (copy-struct honu:function (car funcs)
[honu:function-body e1])
new-funcs)))]))))
(define (typecheck-defn tenv lenv defn)
(match defn
[(struct honu:bind-top (stx names types value)) [(struct honu:bind-top (stx names types value))
(for-each (lambda (n t) (for-each (lambda (n t)
(if (and (not (and (not n) (if (and (not (and (not n)

8
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 ;; 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. ;; get-type-entry safely.
[(struct honu:iface (src-stx name supers members)) [(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)] (let* ([tenv-members (convert-members (make-iface-type name name) members)]
[inherited-decls [inherited-decls
(apply append (map (lambda (n) (check-super-for-members tenv name tenv-members n)) (apply append (map (lambda (n) (check-super-for-members tenv name tenv-members n))
@ -362,7 +367,8 @@
[unique-inherited [unique-inherited
;; remove duplicate entries for the same member name, making sure they match. ;; remove duplicate entries for the same member name, making sure they match.
(check-and-remove-duplicate-members tenv name inherited-decls)]) (check-and-remove-duplicate-members tenv name inherited-decls)])
(extend-tenv name
(extend-tenv-without-checking name
(make-tenv:type src-stx supers tenv-members unique-inherited) (make-tenv:type src-stx supers tenv-members unique-inherited)
tenv) tenv)
defn)] defn)]

3
collects/honu/tenv.ss
View File

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

6
collects/honu/tool.ss
View File

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