monadic test

monadic test

;; -*- mode: scheme -*-

  ;;;;; Test Core Language

  ;; DEF

  (provide ()
    (def (x y) (list #t #f))
    (assert (eq? x #t))
    (assert (eq? y #f))

    (assert (eq? (def #ign #t) #t)))

  ;; IF

  (provide ()
    (assert (eq? #t (if #t #t #f)))
    (assert (eq? #f (if #f #t #f))))

  ;; VAU

  (provide ()
    (def env (current-environment))
    (eq? #t ((vau x #ign x) #t))
    (eq? #t ((vau (x . #ign) #ign x) (list #t)))
    (eq? env ((vau #ign e e))))

  ;; EVAL

  (provide ()
    (def env (current-environment))
    (eval (list def (quote x) #t) env)
    (assert (eq? x #t))

    (assert (eq? (eval #t env) #t)))

  ;; WRAP

  (provide ()
    (assert (eq? #t ((wrap (vau (x) #ign x)) (not #f)))))

  ;; UNWRAP

  (provide ()
    (assert (eq? list (unwrap (wrap list)))))

  ;; EQ?

  (provide ()
    (assert (eq? #t #t))
    (assert (not (eq? #t #f)))
    (assert (not (eq? (list 1) (list 1)))))

  ;; CONS

  (provide ()
    (assert (eq? #t (car (cons #t #f))))
    (assert (eq? #f (cdr (cons #t #f)))))

  ;; MAKE-ENVIRONMENT

  (provide ()
    (def e1 (make-environment))
    (eval (list def (quote x) #t) e1)
    (eval (list def (quote y) #t) e1)
    (assert (eq? #t (eval (quote x) e1)))
    (assert (eq? #t (eval (quote y) e1)))

    (def e2 (make-environment e1))
    (assert (eq? #t (eval (quote x) e2)))
    (assert (eq? #t (eval (quote y) e2)))
    (eval (list def (quote y) #f) e2)
    (assert (eq? #f (eval (quote y) e2)))
    (assert (eq? #t (eval (quote y) e1))))

  ;; MAKE-TYPE

  (provide ()
    (def type (make-type))
    (assert (eq? (type-of type) (type-of (type-of #t)))))

  ;; TYPE-ENVIRONMENT

  (provide ()
    (def type (make-type))
    (def tenv (type-environment type))
    (assert (eq? (type-of tenv) (type-of (current-environment)))))

  ;; TYPE-OF

  (provide ()
    (assert (not (eq? (type-of () #void))))
    (assert (eq? (type-of 0) (type-of 1))))

  ;; TAG, UNTAG

  (provide ()
    (def type (make-type))
    (def tagged (tag type #t))
    (assert (eq? (type-of tagged) type))
    (assert (eq? (untag tagged) #t)))

  ;; VECTOR, VECTOR-REF

  (provide ()
    (def (a b c) (list 1 2 3))
    (def v (vector a b c))
    (assert (eq? (vector-ref v 0) a))
    (assert (eq? (vector-ref v 1) b))
    (assert (eq? (vector-ref v 2) c)))

  ;; Quotation

  (provide ()
    (assert (symbol? 'x))
    (assert (pair? '(a . b))))

  ;;;;; Test Crust Language

  ;; NULL?

  (provide ()
    (assert (null? ()))
    (assert (not (null? 12))))

  ;; BEGIN

  (provide ()
    (assert (eq? #void (begin)))
    (assert (eq? #t (begin (eq? #t #t))))
    (assert (eq? #t (begin #f (eq? #t #t)))))

  ;; Continuation Marks

  (provide ()
    (eq? () (current-marks 'foo))
    (eq? #t (with-mark 'foo #t (car (current-marks 'foo))))
    (eq? #f (with-mark 'foo #t (with-mark 'foo #f (car (current-marks 'foo)))))
    (eq? () (with-mark 'foo #t (with-mark 'foo #f (cdr (current-marks 'foo)))))
    (define (id x) x)
    (eq? #f (with-mark 'foo #t (id (with-mark 'foo #f (car (current-marks 'foo))))))
    (eq? #t (with-mark 'foo #t (id (with-mark 'foo #f (car (cdr (current-marks 'foo)))))))
    (eq? () (with-mark 'foo #t (id (with-mark 'foo #f (cdr (cdr (current-marks 'foo)))))))
    (eq? () (current-marks 'foo)))

  ;; Delimited Control

(define-syntax test-check
  (vau (#ign expr res) env
    (assert (= (display (eval expr env)) (eval res env)))))

(define new-prompt make-prompt)

(test-check 'test2
  (let ((p (new-prompt)))
    (+ (push-prompt p (push-prompt p 5))
       4))
  9)

(test-check 'test3
  (let ((p (new-prompt)))
    (+ (push-prompt p (+ (take-sub-cont p (lambda #ign 5)) 6))
       4))
  9)

(test-check 'test3-1
  (let ((p (new-prompt)))
    (+ (push-prompt p (push-prompt p (+ (take-sub-cont p (lambda #ign 5)) 6)))
       4))
  9)

(test-check 'test3-2
  (let ((p (new-prompt)))
    (let ((v (push-prompt p
	       (let* ((v1 (push-prompt p (+ (take-sub-cont p (lambda #ign 5)) 6)))
		      (v1 (take-sub-cont p (lambda #ign 7))))
		 (+ v1 10)))))
      (+ v 20)))
  27)

(test-check 'test4
  (let ((p (make-prompt)))
    (+ (push-prompt* p
         (lambda ()
	   (+ (take-sub-cont p (lambda (sk) (push-sub-cont* sk (lambda () 5))))
	      7)))
       20))
  32)

(test-check 'test6
  (let ((p1 (new-prompt))
	(p2 (new-prompt))
	(push-twice (lambda (sk)
		      (push-sub-cont* sk (lambda () (push-sub-cont* sk (lambda () 3)))))))
    (+ 10
      (push-prompt* p1 (lambda () (+ 1
             			(push-prompt* p2 (lambda () (take-sub-cont p1 (lambda (sk) (push-twice sk))))))))))
  15)

(test-check 'test7
  (let* ((p1 (new-prompt))
	 (p2 (new-prompt))
	 (p3 (new-prompt))
	 (push-twice
	    (lambda (sk)
	      (push-sub-cont* sk (lambda () (push-sub-cont* sk (lambda ()
		(take-sub-cont p2 (lambda (sk2)
		  (push-sub-cont* sk2 (lambda ()
		    (push-sub-cont* sk2 (lambda () 3)))))))))))))
    (+ 100
      (push-prompt* p1 (lambda ()
	(+ 1
	  (push-prompt* p2 (lambda ()
	    (+ 10
	      (push-prompt* p3  (lambda () (take-sub-cont p1 (lambda (sk) (push-twice sk)))))))))))))
  135)

(test-check 'monadic-paper
  (let ((p (make-prompt)))
    (+ 2 (push-prompt* p (lambda ()
		      (if (take-sub-cont p
					 (lambda (k)
					   (+ (push-sub-cont* k (lambda () #f))
					      (push-sub-cont* k (lambda () #t)))))
			  3
			  4)))))
  9)

;; -*- mode: scheme -*-

  ;;;;; Test Core Language

  ;; DEF

  (provide ()
    (def (x y) (list #t #f))
    (assert (eq? x #t))
    (assert (eq? y #f))

    (assert (eq? (def #ign #t) #t)))

  ;; IF

  (provide ()
    (assert (eq? #t (if #t #t #f)))
    (assert (eq? #f (if #f #t #f))))

  ;; VAU

  (provide ()
    (def env (current-environment))
    (eq? #t ((vau x #ign x) #t))
    (eq? #t ((vau (x . #ign) #ign x) (list #t)))
    (eq? env ((vau #ign e e))))

  ;; EVAL

  (provide ()
    (def env (current-environment))
    (eval (list def (quote x) #t) env)
    (assert (eq? x #t))

    (assert (eq? (eval #t env) #t)))

  ;; WRAP

  (provide ()
    (assert (eq? #t ((wrap (vau (x) #ign x)) (not #f)))))

  ;; UNWRAP

  (provide ()
    (assert (eq? list (unwrap (wrap list)))))

  ;; EQ?

  (provide ()
    (assert (eq? #t #t))
    (assert (not (eq? #t #f)))
    (assert (not (eq? (list 1) (list 1)))))

  ;; CONS

  (provide ()
    (assert (eq? #t (car (cons #t #f))))
    (assert (eq? #f (cdr (cons #t #f)))))

  ;; MAKE-ENVIRONMENT

  (provide ()
    (def e1 (make-environment))
    (eval (list def (quote x) #t) e1)
    (eval (list def (quote y) #t) e1)
    (assert (eq? #t (eval (quote x) e1)))
    (assert (eq? #t (eval (quote y) e1)))

    (def e2 (make-environment e1))
    (assert (eq? #t (eval (quote x) e2)))
    (assert (eq? #t (eval (quote y) e2)))
    (eval (list def (quote y) #f) e2)
    (assert (eq? #f (eval (quote y) e2)))
    (assert (eq? #t (eval (quote y) e1))))

  ;; MAKE-TYPE

  (provide ()
    (def type (make-type))
    (assert (eq? (type-of type) (type-of (type-of #t)))))

  ;; TYPE-ENVIRONMENT

  (provide ()
    (def type (make-type))
    (def tenv (type-environment type))
    (assert (eq? (type-of tenv) (type-of (current-environment)))))

  ;; TYPE-OF

  (provide ()
    (assert (not (eq? (type-of () #void))))
    (assert (eq? (type-of 0) (type-of 1))))

  ;; TAG, UNTAG

  (provide ()
    (def type (make-type))
    (def tagged (tag type #t))
    (assert (eq? (type-of tagged) type))
    (assert (eq? (untag tagged) #t)))

  ;; VECTOR, VECTOR-REF

  (provide ()
    (def (a b c) (list 1 2 3))
    (def v (vector a b c))
    (assert (eq? (vector-ref v 0) a))
    (assert (eq? (vector-ref v 1) b))
    (assert (eq? (vector-ref v 2) c)))

  ;; Quotation

  (provide ()
    (assert (symbol? 'x))
    (assert (pair? '(a . b))))

  ;;;;; Test Crust Language

  ;; NULL?

  (provide ()
    (assert (null? ()))
    (assert (not (null? 12))))

  ;; BEGIN

  (provide ()
    (assert (eq? #void (begin)))
    (assert (eq? #t (begin (eq? #t #t))))
    (assert (eq? #t (begin #f (eq? #t #t)))))

  ;; Continuation Marks

  (provide ()
    (eq? () (current-marks 'foo))
    (eq? #t (with-mark 'foo #t (car (current-marks 'foo))))
    (eq? #f (with-mark 'foo #t (with-mark 'foo #f (car (current-marks 'foo)))))
    (eq? () (with-mark 'foo #t (with-mark 'foo #f (cdr (current-marks 'foo)))))
    (define (id x) x)
    (eq? #f (with-mark 'foo #t (id (with-mark 'foo #f (car (current-marks 'foo))))))
    (eq? #t (with-mark 'foo #t (id (with-mark 'foo #f (car (cdr (current-marks 'foo)))))))
    (eq? () (with-mark 'foo #t (id (with-mark 'foo #f (cdr (cdr (current-marks 'foo)))))))
    (eq? () (current-marks 'foo)))

  ;; Delimited Control

  ;; (let ((p (make-prompt)))
  ;; 		  (+ 2 (push-prompt p
  ;; 				    (if (take-sub-cont p
  ;; 						       (lambda (k)
  ;; 							 (+ (push-sub-cont k #f)
  ;; 							    (push-sub-cont k #t))))
  ;; 					3
  ;; 					4))))

(define-syntax test-check
  (vau (#ign expr res) env
    (assert (= (display (eval expr env)) (eval res env)))))

(define new-prompt make-prompt)

(test-check 'test2
  (let ((p (new-prompt)))
    (+ (push-prompt p (push-prompt p 5))
       4))
  9)

(test-check 'test3
  (let ((p (new-prompt)))
    (+ (push-prompt p (+ (take-sub-cont p (lambda #ign 5)) 6))
       4))
  9)

(test-check 'test3-1
  (let ((p (new-prompt)))
    (+ (push-prompt p (push-prompt p (+ (take-sub-cont p (lambda #ign 5)) 6)))
       4))
  9)

(test-check 'test3-2
  (let ((p (new-prompt)))
    (let ((v (push-prompt p
	       (let* ((v1 (push-prompt p (+ (take-sub-cont p (lambda #ign 5)) 6)))
		      (v1 (take-sub-cont p (lambda #ign 7))))
		 (+ v1 10)))))
      (+ v 20)))
  27)

(test-check 'test4
  (let ((p (make-prompt)))
    (+ (push-prompt* p
         (lambda ()
	   (+ (take-sub-cont p (lambda (sk) (push-sub-cont* sk (lambda () 5))))
	      7)))
       20))
  32)

(test-check 'test6
  (let ((p1 (new-prompt))
	(p2 (new-prompt))
	(push-twice (lambda (sk)
		      (push-sub-cont* sk (lambda () (push-sub-cont* sk (lambda () 3)))))))
    (+ 10
      (push-prompt* p1 (lambda () (+ 1
             			(push-prompt* p2 (lambda () (take-sub-cont p1 (lambda (sk) (push-twice sk))))))))))
  15)

(test-check 'test7
  (let* ((p1 (new-prompt))
	 (p2 (new-prompt))
	 (p3 (new-prompt))
	 (push-twice
	    (lambda (sk)
	      (push-sub-cont* sk (lambda () (push-sub-cont* sk (lambda ()
		(take-sub-cont p2 (lambda (sk2)
		  (push-sub-cont* sk2 (lambda ()
		    (push-sub-cont* sk2 (lambda () 3)))))))))))))
    (+ 100
      (push-prompt* p1 (lambda ()
	(+ 1
	  (push-prompt* p2 (lambda ()
	    (+ 10
	      (push-prompt* p3  (lambda () (take-sub-cont p1 (lambda (sk) (push-twice sk)))))))))))))
  135)


move every function parameter declaration to its own line for a better readable.

(module
  (type $t0 (func(param i32)))
  (export "abc" (func $de/inetsoftware/jwebassembly/samples/FunctionParameters.singleInt))
  (func $de/inetsoftware/jwebassembly/samples/FunctionParameters.singleInt
        (param i32)
        (local i32)
    local.get 0
    i32.const 1
    i32.add
    local.set 1
    return
  )
)

(module
  (type $t0 (func(param i32)))
  (export "abc" (func $de/inetsoftware/jwebassembly/samples/FunctionParameters.singleInt))
  (func $de/inetsoftware/jwebassembly/samples/FunctionParameters.singleInt(param i32)(local i32)
    local.get 0
    i32.const 1
    i32.add
    local.set 1
    return
  )
)


Update table.wat

Update table.wat

(module
  (func $thirteen (result i32) (i32.const 13))
  (func $fourtytwo (result i32) (i32.const 42))
  (table (export "tbl") anyfunc (elem $thirteen $fourtytwo))
)

(module
  (func $thirteen (result i32) (i32.const 13))
  (func $fourtytwo (result i32) (i32.const 42))
  (table (export "tbl") anyfunc (elem $thirteen $fourtytwo)))


Update wasm-table.wat

Update wasm-table.wat

(module
  (table 2 anyfunc)
  (func $f1 (result i32)
    i32.const 42
  )
  (func $f2 (result i32)
    i32.const 13
  )
  (elem (i32.const 0) $f1 $f2)
  (type $return_i32 (func (result i32)))
  (func (export "callByIndex") (param $i i32) (result i32)
    local.get $i
    call_indirect (type $return_i32)
  )
)

(module
  (table 2 anyfunc)
  (func $f1 (result i32)
    i32.const 42)
  (func $f2 (result i32)
    i32.const 13)
  (elem (i32.const 0) $f1 $f2)
  (type $return_i32 (func (result i32)))
  (func (export "callByIndex") (param $i i32) (result i32)
    local.get $i
    call_indirect (type $return_i32)))


Update table2.wat

Update table2.wat

(module
  (import "js" "tbl" (table 2 anyfunc))
  (func $f42 (result i32) i32.const 42)
  (func $f83 (result i32) i32.const 83)
  (elem (i32.const 0) $f42 $f83))

(module
    (import "js" "tbl" (table 2 anyfunc))
    (func $f42 (result i32) i32.const 42)
    (func $f83 (result i32) i32.const 83)
    (elem (i32.const 0) $f42 $f83)
)


adapted delim-c tests

adapted delim-c tests

;; -*- mode: scheme -*-

  ;;;;; Test Core Language

  ;; DEF

  (provide ()
    (def (x y) (list #t #f))
    (assert (eq? x #t))
    (assert (eq? y #f))

    (assert (eq? (def #ign #t) #t)))

  ;; IF

  (provide ()
    (assert (eq? #t (if #t #t #f)))
    (assert (eq? #f (if #f #t #f))))

  ;; VAU

  (provide ()
    (def env (current-environment))
    (eq? #t ((vau x #ign x) #t))
    (eq? #t ((vau (x . #ign) #ign x) (list #t)))
    (eq? env ((vau #ign e e))))

  ;; EVAL

  (provide ()
    (def env (current-environment))
    (eval (list def (quote x) #t) env)
    (assert (eq? x #t))

    (assert (eq? (eval #t env) #t)))

  ;; WRAP

  (provide ()
    (assert (eq? #t ((wrap (vau (x) #ign x)) (not #f)))))

  ;; UNWRAP

  (provide ()
    (assert (eq? list (unwrap (wrap list)))))

  ;; EQ?

  (provide ()
    (assert (eq? #t #t))
    (assert (not (eq? #t #f)))
    (assert (not (eq? (list 1) (list 1)))))

  ;; CONS

  (provide ()
    (assert (eq? #t (car (cons #t #f))))
    (assert (eq? #f (cdr (cons #t #f)))))

  ;; MAKE-ENVIRONMENT

  (provide ()
    (def e1 (make-environment))
    (eval (list def (quote x) #t) e1)
    (eval (list def (quote y) #t) e1)
    (assert (eq? #t (eval (quote x) e1)))
    (assert (eq? #t (eval (quote y) e1)))

    (def e2 (make-environment e1))
    (assert (eq? #t (eval (quote x) e2)))
    (assert (eq? #t (eval (quote y) e2)))
    (eval (list def (quote y) #f) e2)
    (assert (eq? #f (eval (quote y) e2)))
    (assert (eq? #t (eval (quote y) e1))))

  ;; MAKE-TYPE

  (provide ()
    (def type (make-type))
    (assert (eq? (type-of type) (type-of (type-of #t)))))

  ;; TYPE-ENVIRONMENT

  (provide ()
    (def type (make-type))
    (def tenv (type-environment type))
    (assert (eq? (type-of tenv) (type-of (current-environment)))))

  ;; TYPE-OF

  (provide ()
    (assert (not (eq? (type-of () #void))))
    (assert (eq? (type-of 0) (type-of 1))))

  ;; TAG, UNTAG

  (provide ()
    (def type (make-type))
    (def tagged (tag type #t))
    (assert (eq? (type-of tagged) type))
    (assert (eq? (untag tagged) #t)))

  ;; VECTOR, VECTOR-REF

  (provide ()
    (def (a b c) (list 1 2 3))
    (def v (vector a b c))
    (assert (eq? (vector-ref v 0) a))
    (assert (eq? (vector-ref v 1) b))
    (assert (eq? (vector-ref v 2) c)))

  ;; Quotation

  (provide ()
    (assert (symbol? 'x))
    (assert (pair? '(a . b))))

  ;;;;; Test Crust Language

  ;; NULL?

  (provide ()
    (assert (null? ()))
    (assert (not (null? 12))))

  ;; BEGIN

  (provide ()
    (assert (eq? #void (begin)))
    (assert (eq? #t (begin (eq? #t #t))))
    (assert (eq? #t (begin #f (eq? #t #t)))))

  ;; Continuation Marks

  (provide ()
    (eq? () (current-marks 'foo))
    (eq? #t (with-mark 'foo #t (car (current-marks 'foo))))
    (eq? #f (with-mark 'foo #t (with-mark 'foo #f (car (current-marks 'foo)))))
    (eq? () (with-mark 'foo #t (with-mark 'foo #f (cdr (current-marks 'foo)))))
    (define (id x) x)
    (eq? #f (with-mark 'foo #t (id (with-mark 'foo #f (car (current-marks 'foo))))))
    (eq? #t (with-mark 'foo #t (id (with-mark 'foo #f (car (cdr (current-marks 'foo)))))))
    (eq? () (with-mark 'foo #t (id (with-mark 'foo #f (cdr (cdr (current-marks 'foo)))))))
    (eq? () (current-marks 'foo)))

  ;; Delimited Control

(define-syntax test-check
  (vau (#ign expr res) env
    (assert (= (display (eval expr env)) (eval res env)))))

(define new-prompt make-prompt)

(test-check 'test2
  (let ((p (new-prompt)))
    (+ (push-prompt p (push-prompt p 5))
       4))
  9)

(test-check 'test3
  (let ((p (new-prompt)))
    (+ (push-prompt p (+ (take-sub-cont p (lambda #ign 5)) 6))
       4))
  9)

(test-check 'test3-1
  (let ((p (new-prompt)))
    (+ (push-prompt p (push-prompt p (+ (take-sub-cont p (lambda #ign 5)) 6)))
       4))
  9)

(test-check 'test3-2
  (let ((p (new-prompt)))
    (let ((v (push-prompt p
	       (let* ((v1 (push-prompt p (+ (take-sub-cont p (lambda #ign 5)) 6)))
		      (v1 (take-sub-cont p (lambda #ign 7))))
		 (+ v1 10)))))
      (+ v 20)))
  27)

(test-check 'test4
  (let ((p (make-prompt)))
    (+ (push-prompt p
         (+ (take-sub-cont p (lambda (sk) (push-sub-cont sk 5)))
	    7))
       20))
  32)

(test-check 'test6
  (let ((p1 (new-prompt))
	(p2 (new-prompt))
	(push-twice (lambda (sk)
		      (push-sub-cont sk (push-sub-cont sk 3)))))
    (+ 10
      (push-prompt p1 (+ 1
        (push-prompt p2 (take-sub-cont p1 (lambda (sk) (push-twice sk))))))))
  15)

(test-check 'test7
  (let* ((p1 (new-prompt))
	 (p2 (new-prompt))
	 (p3 (new-prompt))
	 (push-twice
	    (lambda (sk)
	      (push-sub-cont sk (push-sub-cont sk
		(take-sub-cont p2 (lambda (sk2)
		  (push-sub-cont sk2
		    (push-sub-cont sk2 3)))))))))
    (+ 100
      (push-prompt p1
	(+ 1
	  (push-prompt p2
	    (+ 10
	      (push-prompt p3 (take-sub-cont p1 (lambda (sk) (push-twice sk))))))))))
  135)

(test-check 'monadic-paper
  (let ((p (make-prompt)))
    (+ 2 (push-prompt p
            (if (take-sub-cont p
                  (lambda (k)
		    (+ (push-sub-cont k #f)
		       (push-sub-cont k #t))))
		3
		4))))
  9)

;; -*- mode: scheme -*-

  ;;;;; Test Core Language

  ;; DEF

  (provide ()
    (def (x y) (list #t #f))
    (assert (eq? x #t))
    (assert (eq? y #f))

    (assert (eq? (def #ign #t) #t)))

  ;; IF

  (provide ()
    (assert (eq? #t (if #t #t #f)))
    (assert (eq? #f (if #f #t #f))))

  ;; VAU

  (provide ()
    (def env (current-environment))
    (eq? #t ((vau x #ign x) #t))
    (eq? #t ((vau (x . #ign) #ign x) (list #t)))
    (eq? env ((vau #ign e e))))

  ;; EVAL

  (provide ()
    (def env (current-environment))
    (eval (list def (quote x) #t) env)
    (assert (eq? x #t))

    (assert (eq? (eval #t env) #t)))

  ;; WRAP

  (provide ()
    (assert (eq? #t ((wrap (vau (x) #ign x)) (not #f)))))

  ;; UNWRAP

  (provide ()
    (assert (eq? list (unwrap (wrap list)))))

  ;; EQ?

  (provide ()
    (assert (eq? #t #t))
    (assert (not (eq? #t #f)))
    (assert (not (eq? (list 1) (list 1)))))

  ;; CONS

  (provide ()
    (assert (eq? #t (car (cons #t #f))))
    (assert (eq? #f (cdr (cons #t #f)))))

  ;; MAKE-ENVIRONMENT

  (provide ()
    (def e1 (make-environment))
    (eval (list def (quote x) #t) e1)
    (eval (list def (quote y) #t) e1)
    (assert (eq? #t (eval (quote x) e1)))
    (assert (eq? #t (eval (quote y) e1)))

    (def e2 (make-environment e1))
    (assert (eq? #t (eval (quote x) e2)))
    (assert (eq? #t (eval (quote y) e2)))
    (eval (list def (quote y) #f) e2)
    (assert (eq? #f (eval (quote y) e2)))
    (assert (eq? #t (eval (quote y) e1))))

  ;; MAKE-TYPE

  (provide ()
    (def type (make-type))
    (assert (eq? (type-of type) (type-of (type-of #t)))))

  ;; TYPE-ENVIRONMENT

  (provide ()
    (def type (make-type))
    (def tenv (type-environment type))
    (assert (eq? (type-of tenv) (type-of (current-environment)))))

  ;; TYPE-OF

  (provide ()
    (assert (not (eq? (type-of () #void))))
    (assert (eq? (type-of 0) (type-of 1))))

  ;; TAG, UNTAG

  (provide ()
    (def type (make-type))
    (def tagged (tag type #t))
    (assert (eq? (type-of tagged) type))
    (assert (eq? (untag tagged) #t)))

  ;; VECTOR, VECTOR-REF

  (provide ()
    (def (a b c) (list 1 2 3))
    (def v (vector a b c))
    (assert (eq? (vector-ref v 0) a))
    (assert (eq? (vector-ref v 1) b))
    (assert (eq? (vector-ref v 2) c)))

  ;; Quotation

  (provide ()
    (assert (symbol? 'x))
    (assert (pair? '(a . b))))

  ;;;;; Test Crust Language

  ;; NULL?

  (provide ()
    (assert (null? ()))
    (assert (not (null? 12))))

  ;; BEGIN

  (provide ()
    (assert (eq? #void (begin)))
    (assert (eq? #t (begin (eq? #t #t))))
    (assert (eq? #t (begin #f (eq? #t #t)))))

  ;; Continuation Marks

  (provide ()
    (eq? () (current-marks 'foo))
    (eq? #t (with-mark 'foo #t (car (current-marks 'foo))))
    (eq? #f (with-mark 'foo #t (with-mark 'foo #f (car (current-marks 'foo)))))
    (eq? () (with-mark 'foo #t (with-mark 'foo #f (cdr (current-marks 'foo)))))
    (define (id x) x)
    (eq? #f (with-mark 'foo #t (id (with-mark 'foo #f (car (current-marks 'foo))))))
    (eq? #t (with-mark 'foo #t (id (with-mark 'foo #f (car (cdr (current-marks 'foo)))))))
    (eq? () (with-mark 'foo #t (id (with-mark 'foo #f (cdr (cdr (current-marks 'foo)))))))
    (eq? () (current-marks 'foo)))

  ;; Delimited Control

(define-syntax test-check
  (vau (#ign expr res) env
    (assert (= (display (eval expr env)) (eval res env)))))

(define new-prompt make-prompt)

(test-check 'test2
  (let ((p (new-prompt)))
    (+ (push-prompt p (push-prompt p 5))
       4))
  9)

(test-check 'test3
  (let ((p (new-prompt)))
    (+ (push-prompt p (+ (take-sub-cont p (lambda #ign 5)) 6))
       4))
  9)

(test-check 'test3-1
  (let ((p (new-prompt)))
    (+ (push-prompt p (push-prompt p (+ (take-sub-cont p (lambda #ign 5)) 6)))
       4))
  9)

(test-check 'test3-2
  (let ((p (new-prompt)))
    (let ((v (push-prompt p
	       (let* ((v1 (push-prompt p (+ (take-sub-cont p (lambda #ign 5)) 6)))
		      (v1 (take-sub-cont p (lambda #ign 7))))
		 (+ v1 10)))))
      (+ v 20)))
  27)

(test-check 'test4
  (let ((p (make-prompt)))
    (+ (push-prompt* p
         (lambda ()
	   (+ (take-sub-cont p (lambda (sk) (push-sub-cont* sk (lambda () 5))))
	      7)))
       20))
  32)

(test-check 'test6
  (let ((p1 (new-prompt))
	(p2 (new-prompt))
	(push-twice (lambda (sk)
		      (push-sub-cont* sk (lambda () (push-sub-cont* sk (lambda () 3)))))))
    (+ 10
      (push-prompt* p1 (lambda () (+ 1
             			(push-prompt* p2 (lambda () (take-sub-cont p1 (lambda (sk) (push-twice sk))))))))))
  15)

(test-check 'test7
  (let* ((p1 (new-prompt))
	 (p2 (new-prompt))
	 (p3 (new-prompt))
	 (push-twice
	    (lambda (sk)
	      (push-sub-cont* sk (lambda () (push-sub-cont* sk (lambda ()
		(take-sub-cont p2 (lambda (sk2)
		  (push-sub-cont* sk2 (lambda ()
		    (push-sub-cont* sk2 (lambda () 3)))))))))))))
    (+ 100
      (push-prompt* p1 (lambda ()
	(+ 1
	  (push-prompt* p2 (lambda ()
	    (+ 10
	      (push-prompt* p3  (lambda () (take-sub-cont p1 (lambda (sk) (push-twice sk)))))))))))))
  135)

(test-check 'monadic-paper
  (let ((p (make-prompt)))
    (+ 2 (push-prompt* p (lambda ()
		      (if (take-sub-cont p
					 (lambda (k)
					   (+ (push-sub-cont* k (lambda () #f))
					      (push-sub-cont* k (lambda () #t)))))
			  3
			  4)))))
  9)


Update wasm-table.wat

Update wasm-table.wat

(module
  (table 2 anyfunc)
  (func $f1 (result i32)
    i32.const 42)
  (func $f2 (result i32)
    i32.const 13)
  (elem (i32.const 0) $f1 $f2)
  (type $return_i32 (func (result i32)))
  (func (export "callByIndex") (param $i i32) (result i32)
    local.get $i
    call_indirect (type $return_i32)))

(module
  (table 2 anyfunc)
  (func $f1 (result i32)
    i32.const 42)
  (func $f2 (result i32)
    i32.const 13)
  (elem (i32.const 0) $f1 $f2)
  (type $return_i32 (func (result i32)))
  (func (export "callByIndex") (param $i i32) (result i32)
    local.get $i
    call_indirect (type $return_i32))
)


More typechecking.

More typechecking.

;; -*- mode: scheme -*-

(define-module man (document section para render)

  (define *current-parent* (dnew null))

  (define-prototype Document
    (id
     title
     children))

  (define-prototype Section
    (id
     parent
     title
     children))

  (define-prototype Para
    (text
     parent))

  (defun (make-document (id String) (title String) -> Document)
    (new Document id title (array)))

  (define-macro (document id title)
    (list define id (list make-document (symbol-name id) title)))

  (defun (make-section (id String) (parent Document) (title String) -> Section)
    (let ((sec (new Section id parent title (array))))
      (#push (.children parent) sec)
      sec))

  (define-macro (section (parent id) title &rest children)
    (list begin
      (list define id (list make-section (symbol-name id) parent title))
        (list* dlet *current-parent* id
               children)))

  (defun (para (text String) -> Para)
    (let* ((parent (dref *current-parent*))
           (para (new Para text (the Section parent))))
      (#push (.children parent) para)
      para))

  (define-generic (render item -> contents))

  (define-method (render (doc Document) -> String)
    (apply cat (list* (cat "
" (.title doc) "
\n")
                      (map-list render (array-to-list (.children doc))))))

  (define-method (render (sec Section) -> String)
    (apply cat (list* (cat "
" (.title sec) "
\n")
                      (map-list render (array-to-list (.children sec))))))

  (define-method (render (para Para) -> String)
    (cat "
" (.text para) "
\n"))

  )

;; -*- mode: scheme -*-

(define-module man (document section para render)

  (define *current-parent* (dnew null))

  (define-prototype Document
    (id
     title
     children))

  (define-prototype Section
    (id
     parent
     title
     children))

  (define-prototype Para
    (text
     parent))

  (defun (make-document (id String) (title String) -> Document)
    (new Document id title (array)))

  (define-macro (document id title)
    (list define id (list make-document (symbol-name id) title)))

  (define (make-section id parent title)
    (let ((sec (new Section id parent title (array))))
      (#push (.children parent) sec)
    sec))

  (define-macro (section (parent id) title &rest children)
    (list begin
      (list define id (list make-section (symbol-name id) parent title))
        (list* dlet *current-parent* id
               children)))

  (define (para text)
    (let* ((parent (dref *current-parent*))
           (para (new Para text parent)))
      (#push (.children parent) para)
      para))

  (define-generic (render item -> contents))

  (define-method (render (doc Document) -> String)
    (apply cat (list* (cat "
" (.title doc) "
\n")
                      (map-list render (array-to-list (.children doc))))))

  (define-method (render (sec Section) -> String)
    (apply cat (list* (cat "
" (.title sec) "
\n")
                      (map-list render (array-to-list (.children sec))))))

  (define-method (render (para Para) -> String)
    (cat "
" (.text para) "
\n"))

  )


Update mem-access.wat

Update mem-access.wat

(module
  (type $t0 (func (result i32)))
  (type $t1 (func (param i32)))
  (import "./memory.wat" "memory" (memory $./memory.wasm.memory 1))
  (func $get (export "get") (type $t0) (result i32)
    (i32.load
      (i32.const 0)))
  (func $set (export "set") (type $t1) (param $p i32)
    (i32.store
      (i32.const 0)
      (get_local $p))))


attempt at block

attempt at block

;; -*- mode: scheme -*-
;; This is the hard crust of Wat code around the JS core defined in `wat.js`.

(def quote (vau (x) #ign x))

(def Void (type-of #void))
(def Ign (type-of #ign))
(def Boolean (type-of #t))
(def Nil (type-of ()))
(def Pair (type-of (cons #void #void)))
(def Symbol (type-of 'foo))
(def String (type-of "foo"))
(def Number (type-of 0))
(def Applicative (type-of (wrap (vau #ign #ign #void))))
(def Operative (type-of (vau #ign #ign #void)))
(def Environment (type-of (make-environment)))
(def Vector (type-of (vector)))
(def Type (type-of (make-type)))

(def void? (wrap (vau (val) #ign (eq? #void val))))
(def ign? (wrap (vau (val) #ign (eq? #ign val))))
(def boolean? (wrap (vau (val) #ign (eq? (type-of val) Boolean))))
(def null? (wrap (vau (val) #ign (eq? () val))))
(def pair? (wrap (vau (val) #ign (eq? (type-of val) Pair))))
(def symbol? (wrap (vau (val) #ign (eq? (type-of val) Symbol))))
(def string? (wrap (vau (val) #ign (eq? (type-of val) String))))
(def symbol? (wrap (vau (val) #ign (eq? (type-of val) Symbol))))
(def number? (wrap (vau (val) #ign (eq? (type-of val) Number))))
(def applicative? (wrap (vau (val) #ign (eq? (type-of val) Applicative))))
(def operative? (wrap (vau (val) #ign (eq? (type-of val) Operative))))
(def environment? (wrap (vau (val) #ign (eq? (type-of val) Environment))))
(def vector? (wrap (vau (val) #ign (eq? (type-of val) Vector))))
(def type? (wrap (vau (val) #ign (eq? (type-of val) Type))))

;; (def begin
;;    ((wrap (vau (seq2) #ign
;;             (seq2
;;               (def aux
;;                 (vau (head . tail) env
;;                   (if (null? tail)
;;                       (eval head env)
;;                       (seq2
;;                         (eval head env)
;;                         (eval (cons aux tail) env)))))
;;                (vau body env
;;                  (if (null? body)
;;                      #void
;;                      (eval (cons aux body) env))))))
;;       (vau (first second) env
;;          ((wrap (vau #ign #ign (eval second env)))
;;           (eval first env)))))

(def list (wrap (vau x #ign x)))

(def list*
  (wrap (vau args #ign
          (begin
            (def aux
              (wrap (vau ((head . tail)) #ign
                      (if (null? tail)
			  head
			  (cons head (aux tail))))))
	    (aux args)))))

(def vau
  ((wrap (vau (vau) #ign
           (vau (formals eformal . body) env
             (eval (list vau formals eformal (cons begin body)) env))))
   vau))

(def lambda
  (vau (formals . body) env
    (wrap (eval (list* vau formals #ign body) env))))

(def car (lambda ((x . #ign)) x))
(def cdr (lambda ((#ign . x)) x))
(def caar (lambda (((x . #ign) . #ign)) x))
(def cadr (lambda ((#ign . (x . #ign))) x))
(def cdar (lambda (((#ign . x) . #ign)) x))
(def cddr (lambda ((#ign . (#ign . x))) x))

(def map (lambda (f l) (if (null? l) () (cons (f (car l)) (map f (cdr l))))))
(def map2 (lambda (f l1 l2)
            (if (null? l1)
                ()
                (if (null? l2)
                    ()
                    (cons (f (car l1) (car l2)) (map2 f (cdr l1) (cdr l2)))))))

(def for-each (lambda (f l) (if (null? l) #void (begin (f (car l)) (for-each f (cdr l))))))

(def let
  (vau (bindings . body) env
    (eval (cons (list* lambda (map car bindings) body)
		(map cadr bindings))
	  env)))

(def let*
  (vau (bindings . body) env
    (eval (if (null? bindings)
	      (list* let bindings body)
	      (list let
		    (list (car bindings))
		    (list* let* (cdr bindings) body)))
	  env)))

(def letrec
  (vau (bindings . body) env
    (eval (list* let ()
		 (list def
		       (map car bindings)
		       (list* list (map cadr bindings)))
		 body)
	  env)))

(def apply
  (lambda (appv arg . opt)
    (eval (cons (unwrap appv) arg)
	  (if (null? opt)
	      (make-environment)
	      (car opt)))))

(def cond
  (vau clauses env
    (def aux
      (lambda ((test . body) . clauses)
	(if (eval test env)
	    (apply (wrap begin) body env)
	    (apply (wrap cond) clauses env))))
    (if (null? clauses)
	#void
	(apply aux clauses))))

(def assert (vau (expr) e (if (eval expr e) #void (fail expr))))

(def not (lambda (val) (if val #f #t)))

(def or (vau (a b) env (if (eval a env) #t (eval b env))))

(def and (vau (a b) env (if (eval a env) (eval b env) #f)))

(def when (vau (test . body) env (eval (list if test (list* begin body) #void) env)))

(def unless (vau (test . body) env (eval (list* when (list not test) body) env)))

(def set!
   (vau (env lhs rhs) denv
      (eval (list def lhs
                  (list (unwrap eval) rhs denv))
            (eval env denv))))

(def provide
  (vau (symbols . body) env
    (eval (list def symbols
		(list let ()
		      (list* begin body)
		      (list* list symbols)))
	  env)))

(def current-environment (vau #ign e e))

(def define
  (vau (lhs . rhs) env
    (if (pair? lhs)
	(let* (((name . args) lhs)
               (proc (eval (list* lambda args rhs) env)))
	  (eval (list def name proc) env)
          (set-label! proc (symbol->string name)))
	(eval (list* def lhs rhs) env))))

(def define-syntax
  (vau (lhs . rhs) env
    (if (pair? lhs)
	(let* (((name . args) lhs)
               (opv (eval (list* vau args (car rhs) (cdr rhs)) env)))
	  (eval (list def name opv) env)
          (set-label! opv (symbol->string name)))
	(eval (list* def lhs rhs) env))))

(define-syntax (define-record-type name (ctor-name . ctor-field-names) pred-name . field-specs) env
  (let* (((type tagger untagger) (make-type))
         (ctor (lambda ctor-args
                 (let ((fields-dict (make-environment)))
                   (map2 (lambda (field-name arg)
                           (eval (list def field-name arg) fields-dict))
                         ctor-field-names
                         ctor-args)
                   (tagger fields-dict))))
         (pred (lambda (obj) (eq? (type-of obj) type))))
    (eval (list def (list name ctor-name pred-name) (list list type ctor pred)) env)
    (set-label! type (symbol->string name))
    (map (lambda (field-spec)
           (let (((name accessor-name . opt) field-spec))
             (eval (list def accessor-name (lambda (obj)
                                             (let ((fields-dict (untagger obj)))
                                               (eval name fields-dict))))
                   env)
             (unless (null? opt)
               (let (((modifier-name) opt))
                 (eval (list def modifier-name (lambda (obj new-val)
                                                 (let ((fields-dict (untagger obj)))
                                                   (eval (list def name new-val) fields-dict))))
                       env)))))
         field-specs)
    type))

(define-syntax (dlet dv val . exprs) env
  (eval (list dlet* dv val (list* lambda () exprs)) env))

(define-syntax (coroutine . exprs) env
  (coroutine* (eval (list* lambda () exprs) env)))

;; (define-syntax (block name . exprs) env
;;   (letrec ((aborter (lambda (val) (throw aborter val))))
;;     (eval (list* let (list (list name aborter))
;;             (list* catch aborter exprs))
;;           env)))

(provide (define-generic define-method put-method!)
  (define generic->vtable (make-identity-hashtable))
  (define-syntax (define-generic (name . args) . body) env
    (define vtable (make-identity-hashtable))
    (define default-method (if (null? body)
                               (lambda #ign (fail "method not found"))
                               (eval (list* lambda args body) env)))
    (define (generic self . arg)
      (apply (hashtable-get vtable (type-of self) default-method) (cons self arg)))
    (set-label! generic (symbol->string name))
    (eval (list def name generic) env)
    (hashtable-put! generic->vtable generic vtable)
    generic)
  (define (put-method! generic type method)
    (define vtable (hashtable-get generic->vtable generic))
    (hashtable-put! vtable type method))
  (define-syntax (define-method (name (self type) . args) . body) env
    (define method (eval (list* lambda (list* self args) body) env))
    (put-method! (eval name env) (eval type env) method))
)

(provide (= /=)
  (define-generic (= a b) (eq? a b))
  (define-syntax (define-builtin-= type-name pred-expr) env
    (define type (eval type-name env))
    (define pred (eval pred-expr env))
    (put-method! = type (lambda (a b) (if (eq? type (type-of b)) (pred a b) #f))))
  (define-builtin-= Number num=)
  (define-builtin-= String str=)
  (define-builtin-= Symbol (lambda (a b) (= (symbol->string a) (symbol->string b))))
  (define (/= a b) (not (= a b)))
)

(provide (< > <= >=)
  (define-generic (< a b))
  (define-method (< (a Number) b) (if (number? b) (num< a b) (fail "can't compare number")))
  (define (> a b) (< b a))
  (define (<= a b) (or (< a b) (= a b)))
  (define (>= a b) (or (> a b) (= a b)))
)

(provide (hash-code)
  (define-generic (hash-code obj) (identity-hash-code obj))
)

(provide (->string)
  (define-generic (->string obj) (strcat "#[" (label obj) "]"))
  (define-method (->string (obj Void)) "#void")
  (define-method (->string (obj Ign)) "#ign")
  (define-method (->string (obj Boolean)) (if obj "#t" "#f"))
  (define-method (->string (obj Nil)) "()")
  (define-method (->string (obj Pair))
    (define (pair->string (kar . kdr))
      (if (null? kdr)
          (->string kar)
          (if (pair? kdr)
              (strcat (->string kar) " " (pair->string kdr))
              (strcat (->string kar) " . " (->string kdr)))))
    (strcat "(" (pair->string obj) ")"))
  (define-method (->string (obj Symbol)) (symbol->string obj))
  (define-method (->string (obj String)) (str-print obj))
  (define-method (->string (obj Number)) (number->string obj))
  (define-method (->string (obj Applicative)) (strcat "#[Applicative " (label obj) "]"))
  (define-method (->string (obj Operative)) (strcat "#[Operative " (label obj) "]"))
  (define-method (->string (obj Environment)) "#[Environment]")
  (define-method (->string (obj Vector)) "#[Vector]")
)

;; -*- mode: scheme -*-
;; This is the hard crust of Wat code around the JS core defined in `wat.js`.

(def quote (vau (x) #ign x))

(def Void (type-of #void))
(def Ign (type-of #ign))
(def Boolean (type-of #t))
(def Nil (type-of ()))
(def Pair (type-of (cons #void #void)))
(def Symbol (type-of 'foo))
(def String (type-of "foo"))
(def Number (type-of 0))
(def Applicative (type-of (wrap (vau #ign #ign #void))))
(def Operative (type-of (vau #ign #ign #void)))
(def Environment (type-of (make-environment)))
(def Vector (type-of (vector)))
(def Type (type-of (make-type)))

(def void? (wrap (vau (val) #ign (eq? #void val))))
(def ign? (wrap (vau (val) #ign (eq? #ign val))))
(def boolean? (wrap (vau (val) #ign (eq? (type-of val) Boolean))))
(def null? (wrap (vau (val) #ign (eq? () val))))
(def pair? (wrap (vau (val) #ign (eq? (type-of val) Pair))))
(def symbol? (wrap (vau (val) #ign (eq? (type-of val) Symbol))))
(def string? (wrap (vau (val) #ign (eq? (type-of val) String))))
(def symbol? (wrap (vau (val) #ign (eq? (type-of val) Symbol))))
(def number? (wrap (vau (val) #ign (eq? (type-of val) Number))))
(def applicative? (wrap (vau (val) #ign (eq? (type-of val) Applicative))))
(def operative? (wrap (vau (val) #ign (eq? (type-of val) Operative))))
(def environment? (wrap (vau (val) #ign (eq? (type-of val) Environment))))
(def vector? (wrap (vau (val) #ign (eq? (type-of val) Vector))))
(def type? (wrap (vau (val) #ign (eq? (type-of val) Type))))

;; (def begin
;;    ((wrap (vau (seq2) #ign
;;             (seq2
;;               (def aux
;;                 (vau (head . tail) env
;;                   (if (null? tail)
;;                       (eval head env)
;;                       (seq2
;;                         (eval head env)
;;                         (eval (cons aux tail) env)))))
;;                (vau body env
;;                  (if (null? body)
;;                      #void
;;                      (eval (cons aux body) env))))))
;;       (vau (first second) env
;;          ((wrap (vau #ign #ign (eval second env)))
;;           (eval first env)))))

(def list (wrap (vau x #ign x)))

(def list*
  (wrap (vau args #ign
          (begin
            (def aux
              (wrap (vau ((head . tail)) #ign
                      (if (null? tail)
			  head
			  (cons head (aux tail))))))
	    (aux args)))))

(def vau
  ((wrap (vau (vau) #ign
           (vau (formals eformal . body) env
             (eval (list vau formals eformal (cons begin body)) env))))
   vau))

(def lambda
  (vau (formals . body) env
    (wrap (eval (list* vau formals #ign body) env))))

(def car (lambda ((x . #ign)) x))
(def cdr (lambda ((#ign . x)) x))
(def caar (lambda (((x . #ign) . #ign)) x))
(def cadr (lambda ((#ign . (x . #ign))) x))
(def cdar (lambda (((#ign . x) . #ign)) x))
(def cddr (lambda ((#ign . (#ign . x))) x))

(def map (lambda (f l) (if (null? l) () (cons (f (car l)) (map f (cdr l))))))
(def map2 (lambda (f l1 l2)
            (if (null? l1)
                ()
                (if (null? l2)
                    ()
                    (cons (f (car l1) (car l2)) (map2 f (cdr l1) (cdr l2)))))))

(def for-each (lambda (f l) (if (null? l) #void (begin (f (car l)) (for-each f (cdr l))))))

(def let
  (vau (bindings . body) env
    (eval (cons (list* lambda (map car bindings) body)
		(map cadr bindings))
	  env)))

(def let*
  (vau (bindings . body) env
    (eval (if (null? bindings)
	      (list* let bindings body)
	      (list let
		    (list (car bindings))
		    (list* let* (cdr bindings) body)))
	  env)))

(def letrec
  (vau (bindings . body) env
    (eval (list* let ()
		 (list def
		       (map car bindings)
		       (list* list (map cadr bindings)))
		 body)
	  env)))

(def apply
  (lambda (appv arg . opt)
    (eval (cons (unwrap appv) arg)
	  (if (null? opt)
	      (make-environment)
	      (car opt)))))

(def cond
  (vau clauses env
    (def aux
      (lambda ((test . body) . clauses)
	(if (eval test env)
	    (apply (wrap begin) body env)
	    (apply (wrap cond) clauses env))))
    (if (null? clauses)
	#void
	(apply aux clauses))))

(def assert (vau (expr) e (if (eval expr e) #void (fail expr))))

(def not (lambda (val) (if val #f #t)))

(def or (vau (a b) env (if (eval a env) #t (eval b env))))

(def and (vau (a b) env (if (eval a env) (eval b env) #f)))

(def when (vau (test . body) env (eval (list if test (list* begin body) #void) env)))

(def unless (vau (test . body) env (eval (list* when (list not test) body) env)))

(def set!
   (vau (env lhs rhs) denv
      (eval (list def lhs
                  (list (unwrap eval) rhs denv))
            (eval env denv))))

(def provide
  (vau (symbols . body) env
    (eval (list def symbols
		(list let ()
		      (list* begin body)
		      (list* list symbols)))
	  env)))

(def current-environment (vau #ign e e))

(def define
  (vau (lhs . rhs) env
    (if (pair? lhs)
	(let* (((name . args) lhs)
               (proc (eval (list* lambda args rhs) env)))
	  (eval (list def name proc) env)
          (set-label! proc (symbol->string name)))
	(eval (list* def lhs rhs) env))))

(def define-syntax
  (vau (lhs . rhs) env
    (if (pair? lhs)
	(let* (((name . args) lhs)
               (opv (eval (list* vau args (car rhs) (cdr rhs)) env)))
	  (eval (list def name opv) env)
          (set-label! opv (symbol->string name)))
	(eval (list* def lhs rhs) env))))

(define-syntax (define-record-type name (ctor-name . ctor-field-names) pred-name . field-specs) env
  (let* (((type tagger untagger) (make-type))
         (ctor (lambda ctor-args
                 (let ((fields-dict (make-environment)))
                   (map2 (lambda (field-name arg)
                           (eval (list def field-name arg) fields-dict))
                         ctor-field-names
                         ctor-args)
                   (tagger fields-dict))))
         (pred (lambda (obj) (eq? (type-of obj) type))))
    (eval (list def (list name ctor-name pred-name) (list list type ctor pred)) env)
    (set-label! type (symbol->string name))
    (map (lambda (field-spec)
           (let (((name accessor-name . opt) field-spec))
             (eval (list def accessor-name (lambda (obj)
                                             (let ((fields-dict (untagger obj)))
                                               (eval name fields-dict))))
                   env)
             (unless (null? opt)
               (let (((modifier-name) opt))
                 (eval (list def modifier-name (lambda (obj new-val)
                                                 (let ((fields-dict (untagger obj)))
                                                   (eval (list def name new-val) fields-dict))))
                       env)))))
         field-specs)
    type))

(define-syntax (dlet dv val . exprs) env
  (eval (list dlet* dv val (list* lambda () exprs)) env))

(define-syntax (coroutine . exprs) env
  (coroutine* (eval (list* lambda () exprs) env)))

(provide (define-generic define-method put-method!)
  (define generic->vtable (make-identity-hashtable))
  (define-syntax (define-generic (name . args) . body) env
    (define vtable (make-identity-hashtable))
    (define default-method (if (null? body)
                               (lambda #ign (fail "method not found"))
                               (eval (list* lambda args body) env)))
    (define (generic self . arg)
      (apply (hashtable-get vtable (type-of self) default-method) (cons self arg)))
    (set-label! generic (symbol->string name))
    (eval (list def name generic) env)
    (hashtable-put! generic->vtable generic vtable)
    generic)
  (define (put-method! generic type method)
    (define vtable (hashtable-get generic->vtable generic))
    (hashtable-put! vtable type method))
  (define-syntax (define-method (name (self type) . args) . body) env
    (define method (eval (list* lambda (list* self args) body) env))
    (put-method! (eval name env) (eval type env) method))
)

(provide (= /=)
  (define-generic (= a b) (eq? a b))
  (define-syntax (define-builtin-= type-name pred-expr) env
    (define type (eval type-name env))
    (define pred (eval pred-expr env))
    (put-method! = type (lambda (a b) (if (eq? type (type-of b)) (pred a b) #f))))
  (define-builtin-= Number num=)
  (define-builtin-= String str=)
  (define-builtin-= Symbol (lambda (a b) (= (symbol->string a) (symbol->string b))))
  (define (/= a b) (not (= a b)))
)

(provide (< > <= >=)
  (define-generic (< a b))
  (define-method (< (a Number) b) (if (number? b) (num< a b) (fail "can't compare number")))
  (define (> a b) (< b a))
  (define (<= a b) (or (< a b) (= a b)))
  (define (>= a b) (or (> a b) (= a b)))
)

(provide (hash-code)
  (define-generic (hash-code obj) (identity-hash-code obj))
)

(provide (->string)
  (define-generic (->string obj) (strcat "#[" (label obj) "]"))
  (define-method (->string (obj Void)) "#void")
  (define-method (->string (obj Ign)) "#ign")
  (define-method (->string (obj Boolean)) (if obj "#t" "#f"))
  (define-method (->string (obj Nil)) "()")
  (define-method (->string (obj Pair))
    (define (pair->string (kar . kdr))
      (if (null? kdr)
          (->string kar)
          (if (pair? kdr)
              (strcat (->string kar) " " (pair->string kdr))
              (strcat (->string kar) " . " (->string kdr)))))
    (strcat "(" (pair->string obj) ")"))
  (define-method (->string (obj Symbol)) (symbol->string obj))
  (define-method (->string (obj String)) (str-print obj))
  (define-method (->string (obj Number)) (number->string obj))
  (define-method (->string (obj Applicative)) (strcat "#[Applicative " (label obj) "]"))
  (define-method (->string (obj Operative)) (strcat "#[Operative " (label obj) "]"))
  (define-method (->string (obj Environment)) "#[Environment]")
  (define-method (->string (obj Vector)) "#[Vector]")
)


Update table2.wat

Update table2.wat

(module
  (import "js" "tbl" (table 2 anyfunc))
  (func $f42 (result i32) i32.const 42)
  (func $f83 (result i32) i32.const 83)
  (elem (i32.const 0) $f42 $f83)
)

(module
  (import "js" "tbl" (table 2 anyfunc))
  (func $f42 (result i32) i32.const 42)
  (func $f83 (result i32) i32.const 83)
  (elem (i32.const 0) $f42 $f83))


Implement while as operative

Implement while as operative

;; -*- mode: lisp -*-

;; ``72. An adequate bootstrap is a contradiction in terms.''

;; Rename ur-def
(vm-def _def vm-def)

;; Rename bindings that will be used as provided by VM
(_def array-to-list vm-array-to-list)
(_def begin vm-begin)
(_def cons vm-cons)
(_def cons? vm-cons?)
(_def dnew vm-dnew)
(_def dref vm-dref)
(_def error vm-error)
(_def eval vm-eval)
(_def if vm-if)
(_def js-getter vm-js-getter)
(_def js-global vm-js-global)
(_def js-invoker vm-js-invoker)
(_def list* vm-list*)
(_def list-to-array vm-list-to-array)
(_def make-environment vm-make-environment)
(_def new vm-js-new)
(_def nil? vm-nil?)
(_def reverse-list vm-reverse-list)
(_def setter vm-setter)
(_def symbol-name vm-symbol-name)
(_def symbol? vm-symbol?)
(_def throw vm-throw)
(_def unwrap vm-unwrap)
(_def wrap vm-wrap)

;; Important utilities
(_def quote (vm-vau (x) #ignore x))
(_def list (wrap (vm-vau elts #ignore elts)))
(_def the-environment (vm-vau () e e))

;;;; Macro and vau

(_def make-macro-expander
  (wrap
    (vm-vau (expander) #ignore
      (vm-vau operands env
        (eval (eval (cons expander operands) (make-environment)) env)))))

(_def _vau
  (make-macro-expander
    (vm-vau (params env-param . body) #ignore
      (list vm-vau params env-param (list* begin body)))))

(_def macro
  (make-macro-expander
    (_vau (params . body) #ignore
      (list make-macro-expander (list* _vau params #ignore body)))))

(_def defmacro
  (macro ((name . params) . body)
    (list _def name (list* macro params body))))

(defmacro (_lambda params . body)
  (list wrap (list* _vau params #ignore body)))

(defmacro (defoperative (name . params) envparam . body)
  (list _def name (list* _vau params envparam body)))

;;;; Wrap incomplete VM forms

(defmacro (loop . body)
  (list vm-loop (list* begin body)))

(defoperative (catch protected handler) env
  (eval (list vm-catch protected (eval handler env)) env))

(defoperative (push-prompt prompt . body) env
  (eval (list vm-push-prompt (eval prompt env) (list* begin body)) env))

(defmacro (take-subcont prompt k . body)
  (list vm-take-subcont prompt (list* _lambda (list k) body)))

(defmacro (push-subcont k . body)
  (list vm-push-subcont k (list* _lambda () body)))

(defmacro (push-prompt-subcont p k . body)
  (list vm-push-prompt-subcont p k (list* _lambda () body)))

;;;; List utilities

(_def compose (_lambda (f g) (_lambda (arg) (f (g arg)))))

(_def car (_lambda ((x . #ignore)) x))
(_def cdr (_lambda ((#ignore . x)) x))
(_def caar (compose car car))
(_def cadr (compose car cdr))
(_def cdar (compose cdr car))
(_def cddr (compose cdr cdr))

;;;; Important macros and functions

(_def map-list
  (_lambda (f lst)
    (if (nil? lst)
        ()
        (cons (f (car lst)) (map-list f (cdr lst))))))

(_def fold-list
  (_lambda (f init lst)
    (if (nil? lst)
        init
        (fold-list f (f init (car lst)) (cdr lst)))))

(defmacro (let x . rest)
  (if (symbol? x)
      (list* let-loop x rest)
      (list* (list* _lambda (map-list car x) rest)
             (map-list cadr x))))

(defmacro (let-loop name bindings . body)
  (list letrec (list (list name (list* lambda (map-list car bindings)
                                       body)))
        (list* name (map-list cadr bindings))))

(defmacro (let* bindings . body)
  (if (nil? bindings)
      (list* let () body)
      (list let (list (car bindings))
            (list* let* (cdr bindings) body))))

(defmacro (letrec bindings . body)
  (list* let ()
         (list _def
               (map-list car bindings)
               (list* list (map-list cadr bindings)))
         body))

(defmacro (lambda params . body)
  (letrec ((typed-params->names-and-checks
            (_lambda (ps)
              (if (cons? ps)
                  (let* (((p . rest-ps) ps)
                         ((names . checks) (typed-params->names-and-checks rest-ps)))
                    (if (cons? p)
                        (let* (((name type) p)
                               (check (list the type name)))
                          (cons (cons name names) (cons check checks)))
                        (cons (cons p names) checks)))
                  (cons ps ())))))
    (let (((untyped-names . type-checks) (typed-params->names-and-checks params)))
      (list* _lambda untyped-names (list* begin type-checks) body))))

(defmacro (def lhs . rhs)
  (if (cons? lhs)
    (list _def (car lhs) (list* lambda (cdr lhs) rhs))
    (list _def lhs (car rhs))))

(def (apply appv arg . opt)
  (if (instanceof appv $Function)
      (~apply appv #null (list-to-array arg))
      (eval (cons (unwrap appv) arg)
            (if (nil? opt)
                (make-environment)
                (car opt)))))

;;;; Simple control

(defoperative (cond . clauses) env
  (if (nil? clauses)
      #undefined
      (let ((((test . body) . clauses) clauses))
        (if (eval test env)
            (apply (wrap begin) body env)
            (apply (wrap cond) clauses env)))))

(def else #t)

(defoperative (and . x) e
  (cond ((nil? x)         #t)
        ((nil? (cdr x))   (eval (car x) e))
        ((eval (car x) e) (apply (wrap and) (cdr x) e))
        (else             #f)))

(defoperative (or . x) e
  (cond ((nil? x)         #f)
        ((nil? (cdr x))   (eval (car x) e))
        ((eval (car x) e) #t)
        (else             (apply (wrap or) (cdr x) e))))

(def (call-with-escape fun)
  (let ((fresh (list #null)))
    (catch (fun (_lambda opt-arg (throw (list fresh opt-arg))))
      (_lambda (exc)
        (if (and (cons? exc) (= fresh (car exc)))
            (let ((opt-arg (cadr exc)))
              (if (cons? opt-arg) (car opt-arg) #undefined))
            (throw exc))))))

(defmacro (label name . body)
  (list call-with-escape (list* _lambda (list name) body)))

(defoperative (while test . body) env
  (let ((body (list* begin body)))
    (label return
      (loop
        (if (eval test env)
          (eval body env)
          (return))))))

(defmacro (when test . body)
  (list if test (list* begin body) #null))

(defmacro (unless test . body)
  (list* when (list not test) body))

(defmacro (set (getter . args) new-val)
  (list* (list setter getter) new-val args))

;;;; Delimited dynamic binding

;; Evaluate right hand sides before binding all dynamic variables at once.
(defoperative (dlet bindings . body) env
  (eval (let process-bindings ((bs bindings))
          (if (nil? bs)
              (list* begin body)
              (let* ((((name expr) . rest-bs) bs)
                     (value (eval expr env)))
                (list vm-dlet name value (process-bindings rest-bs)))))
        env))

;;;; Prototypes

(defoperative (defprototype name super prop-names) env
  (let ((p (apply vm-js-make-prototype (list* (symbol-name name) (map-list symbol-name prop-names)))))
    (set (.prototype (.constructor p)) (new (eval super env)))
    (eval (list _def name p) env)))

(def (put-method ctor name js-fun)
  (set ((js-getter name) (.prototype ctor)) js-fun))

(defmacro (defmethod (name (self ctor) . args) . body)
  (list put-method ctor (symbol-name name)
        (list vm-js-function (list* lambda (list* self args) body))))

(defmacro (defgeneric (name . #ignore))
  (list _def name (vm-js-invoker (symbol-name name))))

;;;; Modules

(defoperative (provide symbols . body) env
  (eval (list _def symbols
              (list let ()
                    (list* begin body)
                    (list* list symbols)))
        env))

(defoperative (module exports . body) env
  (let ((menv (make-environment env)))
    (eval (list* provide exports body) menv)
    (make-environment menv)))

(defmacro (defmodule name exports . body)
  (list _def name (list* module exports body)))

(defoperative (import module imports) env
  (let* ((m (eval module env))
         (values (map-list (_lambda (import) (eval import m)) imports)))
    (eval (list _def imports (list* list values)) env)))

;;;; JavaScript

(def (relational-op name)
  (let ((binop (vm-js-binop name)))
    (letrec ((op (lambda (arg1 arg2 . rest)
                   (if (binop arg1 arg2)
                       (if (nil? rest)
                           #t
                           (apply op (list* arg2 rest)))
                       #f))))
      op)))

(def = (relational-op "==="))
(def < (relational-op "<"))
(def > (relational-op ">"))
(def <= (relational-op "<="))
(def >= (relational-op ">="))

(def (!= . args) (not (apply = args)))

(def * (let ((vm* (vm-js-binop "*")))
         (lambda args
           (fold-list vm* 1 args))))

;; Can't simply use 0 as unit or it won't work with strings
(def + (let ((vm+ (vm-js-binop "+")))
         (lambda args
           (if (nil? args)
               0
               (fold-list vm+ (car args) (cdr args))))))

(def (negative-op binop unit)
  (lambda (arg1 . rest)
    (if (nil? rest)
        (binop unit arg1)
        (fold-list binop arg1 rest))))

(def - (negative-op (vm-js-binop "-") 0))
(def / (negative-op (vm-js-binop "/") 1))

(def % (vm-js-binop "%"))
(def not (vm-js-unop "!"))
(def typeof (vm-js-unop "typeof"))
(def in (vm-js-binop "in"))
(def instanceof (vm-js-binop "instanceof"))

(def bitand (vm-js-binop "&"))
(def bitor (vm-js-binop "|"))
(def bitxor (vm-js-binop "^"))
(def bitnot (vm-js-unop "~"))
(def bitshiftl (vm-js-binop "<<"))
(def bitshiftr (vm-js-binop ">>"))
(def bitshiftr0 (vm-js-binop ">>>"))

(defoperative (object . pairs) env
  (let ((obj (vm-js-make-object)))
    (map-list (_lambda ((name value))
                (set ((js-getter (eval name env)) obj) (eval value env)))
              pairs)
    obj))

(def (@ object key)
  ((js-getter key) object))

(set (setter @) (lambda (new-val object key)
                  (set ((js-getter key) object) new-val)))

(def (array . args) (list-to-array args))

(def (js-callback fun)
  (vm-js-function (_lambda args (push-prompt vm-root-prompt (apply fun args)))))

(defmacro (type? obj type)
  (list vm-type? obj type (symbol-name type)))

(defmacro (the type obj)
  (list if (list type? obj type) obj (list error (list + obj " is not a: " type))))

(def Arguments $Arguments)
(def Array $Array)
(def Boolean $Boolean)
(def Date $Date)
(def Function $Function)
(def Number $Number)
(def Object $Object)
(def RegExp $RegExp)
(def String $String)

(def (log x . xs)
  (apply ~log (list* $console x xs))
  x)

;;;; Error break routine, called by VM to print stacktrace and throw

(def (print-stacktrace)
  (def (print-frame k)
    (log (~toString (.dbg k)) (.e k))
    (if (.next k)
        (print-frame (.next k))
        #undefined))
  (take-subcont vm-root-prompt k
    (print-frame k)
    (push-prompt vm-root-prompt
      (push-subcont k))))

(def (user-break err)
  (print-stacktrace)
  (throw err))

;;;; Final events

(defoperative (let-redirect exp bindings . body) env
  (eval (list* (eval (list* _lambda (map-list car bindings) body)
                     (eval exp
                           env))
               (map-list cadr bindings))
        env))

(defoperative (bindings->environment . bindings) denv
  (eval (list let-redirect
              (make-environment)
              bindings
              (list the-environment))
        denv))

(defoperative (slurp-environment . bindings) env
  (eval (list* bindings->environment (map-list (lambda (b) (list b b)) bindings)) env))

;;;; Export bindings to userland

;; User environment is subenvironment of environment containing exported bindings
;; so exported bindings cannot be modified

(make-environment
  (slurp-environment
   defoperative _def _lambda _vau apply eval make-environment the-environment unwrap wrap
   begin def defmacro lambda let let* quote symbol-name symbol?
   caar cadr car cdar cddr cdr cons cons? fold-list list list* map-list nil? reverse-list
   defgeneric defprototype defmethod new the type?
   catch cond else if label loop throw unless when while error
   set setter
   push-prompt push-subcont take-subcont push-prompt-subcont
   dlet dnew dref
   defmodule import module
   Arguments Array Date Function Number Object RegExp String
   array array-to-list js-callback js-getter js-global js-invoker list-to-array object log
   @ and or not != % * + - / < <= = > >= in instanceof typeof
   bitand bitor bitxor bitnot bitshiftl bitshiftr bitshiftr0
   print-stacktrace
   ))

;; -*- mode: lisp -*-

;; ``72. An adequate bootstrap is a contradiction in terms.''

;; Rename ur-def
(vm-def _def vm-def)

;; Rename bindings that will be used as provided by VM
(_def array-to-list vm-array-to-list)
(_def begin vm-begin)
(_def cons vm-cons)
(_def cons? vm-cons?)
(_def dnew vm-dnew)
(_def dref vm-dref)
(_def error vm-error)
(_def eval vm-eval)
(_def if vm-if)
(_def js-getter vm-js-getter)
(_def js-global vm-js-global)
(_def js-invoker vm-js-invoker)
(_def list* vm-list*)
(_def list-to-array vm-list-to-array)
(_def make-environment vm-make-environment)
(_def new vm-js-new)
(_def nil? vm-nil?)
(_def reverse-list vm-reverse-list)
(_def setter vm-setter)
(_def symbol-name vm-symbol-name)
(_def symbol? vm-symbol?)
(_def throw vm-throw)
(_def unwrap vm-unwrap)
(_def wrap vm-wrap)

;; Important utilities
(_def quote (vm-vau (x) #ignore x))
(_def list (wrap (vm-vau elts #ignore elts)))
(_def the-environment (vm-vau () e e))

;;;; Macro and vau

(_def make-macro-expander
  (wrap
    (vm-vau (expander) #ignore
      (vm-vau operands env
        (eval (eval (cons expander operands) (make-environment)) env)))))

(_def _vau
  (make-macro-expander
    (vm-vau (params env-param . body) #ignore
      (list vm-vau params env-param (list* begin body)))))

(_def macro
  (make-macro-expander
    (_vau (params . body) #ignore
      (list make-macro-expander (list* _vau params #ignore body)))))

(_def defmacro
  (macro ((name . params) . body)
    (list _def name (list* macro params body))))

(defmacro (_lambda params . body)
  (list wrap (list* _vau params #ignore body)))

(defmacro (defoperative (name . params) envparam . body)
  (list _def name (list* _vau params envparam body)))

;;;; Wrap incomplete VM forms

(defmacro (loop . body)
  (list vm-loop (list* begin body)))

(defoperative (catch protected handler) env
  (eval (list vm-catch protected (eval handler env)) env))

(defoperative (push-prompt prompt . body) env
  (eval (list vm-push-prompt (eval prompt env) (list* begin body)) env))

(defmacro (take-subcont prompt k . body)
  (list vm-take-subcont prompt (list* _lambda (list k) body)))

(defmacro (push-subcont k . body)
  (list vm-push-subcont k (list* _lambda () body)))

(defmacro (push-prompt-subcont p k . body)
  (list vm-push-prompt-subcont p k (list* _lambda () body)))

;;;; List utilities

(_def compose (_lambda (f g) (_lambda (arg) (f (g arg)))))

(_def car (_lambda ((x . #ignore)) x))
(_def cdr (_lambda ((#ignore . x)) x))
(_def caar (compose car car))
(_def cadr (compose car cdr))
(_def cdar (compose cdr car))
(_def cddr (compose cdr cdr))

;;;; Important macros and functions

(_def map-list
  (_lambda (f lst)
    (if (nil? lst)
        ()
        (cons (f (car lst)) (map-list f (cdr lst))))))

(_def fold-list
  (_lambda (f init lst)
    (if (nil? lst)
        init
        (fold-list f (f init (car lst)) (cdr lst)))))

(defmacro (let x . rest)
  (if (symbol? x)
      (list* let-loop x rest)
      (list* (list* _lambda (map-list car x) rest)
             (map-list cadr x))))

(defmacro (let-loop name bindings . body)
  (list letrec (list (list name (list* lambda (map-list car bindings)
                                       body)))
        (list* name (map-list cadr bindings))))

(defmacro (let* bindings . body)
  (if (nil? bindings)
      (list* let () body)
      (list let (list (car bindings))
            (list* let* (cdr bindings) body))))

(defmacro (letrec bindings . body)
  (list* let ()
         (list _def
               (map-list car bindings)
               (list* list (map-list cadr bindings)))
         body))

(defmacro (lambda params . body)
  (letrec ((typed-params->names-and-checks
            (_lambda (ps)
              (if (cons? ps)
                  (let* (((p . rest-ps) ps)
                         ((names . checks) (typed-params->names-and-checks rest-ps)))
                    (if (cons? p)
                        (let* (((name type) p)
                               (check (list the type name)))
                          (cons (cons name names) (cons check checks)))
                        (cons (cons p names) checks)))
                  (cons ps ())))))
    (let (((untyped-names . type-checks) (typed-params->names-and-checks params)))
      (list* _lambda untyped-names (list* begin type-checks) body))))

(defmacro (def lhs . rhs)
  (if (cons? lhs)
    (list _def (car lhs) (list* lambda (cdr lhs) rhs))
    (list _def lhs (car rhs))))

(def (apply appv arg . opt)
  (if (instanceof appv $Function)
      (~apply appv #null (list-to-array arg))
      (eval (cons (unwrap appv) arg)
            (if (nil? opt)
                (make-environment)
                (car opt)))))

;;;; Simple control

(defoperative (cond . clauses) env
  (if (nil? clauses)
      #undefined
      (let ((((test . body) . clauses) clauses))
        (if (eval test env)
            (apply (wrap begin) body env)
            (apply (wrap cond) clauses env)))))

(def else #t)

(defoperative (and . x) e
  (cond ((nil? x)         #t)
        ((nil? (cdr x))   (eval (car x) e))
        ((eval (car x) e) (apply (wrap and) (cdr x) e))
        (else             #f)))

(defoperative (or . x) e
  (cond ((nil? x)         #f)
        ((nil? (cdr x))   (eval (car x) e))
        ((eval (car x) e) #t)
        (else             (apply (wrap or) (cdr x) e))))

(def (call-with-escape fun)
  (let ((fresh (list #null)))
    (catch (fun (_lambda opt-arg (throw (list fresh opt-arg))))
      (_lambda (exc)
        (if (and (cons? exc) (= fresh (car exc)))
            (let ((opt-arg (cadr exc)))
              (if (cons? opt-arg) (car opt-arg) #undefined))
            (throw exc))))))

(defmacro (label name . body)
  (list call-with-escape (list* _lambda (list name) body)))

(def (call-while test-fun body-fun)
  (label return
    (loop
      (if (test-fun)
        (body-fun)
        (return)))))

(defmacro (while test . body)
  (list call-while
        (list _lambda () test)
        (list* _lambda () body)))

(defmacro (when test . body)
  (list if test (list* begin body) #null))

(defmacro (unless test . body)
  (list* when (list not test) body))

(defmacro (set (getter . args) new-val)
  (list* (list setter getter) new-val args))

;;;; Delimited dynamic binding

;; Evaluate right hand sides before binding all dynamic variables at once.
(defoperative (dlet bindings . body) env
  (eval (let process-bindings ((bs bindings))
          (if (nil? bs)
              (list* begin body)
              (let* ((((name expr) . rest-bs) bs)
                     (value (eval expr env)))
                (list vm-dlet name value (process-bindings rest-bs)))))
        env))

;;;; Prototypes

(defoperative (defprototype name super prop-names) env
  (let ((p (apply vm-js-make-prototype (list* (symbol-name name) (map-list symbol-name prop-names)))))
    (set (.prototype (.constructor p)) (new (eval super env)))
    (eval (list _def name p) env)))

(def (put-method ctor name js-fun)
  (set ((js-getter name) (.prototype ctor)) js-fun))

(defmacro (defmethod (name (self ctor) . args) . body)
  (list put-method ctor (symbol-name name)
        (list vm-js-function (list* lambda (list* self args) body))))

(defmacro (defgeneric (name . #ignore))
  (list _def name (vm-js-invoker (symbol-name name))))

;;;; Modules

(defoperative (provide symbols . body) env
  (eval (list _def symbols
              (list let ()
                    (list* begin body)
                    (list* list symbols)))
        env))

(defoperative (module exports . body) env
  (let ((menv (make-environment env)))
    (eval (list* provide exports body) menv)
    (make-environment menv)))

(defmacro (defmodule name exports . body)
  (list _def name (list* module exports body)))

(defoperative (import module imports) env
  (let* ((m (eval module env))
         (values (map-list (_lambda (import) (eval import m)) imports)))
    (eval (list _def imports (list* list values)) env)))

;;;; JavaScript

(def (relational-op name)
  (let ((binop (vm-js-binop name)))
    (letrec ((op (lambda (arg1 arg2 . rest)
                   (if (binop arg1 arg2)
                       (if (nil? rest)
                           #t
                           (apply op (list* arg2 rest)))
                       #f))))
      op)))

(def = (relational-op "==="))
(def < (relational-op "<"))
(def > (relational-op ">"))
(def <= (relational-op "<="))
(def >= (relational-op ">="))

(def (!= . args) (not (apply = args)))

(def * (let ((vm* (vm-js-binop "*")))
         (lambda args
           (fold-list vm* 1 args))))

;; Can't simply use 0 as unit or it won't work with strings
(def + (let ((vm+ (vm-js-binop "+")))
         (lambda args
           (if (nil? args)
               0
               (fold-list vm+ (car args) (cdr args))))))

(def (negative-op binop unit)
  (lambda (arg1 . rest)
    (if (nil? rest)
        (binop unit arg1)
        (fold-list binop arg1 rest))))

(def - (negative-op (vm-js-binop "-") 0))
(def / (negative-op (vm-js-binop "/") 1))

(def % (vm-js-binop "%"))
(def not (vm-js-unop "!"))
(def typeof (vm-js-unop "typeof"))
(def in (vm-js-binop "in"))
(def instanceof (vm-js-binop "instanceof"))

(def bitand (vm-js-binop "&"))
(def bitor (vm-js-binop "|"))
(def bitxor (vm-js-binop "^"))
(def bitnot (vm-js-unop "~"))
(def bitshiftl (vm-js-binop "<<"))
(def bitshiftr (vm-js-binop ">>"))
(def bitshiftr0 (vm-js-binop ">>>"))

(defoperative (object . pairs) env
  (let ((obj (vm-js-make-object)))
    (map-list (_lambda ((name value))
                (set ((js-getter (eval name env)) obj) (eval value env)))
              pairs)
    obj))

(def (@ object key)
  ((js-getter key) object))

(set (setter @) (lambda (new-val object key)
                  (set ((js-getter key) object) new-val)))

(def (array . args) (list-to-array args))

(def (js-callback fun)
  (vm-js-function (_lambda args (push-prompt vm-root-prompt (apply fun args)))))

(defmacro (type? obj type)
  (list vm-type? obj type (symbol-name type)))

(defmacro (the type obj)
  (list if (list type? obj type) obj (list error (list + obj " is not a: " type))))

(def Arguments $Arguments)
(def Array $Array)
(def Boolean $Boolean)
(def Date $Date)
(def Function $Function)
(def Number $Number)
(def Object $Object)
(def RegExp $RegExp)
(def String $String)

(def (log x . xs)
  (apply ~log (list* $console x xs))
  x)

;;;; Error break routine, called by VM to print stacktrace and throw

(def (print-stacktrace)
  (def (print-frame k)
    (log (~toString (.dbg k)) (.e k))
    (if (.next k)
        (print-frame (.next k))
        #undefined))
  (take-subcont vm-root-prompt k
    (print-frame k)
    (push-prompt vm-root-prompt
      (push-subcont k))))

(def (user-break err)
  (print-stacktrace)
  (throw err))

;;;; Final events

(defoperative (let-redirect exp bindings . body) env
  (eval (list* (eval (list* _lambda (map-list car bindings) body)
                     (eval exp
                           env))
               (map-list cadr bindings))
        env))

(defoperative (bindings->environment . bindings) denv
  (eval (list let-redirect
              (make-environment)
              bindings
              (list the-environment))
        denv))

(defoperative (slurp-environment . bindings) env
  (eval (list* bindings->environment (map-list (lambda (b) (list b b)) bindings)) env))

;;;; Export bindings to userland

;; User environment is subenvironment of environment containing exported bindings
;; so exported bindings cannot be modified

(make-environment
  (slurp-environment
   defoperative _def _lambda _vau apply eval make-environment the-environment unwrap wrap
   begin def defmacro lambda let let* quote symbol-name symbol?
   caar cadr car cdar cddr cdr cons cons? fold-list list list* map-list nil? reverse-list
   defgeneric defprototype defmethod new the type?
   catch cond else if label loop throw unless when while error
   set setter
   push-prompt push-subcont take-subcont push-prompt-subcont
   dlet dnew dref
   defmodule import module
   Arguments Array Date Function Number Object RegExp String
   array array-to-list js-callback js-getter js-global js-invoker list-to-array object log
   @ and or not != % * + - / < <= = > >= in instanceof typeof
   bitand bitor bitxor bitnot bitshiftl bitshiftr bitshiftr0
   print-stacktrace
   ))


Update examples/2.wat

Update examples/2.wat

(module
  (func (export "add") (param i32) (param i32) (result i32)
    get_local 0
    get_local 1
    i32.add))

(module
  (func (param i32) (param i32) (result i32)
    get_local 0
    get_local 1
    i32.add))


lucet-wasi tests: don't put string at location 0, thats NULL

and we should be rejecting null pointers!

(module
  (type (func (param i32 i32 i32 i32) (result i32)))
  (type (func))

  ;; import fd_read, this is fine.
  (func $read (import "wasi_snapshot_preview1" "fd_read") (type 0))

  ;; import fd_write, this is also fine.
  (func $write (import "wasi_snapshot_preview1" "fd_write") (type 0))

  ;; import fd_read, again, under a different name!
  ;; this is to test that we join together the imports.
  ;; the .wat would be invalid if their types disagree, so there
  ;; is no observable difference between $read and $read_2
  (func $read_2 (import "wasi_snapshot_preview1" "fd_read") (type 0))

  ;; import fd_write again for grins.
  (import "wasi_snapshot_preview1" "fd_write" (func (type 0)))
  (memory 1)
  (data (i32.const 4) "duplicate import works!\0a")
  (data (i32.const 64) "\04\00\00\00\18\00\00\00")

  (func $_setup (type 1)
    (drop (call $write (i32.const 1) (i32.const 64) (i32.const 1) (i32.const 0))))

  ;; declare that, actually, one of the imported functions is exported
  (export "read_2" (func $read_2))
  ;; and declare that the *other* read function is also exported, by a
  ;; different name. This lets us check that when we merge the functions,
  ;; we also merge their export names properly.
  (export "read" (func $read))

  ;; and check that other exported functions still work, and are not affected
  (export "write" (func $write))

  ;; and that we can export local functions without issue
  (export "_start" (func $_setup))
)

(module
  (type (func (param i32 i32 i32 i32) (result i32)))
  (type (func))

  ;; import fd_read, this is fine.
  (func $read (import "wasi_snapshot_preview1" "fd_read") (type 0))

  ;; import fd_write, this is also fine.
  (func $write (import "wasi_snapshot_preview1" "fd_write") (type 0))

  ;; import fd_read, again, under a different name!
  ;; this is to test that we join together the imports.
  ;; the .wat would be invalid if their types disagree, so there
  ;; is no observable difference between $read and $read_2
  (func $read_2 (import "wasi_snapshot_preview1" "fd_read") (type 0))

  ;; import fd_write again for grins.
  (import "wasi_snapshot_preview1" "fd_write" (func (type 0)))
  (memory 1)
  (data (i32.const 0) "duplicate import works!\0a")
  (data (i32.const 64) "\00\00\00\00\18\00\00\00")

  (func $_setup (type 1)
    (drop (call $write (i32.const 1) (i32.const 64) (i32.const 1) (i32.const 0))))

  ;; declare that, actually, one of the imported functions is exported
  (export "read_2" (func $read_2))
  ;; and declare that the *other* read function is also exported, by a
  ;; different name. This lets us check that when we merge the functions,
  ;; we also merge their export names properly.
  (export "read" (func $read))

  ;; and check that other exported functions still work, and are not affected
  (export "write" (func $write))

  ;; and that we can export local functions without issue
  (export "_start" (func $_setup))
)