# JAVA some preparatory work for integrating with Java code
[hear] (class Object ()
(method add-one (lambda (x) (+ (x) 1)))
(method unknown (lambda (x) (x)))
(method <init>-V (self))
(method <init> (self))
(method classname Object)
(method equals-Object-Z (this ==))
(method equals (self equals-Object-Z))
(method act (true))
(method isobj (true)));
[hear] (define java-object / Object);
[hear] (define act / ? x / true);
#(class java-string ()
# (field super (java-object new))
# (method classname String)
# (method unknown (lambda (x) (super (x)))));
# inconsistency of various kinds of equality throughout message
# needs to be cleaned up
[hear] (class Integer ()
(field super (java-object new))
(field value (cell new 0))
(method <init> (self))
(method <init>-V (self))
(method <init>-I-V (lambda (v)
(begin
(value set (v))
(self))))
(method intValue-V (value get))
(method intValue (self intValue-V))
(method equals-Object-Z (lambda (o) (if (= (o classname) Integer)
(= (value get) (o value get))
(false))))
(method equals (self equals-Object-Z))
(method get (value get))
(method set (lambda(x)
(value set
(if (number? / x)
(x)
(x intValue)))))
(method classname Integer)
(method unknown (lambda (x) (super (x)))));
# string is basically the same as an integer
[hear] (class String ()
(field super (java-object new))
(field value (cell new 0))
(method <init> (self))
(method <init>-V (self))
(method <init>-String-V (lambda (v)
(begin
(value set (v value get))
(self))))
(method int-init (lambda (x)
(begin
(value set (x))
(self))))
(method intValue-V (value get))
(method intValue (self intValue-V))
(method get (value get))
(method set (lambda(x)
(value set
(if (number? / x)
(x)
(x intValue)))))
(method equals-Object-Z (lambda (o) (if (= (o classname) String)
(= (value get) (o value get))
(false))))
(method equals (self equals-Object-Z))
(method classname String)
(method unknown (lambda (x) (super (x)))));
# will need to install class hierarchy, just hardcode a few things for now
[hear] (define java
(? x / ? y /
(cond ((= (y) String) (String))
((= (y) Object) (java-object))
((= (y) Integer) (Integer))
(java-object))));
[hear] ((java util String) new isobj);
[hear] (= ((java util String) new add-one 15) 16);
[hear] (class java-numeric ()
(field super (java-object new))
(method unknown (lambda (x) (super (x))))
(field java-content (cell new 0))
(method get (java-content get))
(method init (lambda (v)
(begin
(self set (v))
(self))))
(method set (lambda (v) (java-content set (v)))));
[hear] (define byte (java-numeric));
[hear] (define char (java-numeric));
[hear] (define double (java-numeric));
[hear] (define float (java-numeric));
[hear] (define int (java-numeric));
[hear] (define long (java-numeric));
[hear] (define short (java-numeric));
[hear] (define boolean (java-numeric));
[hear] (define void (java-numeric));
[hear] (define java-test1 (int new));
[hear] (java-test1 set 15);
[hear] (= 15 (java-test1 get));
[hear] (define java-test2 (int new init 17));
[hear] (= 17 (java-test2 get));
[hear] (define state-machine-test1
(? x
(cond ((= (x) 1) 20)
((= (x) 2) 40)
((= (x) 3) 60)
0)));
[hear] (= (state-machine-test1 3) 60);
# really ought to go back and be clear about eager/laziness issues
[hear] (define state-machine-test2
(? x
(cond ((= (x) 1) (java-test1 set 20))
((= (x) 2) (java-test1 set 40))
((= (x) 3) (java-test1 set 60))
0)));
[hear] (state-machine-test2 2);
[hear] (= (java-test1 get) 40);
[hear] (define compare-object-reference
(lambda (o1 o2)
(if (number? / o1)
(number? / o2)
(= (o1 unique-id) (o2 unique-id)))));
[hear] (define jvm-maker
(lambda (vars stack pc ret)
(? op
(begin
(pc set (+ (pc get) 1)) /
cond ((= (op) new)
(lambda (type)
(stack-push (stack) ((type) new))))
((= (op) dup)
(stack-push (stack) (stack-peek (stack))))
((= (op) checkcast)
(lambda (t)
1))
((or (= (op) astore) (= (op) istore))
(lambda (index)
(vars set (hash-add (vars get) (index) (stack-pop (stack))))))
((or (= (op) aload) (= (op) iload))
(lambda (index)
(stack-push (stack) (hash-ref (vars get) (index)))))
((or (= (op) iconst) (= (op) ldc))
(lambda (val)
(stack-push (stack) (val))))
((= (op) aconst_null)
(stack-push (stack) 0))
((= (op) instanceof)
(lambda (t)
(stack-push
(stack)
(not / number? / (stack-pop / stack) (t new classname)))))
((= (op) getfield)
(lambda (key ignore)
(stack-push (stack) ((stack-pop (stack)) (key) get))))
((= (op) putfield)
(lambda (key ignore)
(let ((val (stack-pop (stack))))
((stack-pop (stack)) (key) set (val)))))
((= (op) imul)
(let ((v2 (stack-pop (stack))))
(let ((v1 (stack-pop (stack))))
(stack-push (stack)
(* (v1) (v2))))))
((= (op) iadd)
(let ((v2 (stack-pop (stack))))
(let ((v1 (stack-pop (stack))))
(stack-push (stack)
(+ (v1) (v2))))))
((= (op) isub)
(let ((v2 (stack-pop (stack))))
(let ((v1 (stack-pop (stack))))
(stack-push (stack)
(- (v1) (v2))))))
((= (op) goto)
(lambda (x)
(pc set (x))))
((= (op) iflt)
(lambda (x)
(if (< (stack-pop (stack)) 0)
(pc set (x))
0)))
((= (op) ifle)
(lambda (x)
(if (< (stack-pop (stack)) 1)
(pc set (x))
0)))
((= (op) ifgt)
(lambda (x)
(if (> (stack-pop (stack)) 0)
(pc set (x))
0)))
((= (op) ifge)
(lambda (x)
(if (>= (stack-pop (stack)) 0)
(pc set (x))
0)))
((= (op) ifne)
(lambda (x)
(if (not (= (stack-pop (stack)) 0))
(pc set (x))
0)))
((= (op) ifeq)
(lambda (x)
(if (= (stack-pop (stack)) 0)
(pc set (x))
0)))
((= (op) if_icmpne)
(let ((v2 (stack-pop (stack))))
(let ((v1 (stack-pop (stack))))
(lambda (x)
(if (not (= (v1) (v2)))
(pc set (x))
0)))))
((= (op) if_icmpeq)
(let ((v2 (stack-pop (stack))))
(let ((v1 (stack-pop (stack))))
(lambda (x)
(if (= (v1) (v2))
(pc set (x))
0)))))
((= (op) if_acmpne)
(let ((v2 (stack-pop (stack))))
(let ((v1 (stack-pop (stack))))
(lambda (x)
(if (not (compare-object-reference (v1) (v2)))
(pc set (x))
0)))))
((= (op) if_acmpeq)
(let ((v2 (stack-pop (stack))))
(let ((v1 (stack-pop (stack))))
(lambda (x)
(if (compare-object-reference (v1) (v2))
(pc set (x))
0)))))
((= (op) if_icmpge)
(let ((v2 (stack-pop (stack))))
(let ((v1 (stack-pop (stack))))
(lambda (x)
(if (>= (v1) (v2))
(pc set (x))
0)))))
((= (op) if_icmpgt)
(let ((v2 (stack-pop (stack))))
(let ((v1 (stack-pop (stack))))
(lambda (x)
(if (> (v1) (v2))
(pc set (x))
0)))))
((= (op) if_icmple)
(let ((v2 (stack-pop (stack))))
(let ((v1 (stack-pop (stack))))
(lambda (x)
(if (<= (v1) (v2))
(pc set (x))
0)))))
((= (op) if_icmplt)
(let ((v2 (stack-pop (stack))))
(let ((v1 (stack-pop (stack))))
(lambda (x)
(if (< (v1) (v2))
(pc set (x))
0)))))
((= (op) ifnull)
(lambda (x)
(if (number? / stack-pop (stack))
(pc set (x))
0)))
((= (op) ifnonnull)
(lambda (x)
(if (not (number? / stack-pop (stack)))
(pc set (x))
0)))
((= (op) return)
(begin (ret set (hash-ref (vars get) 0))
(pc set -1)))
((= (op) ireturn)
(begin (ret set (stack-pop (stack)))
(pc set -1)))
((= (op) areturn)
(begin (ret set (stack-pop (stack)))
(pc set -1)))
((= (op) goto)
(lambda (target)
(pc set (target))))
((= (op) invokevirtual)
(lambda (target m n)
(let ((result (stack-call (stack) (target) (m))))
(if (= (n) 1)
(stack-push (stack) (result))
0))))
((= (op) invokeinterface)
(lambda (target m n ignore)
(let ((result (stack-call (stack) (target) (m))))
(if (= (n) 1)
(stack-push (stack) (result))
0))))
((= (op) invokespecial)
(lambda (target m n)
(let ((result (stack-call-special (stack)
(hash-ref (vars get) 0)
(target)
(m))))
(if (= (n) 1)
(stack-push (stack) (result))
0))))
0))));
[hear] (define stack-call
(lambda (stack target ct)
(if (= (ct) 0)
((stack-pop (stack)) (target))
(let ((arg (stack-pop (stack))))
((stack-call (stack) (target) (- (ct) 1)) (arg))))));
[hear] (define stack-call-special
(lambda (stack self target ct)
(if (= (ct) 0)
(let ((act (stack-pop / stack)))
(if (act == (self))
(act super (target))
(act (target))))
(let ((arg (stack-pop (stack))))
((stack-call-special (stack) (self) (target) (- (ct) 1)) (arg))))));
[hear] (define stack-push
(lambda (stack x)
(stack set (prepend (x) (stack get)))));
[hear] (define stack-pop
(lambda (stack)
(let ((v (head (stack get))))
(begin
(stack set (tail (stack get)))
(v)))));
[hear] (define stack-peek
(lambda (stack)
(head (stack get))));
[hear] (define stack-test1 (cell new (vector 5 3 1)));
[hear] (= (stack-pop (stack-test1)) 5);
[hear] (= (stack-peek (stack-test1)) 3);
[hear] (= (stack-pop (stack-test1)) 3);
[hear] (stack-push (stack-test1) 7);
[hear] (= (stack-pop (stack-test1)) 7);
[hear] (define vars-test1 (cell new (hash-null)));
[hear] (define pc-test1 (cell new 0));
[hear] (define ret-test1 (cell new 0));
[hear] (define test-jvm (jvm-maker (vars-test1) (stack-test1) (pc-test1) (ret-test1)));
[hear] (stack-push (stack-test1) 4);
[hear] (test-jvm dup);
[hear] (= (stack-pop (stack-test1)) 4);
[hear] (= (stack-pop (stack-test1)) 4);
[hear] (stack-push (stack-test1) 66);
[hear] (stack-push (stack-test1) 77);
[hear] (test-jvm astore 3);
[hear] (= (stack-pop (stack-test1)) 66);
[hear] (test-jvm aload 3);
[hear] (= (stack-pop (stack-test1)) 77);
[hear] (class test-class ()
(field x ((int) new))
(field y ((int) new)));
[hear] (define test-this (test-class new));
[hear] (test-this x set 5);
[hear] (= (test-this x get) 5);
[hear] (stack-push (stack-test1) (test-this));
[hear] (= ((stack-pop (stack-test1)) x get) 5);
[hear] (stack-push (stack-test1) (test-this));
[hear] (test-jvm astore 0);
[hear] (test-jvm aload 0);
[hear] (test-jvm getfield x (int));
[hear] (= (stack-pop (stack-test1)) 5);
[hear] (test-jvm aload 0);
[hear] (test-jvm iconst 15);
[hear] (test-jvm putfield y (int));
[hear] (= (test-this y get) 15);
[hear] (stack-push (stack-test1) 7);
[hear] (stack-push (stack-test1) 10);
[hear] (test-jvm imul);
[hear] (test-jvm ireturn);
[hear] (= (ret-test1 get) 70);
[hear] (define state-machine-helper /
? at /
lambda (vars stack machine) /
let ((pc (cell new (at)))
(ret (cell new (true)))) /
let ((jvm (jvm-maker (vars) (stack) (pc) (ret)))) /
(begin
(machine (jvm) (pc get))
(if (= (pc get) -1)
(ret get)
(state-machine-helper (pc get) (vars) (stack) (machine)))));
[hear] (define state-machine
(state-machine-helper 0));
[hear] (stack-push (stack-test1) 10);
[hear] (stack-push (stack-test1) 33);
[hear] (= (state-machine (vars-test1) (stack-test1) / ? jvm / ? x /
(cond ((= (x) 0) (jvm istore 4))
((= (x) 1) (jvm iload 4))
(jvm ireturn)))
33);
[hear] (stack-push (stack-test1) 10);
[hear] (define bytecode-test-mul
(lambda (arg0 arg1) /
let ((vars / cell new / make-hash / vector (pair 0 0) (pair 1 (arg0)) (pair 2 (arg1)))
(stack / cell new / vector)) /
state-machine (vars) (stack) / ? jvm / ? x / cond
((= (x) 0) (jvm iload 1))
((= (x) 1) (jvm iload 2))
((= (x) 2) (jvm imul))
((= (x) 3) (jvm ireturn))
(jvm return)));
[hear] (= (bytecode-test-mul 5 9) 45);