Section 41
Want more of a challenge? View in iconic form (experimental)



       # JAVA some preparatory work for integrating with Java code
[hear] (class java-object ()
              (method add-one (lambda (x) (+ (x) 1)))
              (method isobj (true)));

[hear] (class java-string ()
              (field super (java-object new))
              (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) (java-string))
              ((= (y) Object) (java-object))
              (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 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))))
              ((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)))))
              ((= (op) iconst)
               (lambda (val)
                 (stack-push (stack) (val))))
              ((= (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) return)
               (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))))
              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-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);