finally a correct REPL loop

finally a correct REPL loop

;; -*- mode: scheme -*-

(define env (current-environment))

(define (repl)
  (define (loop)
    (display (eval (read) env))
    (loop))
  (push-prompt *top-level*
    (loop)))

(display "Welcome to Wat -10.3")
(repl)

;; -*- mode: scheme -*-

(define env (current-environment))

(define (repl)
  (define (loop)
    (push-prompt *top-level*
      (display (eval (read) env))
      (loop)))
  (loop))

(display "Welcome to Wat -10.3")
(repl)


Update memory.wat

Update memory.wat

(module
  (memory (import "js" "mem") 1)
  (func (export "accumulate") (param $ptr i32) (param $len i32) (result i32)
    (local $end i32)
    (local $sum i32)
    (local.set $end
      (i32.add
        (local.get $ptr)
        (i32.mul
          (local.get $len)
          (i32.const 4))))
    (block $break
      (loop $top
        (br_if $break
          (i32.eq
            (local.get $ptr)
            (local.get $end)))
        (local.set $sum
          (i32.add
            (local.get $sum)
            (i32.load
              (local.get $ptr))))
        (local.set $ptr
          (i32.add
            (local.get $ptr)
            (i32.const 4)))
        (br $top)))
    (local.get $sum)))

(module
  (memory (import "js" "mem") 1)
  (func (export "accumulate") (param $ptr i32) (param $len i32) (result i32)
    (local $end i32)
    (local $sum i32)
    (local.set $end (i32.add (local.get $ptr) (i32.mul (local.get $len) (i32.const 4))))
    (block $break (loop $top
      (br_if $break (i32.eq (local.get $ptr) (local.get $end)))
      (local.set $sum (i32.add (local.get $sum)
                               (i32.load (local.get $ptr))))
        (local.set $ptr (i32.add (local.get $ptr) (i32.const 4)))
        (br $top)
    ))
    (local.get $sum)
  )
)


add error monad test

add error monad 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 tagger untagger) (make-type))
    (assert (eq? (type-of type) (type-of (type-of #t))))
    (let ((x (list #void)))
      (eq? type (type-of (tagger x)))
      (eq? x (untagger (tagger x)))))

  ;; TYPE-OF

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

  ;; 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)))))

;; Delimited Control

(define-syntax test-check
  (vau (#ign expr res) env
    (assert (= (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 #ign 5) 6))
       4))
  9)

(test-check 'test3-1
  (let ((p (new-prompt)))
    (+ (push-prompt p (push-prompt p (+ (take-sub-cont p #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 #ign 5) 6)))
		      (v1 (take-sub-cont p #ign 7)))
		 (+ v1 10)))))
      (+ v 20)))
  27)

(test-check 'test4
  (let ((p (make-prompt)))
    (+ (push-prompt p
         (+ (take-sub-cont p 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 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 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 sk (push-twice sk)))))))))
  135)

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

;; Delimited Dynamic Binding

(let ((p (make-prompt)))
  (assert (= 117 (+ 10 (push-prompt p (+ 2 (shift p k (+ 100 (k (k 3))))))))))

(test-check 'ddb-1
  (let ((dv (dnew)))
    (dlet dv 12 (dref dv)))
  12)

(test-check 'ddb-2
  (let ((dv (dnew)))
    (dlet dv 12 (dlet dv 14 (dref dv))))
  14)

(test-check 'ddb-3
  (let ((dv (dnew)) (p (make-prompt)))
    (dlet dv 1
      (push-prompt p
        (dlet dv 3
          (take-sub-cont p k (dref dv))))))
  1)

(test-check 'ddb-4
  (let ((dv (dnew)) (p (make-prompt)))
    (dlet dv 1
      (push-prompt p
        (dlet dv 3
          (take-sub-cont p k
	    (push-sub-cont k
	       (dref dv)))))))
  3)

;; Test to see whether continuations are properly tail-recursive.
;; (define (tailtest)
;;   (let ((p (make-prompt)))
;;     (push-prompt p
;;       (take-sub-cont p sk
;;          (push-sub-cont sk (tailtest))))))
;; (tailtest)

;; Error monad from Filinski's "Representing Monads".

(provide ()
  (define *default-prompt* (make-prompt))
  (define (reflect m) (shift *default-prompt* k (ext k m)))
  (define (reify t) (push-prompt *default-prompt* (unit (t))))

  (def (suc-type suc-tag suc-untag) (make-type))
  (define (make-suc a) (suc-tag a))
  (def (err-type err-tag err-untag) (make-type))
  (define (make-err string) (err-tag string))
  (define (unit a) (make-suc a))
  (define (ext f m)
    (cond ((eq? suc-type (type-of m)) (f (suc-untag m)))
          ((eq? err-type (type-of m)) m)
          (#t (fail "type error"))))

  (define (myraise e) (reflect (make-err e)))
  (define (myhandle t h)
    (let ((m (reify t)))
      (cond ((eq? suc-type (type-of m)) (suc-untag m))
            ((eq? err-type (type-of m)) (h (err-untag m)))
            (#t (fail "type error")))))

  (define (show t)
    (myhandle (lambda () (t))
              (lambda (s) s)))

  (assert (= 3 (show (lambda () (+ 1 2)))))
  (assert (eq? #f (show (lambda () (+ 1 (myraise #f))))))
)


test define-record-type's predicate better

;; -*- 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 tagger untagger) (make-type))
    (assert (eq? (type-of type) (type-of (type-of #t))))
    (let ((x (list #void)))
      (eq? type (type-of (tagger x)))
      (eq? x (untagger (tagger x)))))

  ;; TYPE-OF

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

  ;; 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)))))

;; IDHASH

(provide ()
  (assert (not (eq? (idhash "foo") (idhash "bar")))))

;; DEFINE-RECORD-TYPE

(provide ()
  (define-record-type pare
    (kons kar kdr)
    pare?
    (kar kar set-kar!)
    (kdr kdr set-kdr!))
  (define p (kons 1 2))
  (assert (= 1 (kar p)))
  (assert (= 2 (kdr p)))
  (set-kar! p 3)
  (set-kdr! p 4)
  (assert (= 3 (kar p)))
  (assert (= 4 (kdr p)))
  (assert (pare? p))
  (assert (eq? #f (pare? 12))))

;; Delimited Control

(define-syntax test-check
  (vau (#ign expr res) env
    (assert (= (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 #ign 5) 6))
       4))
  9)

(test-check 'test3-1
  (let ((p (new-prompt)))
    (+ (push-prompt p (push-prompt p (+ (take-sub-cont p #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 #ign 5) 6)))
		      (v1 (take-sub-cont p #ign 7)))
		 (+ v1 10)))))
      (+ v 20)))
  27)

(test-check 'test4
  (let ((p (make-prompt)))
    (+ (push-prompt p
         (+ (take-sub-cont p 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 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 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 sk (push-twice sk)))))))))
  135)

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

;; Delimited Dynamic Binding

(let ((p (make-prompt)))
  (assert (= 117 (+ 10 (push-prompt p (+ 2 (shift p k (+ 100 (k (k 3))))))))))

(test-check 'ddb-1
  (let ((dv (dnew)))
    (dlet dv 12 (dref dv)))
  12)

(test-check 'ddb-2
  (let ((dv (dnew)))
    (dlet dv 12 (dlet dv 14 (dref dv))))
  14)

(test-check 'ddb-3
  (let ((dv (dnew)) (p (make-prompt)))
    (dlet dv 1
      (push-prompt p
        (dlet dv 3
          (take-sub-cont p k (dref dv))))))
  1)

(test-check 'ddb-4
  (let ((dv (dnew)) (p (make-prompt)))
    (dlet dv 1
      (push-prompt p
        (dlet dv 3
          (take-sub-cont p k
	    (push-sub-cont k
	       (dref dv)))))))
  3)

;; Test to see whether continuations are properly tail-recursive.
;; From "A Monadic Framework".
;;
;; (define (tailtest)
;;   (let ((p (make-prompt)))
;;     (push-prompt p
;;       (take-sub-cont p sk
;;          (push-sub-cont sk (tailtest))))))
;; (tailtest)
;;
;; Another one, from Oleg's "Argument against call/cc".
;;
;; (define (leak-test1 identity-thunk)
;;   (let-loop loop ((id (lambda (x) x)))
;;     (loop (id (identity-thunk)))))
;; (let ((p (make-prompt)))
;;   (leak-test1 (lambda () (push-prompt p (shift p k k)))))

;; Error monad from Filinski's "Representing Monads".

(provide ()
  (define *default-prompt* (make-prompt))
  (define (reflect m) (shift *default-prompt* k (ext k m)))
  (define (reify t) (push-prompt *default-prompt* (unit (t))))

  (def (suc-type suc-tag suc-untag) (make-type))
  (define (make-suc a) (suc-tag a))
  (def (err-type err-tag err-untag) (make-type))
  (define (make-err string) (err-tag string))
  (define (unit a) (make-suc a))
  (define (ext f m)
    (cond ((eq? suc-type (type-of m)) (f (suc-untag m)))
          ((eq? err-type (type-of m)) m)
          (#t (fail "type error"))))

  (define (myraise e) (reflect (make-err e)))
  (define (myhandle t h)
    (let ((m (reify t)))
      (cond ((eq? suc-type (type-of m)) (suc-untag m))
            ((eq? err-type (type-of m)) (h (err-untag m)))
            (#t (fail "type error")))))

  (define (show t)
    (myhandle (lambda () (t))
              (lambda (s) s)))

  (assert (= 3 (show (lambda () (+ 1 2)))))
  (assert (eq? #f (show (lambda () (+ 1 (myraise #f))))))
)

;; -*- 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 tagger untagger) (make-type))
    (assert (eq? (type-of type) (type-of (type-of #t))))
    (let ((x (list #void)))
      (eq? type (type-of (tagger x)))
      (eq? x (untagger (tagger x)))))

  ;; TYPE-OF

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

  ;; 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)))))

;; IDHASH

(provide ()
  (assert (not (eq? (idhash "foo") (idhash "bar")))))

;; DEFINE-RECORD-TYPE

(provide ()
  (define-record-type pare
    (kons kar kdr)
    pare?
    (kar kar set-kar!)
    (kdr kdr set-kdr!))
  (define p (kons 1 2))
  (assert (= 1 (kar p)))
  (assert (= 2 (kdr p)))
  (set-kar! p 3)
  (set-kdr! p 4)
  (assert (= 3 (kar p)))
  (assert (= 4 (kdr p)))
  (assert (pare? p)))

;; Delimited Control

(define-syntax test-check
  (vau (#ign expr res) env
    (assert (= (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 #ign 5) 6))
       4))
  9)

(test-check 'test3-1
  (let ((p (new-prompt)))
    (+ (push-prompt p (push-prompt p (+ (take-sub-cont p #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 #ign 5) 6)))
		      (v1 (take-sub-cont p #ign 7)))
		 (+ v1 10)))))
      (+ v 20)))
  27)

(test-check 'test4
  (let ((p (make-prompt)))
    (+ (push-prompt p
         (+ (take-sub-cont p 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 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 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 sk (push-twice sk)))))))))
  135)

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

;; Delimited Dynamic Binding

(let ((p (make-prompt)))
  (assert (= 117 (+ 10 (push-prompt p (+ 2 (shift p k (+ 100 (k (k 3))))))))))

(test-check 'ddb-1
  (let ((dv (dnew)))
    (dlet dv 12 (dref dv)))
  12)

(test-check 'ddb-2
  (let ((dv (dnew)))
    (dlet dv 12 (dlet dv 14 (dref dv))))
  14)

(test-check 'ddb-3
  (let ((dv (dnew)) (p (make-prompt)))
    (dlet dv 1
      (push-prompt p
        (dlet dv 3
          (take-sub-cont p k (dref dv))))))
  1)

(test-check 'ddb-4
  (let ((dv (dnew)) (p (make-prompt)))
    (dlet dv 1
      (push-prompt p
        (dlet dv 3
          (take-sub-cont p k
	    (push-sub-cont k
	       (dref dv)))))))
  3)

;; Test to see whether continuations are properly tail-recursive.
;; From "A Monadic Framework".
;;
;; (define (tailtest)
;;   (let ((p (make-prompt)))
;;     (push-prompt p
;;       (take-sub-cont p sk
;;          (push-sub-cont sk (tailtest))))))
;; (tailtest)
;;
;; Another one, from Oleg's "Argument against call/cc".
;;
;; (define (leak-test1 identity-thunk)
;;   (let-loop loop ((id (lambda (x) x)))
;;     (loop (id (identity-thunk)))))
;; (let ((p (make-prompt)))
;;   (leak-test1 (lambda () (push-prompt p (shift p k k)))))

;; Error monad from Filinski's "Representing Monads".

(provide ()
  (define *default-prompt* (make-prompt))
  (define (reflect m) (shift *default-prompt* k (ext k m)))
  (define (reify t) (push-prompt *default-prompt* (unit (t))))

  (def (suc-type suc-tag suc-untag) (make-type))
  (define (make-suc a) (suc-tag a))
  (def (err-type err-tag err-untag) (make-type))
  (define (make-err string) (err-tag string))
  (define (unit a) (make-suc a))
  (define (ext f m)
    (cond ((eq? suc-type (type-of m)) (f (suc-untag m)))
          ((eq? err-type (type-of m)) m)
          (#t (fail "type error"))))

  (define (myraise e) (reflect (make-err e)))
  (define (myhandle t h)
    (let ((m (reify t)))
      (cond ((eq? suc-type (type-of m)) (suc-untag m))
            ((eq? err-type (type-of m)) (h (err-untag m)))
            (#t (fail "type error")))))

  (define (show t)
    (myhandle (lambda () (t))
              (lambda (s) s)))

  (assert (= 3 (show (lambda () (+ 1 2)))))
  (assert (eq? #f (show (lambda () (+ 1 (myraise #f))))))
)


use linux lines

use linux lines

(module
  (func $singleInt (param i32)
  )
)

(module
  (func $singleInt(param i32)
  )
)


REPL scrolling.

REPL scrolling.

;; -*- mode: scheme -*-

;; WAT ON THE WWW

(provide (read display)

(define *window* (js-global "window"))
(define *document* (js-global "document"))
(define *body* (js-prop *document* "body"))

(define getElementById
  (let ((m (js-method "getElementById")))
    (lambda (str) (m *document* (to-js str)))))

(define createElement
  (let ((m (js-method "createElement")))
    (lambda (name) (m *document* (to-js name)))))

(define createTextNode
  (let ((m (js-method "createTextNode")))
    (lambda (s) (m *document* (to-js s)))))

(define appendChild
  (let ((m (js-method "appendChild")))
    (lambda (e child) (m e child))))

(define scrollTo
  (let ((m (js-method "scrollTo")))
    (lambda (x y) (m *window* x y))))

(define (read-input)
  (let ((res (list* 'begin (read-from-string (from-js (js-prop (getElementById "input") "value"))))))
    (display (strcat "USER> " (from-js (js-prop (getElementById "input") "value"))))
    (js-set-prop! (getElementById "input") "value" (to-js ""))
    res))

(define *input-pollset* (make-pollset))
(js-set-prop! (getElementById "input") "onkeypress" (pollset-callback *input-pollset*))

(define (read)
  (let ((evt (pollset-wait *input-pollset*)))
    (if (= (from-js (js-prop evt "keyCode")) 13)
        (read-input)
        (read))))

(define (display msg)
  (let ((div (createElement "div")))
    (appendChild div (createTextNode (to-js msg)))
    (appendChild (getElementById "output") div)
    (scrollTo (to-js 0) (js-prop *body* "scrollHeight"))
    msg))

((js-method "focus") (getElementById "input"))

) ; edivorp

;; -*- mode: scheme -*-

;; WAT ON THE WWW

(provide (read display)

(define *document* (js-global "document"))

(define getElementById
  (let ((m (js-method "getElementById")))
    (lambda (str) (m *document* (to-js str)))))

(define createElement
  (let ((m (js-method "createElement")))
    (lambda (name) (m *document* (to-js name)))))

(define createTextNode
  (let ((m (js-method "createTextNode")))
    (lambda (s) (m *document* (to-js s)))))

(define appendChild
  (let ((m (js-method "appendChild")))
    (lambda (e child) (m e child))))

(define (read-input)
  (let ((res (list* 'begin (read-from-string (from-js (js-prop (getElementById "input") "value"))))))
    (display (strcat "USER> " (from-js (js-prop (getElementById "input") "value"))))
    (js-set-prop! (getElementById "input") "value" (to-js ""))
    res))

(define *input-pollset* (make-pollset))
(js-set-prop! (getElementById "input") "onkeypress" (pollset-callback *input-pollset*))

(define (read)
  (let ((evt (pollset-wait *input-pollset*)))
    (if (= (from-js (js-prop evt "keyCode")) 13)
        (read-input)
        (read))))

(define (display msg)
  (let ((div (createElement "div")))
    (appendChild div (createTextNode (to-js msg)))
    (appendChild (getElementById "output") div)
    msg))

((js-method "focus") (getElementById "input"))

) ; edivorp


[exceptions] Fix .wat file

[exceptions] Fix .wat file

;; Name: Exception handling
;; Proposal: https://github.com/WebAssembly/exception-handling
;; Features: exceptions

(module
  (func
    try
    catch_all
    end
  )
)

;; Name: Exception handling
;; Proposal: https://github.com/WebAssembly/exception-handling
;; Features: exceptions

(module
  (func
    try
    catch
      drop
    end
  )
)


Update simple-name-section.wat

Update simple-name-section.wat

(module
  (func $i (import "imports" "imported_func") (param i32))
  (func (export "exported_func")
    i32.const 42
    call $i
  )
 )

(module
  (func $i (import "imports" "imported_func") (param i32))
  (func (export "exported_func")
    i32.const 42
    call $i))


fixed line causing compiler error

fixed line causing compiler error

this should fix issue #10

(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)
    get_local $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)
    get_local $i
    call_indirect $return_i32)
)


Update simple.wat

Update simple.wat

(module
  (func $i (import "imports" "imported_func") (param i32))
  (func (export "exported_func")
    i32.const 42
    call $i
  )
)


Update global.wat

Update global.wat

(module
  (global $g (import "js" "global") (mut i32))
  (func (export "getGlobal") (result i32)
    (global.get $g)
  )
  (func (export "incGlobal")
    (global.set $g (i32.add (global.get $g) (i32.const 1)))
  )
)

(module
  (global $g (import "js" "global") (mut i32))
  (func (export "getGlobal") (result i32)
    (global.get $g))
  (func (export "incGlobal")
    (global.set $g (i32.add (global.get $g) (i32.const 1)))))


Remove obsolete functionality.

Remove obsolete functionality.

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

;(start-profile)

(def quote (vau (x) #ign x))
(set-label! quote "quote")

(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)))
(set-label! list "list")

;; (def list*
;;   (wrap (vau args #ign
;;           (begin
;;             (def aux
;;               (wrap (vau ((head . tail)) #ign
;;                       (if (null? tail)
;; 			  head
;; 			  (cons head (aux tail))))))
;; 	    (aux args)))))
;; (set-label! list* "list*")

(def vau
  ((wrap (vau (vau) #ign
           (vau (formals eformal . body) env
             (eval (list vau formals eformal (cons begin body)) env))))
   vau))
(set-label! vau "vau")

(def lambda
  (vau (formals . body) env
    (wrap (eval (list* vau formals #ign body) env))))
(set-label! lambda "lambda")

(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
  (macro (vau (bindings . body) #ign
           (cons (list* lambda (map car bindings) body)
                 (map cadr bindings)))))

(def let*
  (macro (vau (bindings . body) #ign
           (if (null? bindings)
               (list* let bindings body)
               (list let
                     (list (car bindings))
                     (list* let* (cdr bindings) body))))))

(def letrec
  (macro (vau (bindings . body) #ign
           (list* let ()
                  (list def
                        (map car bindings)
                        (list* list (map cadr bindings)))
                  body))))

(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 (macro (vau (test . body) #ign (list if test (list* begin body) #void))))

(def unless (macro (vau (test . body) #ign (list* when (list not test) body))))

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

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

(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))))

(def define-macro
  (vau ((name . ptree) . body) env
    (eval (list def name (list macro (list* vau ptree #ign body))) 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-macro (dlet dv val . exprs)
  (list dlet* dv val (list* lambda () exprs)))

(define-macro (unwind-protect protected . cleanup)
  (list finally protected (list* begin cleanup)))

(define-macro (loop . forms)
  (list loop1 (list* begin forms)))

(define-syntax (dotimes (var times . optional-result-form) . exprs) env
  (define wrapped-exprs (list* begin exprs))
  (define evaled-times (eval times env))
  (define result-form (if (null? optional-result-form) #void (car optional-result-form)))
  (let ((subenv (make-environment env)))
    (eval (list def var 0) subenv)
    (while (< (eval var subenv) evaled-times)
      (eval wrapped-exprs subenv)
      (eval (list def var (+ 1 (eval var subenv))) subenv))
    (eval result-form subenv)))

(provide (block return-from)
  (define (call-with-escape fun)
    (define extent-ended? #f)
    (define *env* (current-environment))
    (define (escape val)
      (if extent-ended?
          (fail "extent ended")
          (throw* escape val)))
    (unwind-protect (catch* escape (lambda () (fun escape)))
      (set! *env* extent-ended? #t)))
  (define-macro (block name . body)
    (list call-with-escape (list* lambda (list name) body)))
  (define (return-from esc . val) (esc (if (null? val) #void (car val))))
)

(define-syntax (while test . body) env
  (block exit
    (loop
      (if (eval test env)
          (eval (list* begin body) env)
          (return-from exit #void)))))

(define-macro (until test . body)
  (list* while (list not test) body))

(provide (define-generic define-method)
  (define-syntax (define-generic (name . args) . body) env
    (define str-name (symbol->string name))
    (define default-method (if (null? body)
                               (lambda #ign (fail (strcat "method not found: " str-name)))
                               (eval (list* lambda args body) env)))
    (define (generic self . arg)
      (apply (find-method (type-of self) str-name default-method) (cons self arg)))
    (set-label! generic str-name)
    (eval (list def name generic) env)
    generic)
  (define-syntax (define-method (name (self type) . args) . body) env
    (define method (eval (list* lambda (list* self args) body) env))
    (put-method! (eval type env) (symbol->string name) 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-method (= (a Pair) b) (and (pair? b) (and (= (car a) (car b)) (= (cdr a) (cdr 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 pair->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)) (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]")
  (define (pair->string (kar . kdr))
    (if (null? kdr)
        (->string kar)
        (if (pair? kdr)
            (strcat (->string kar) " " (pair->string kdr))
            (strcat (->string kar) " . " (->string kdr)))))
)

(provide (->number)
  (define-generic (->number obj))
  (define-method (->number (obj Number)) obj)
  (define-method (->number (obj String)) (string->number obj))
  (define-method (->number (obj Symbol)) (string->number (symbol->string obj)))
)

(provide (make-prompt push-prompt take-subcont push-subcont shift)
  (def (prompt-type tag-prompt #ign) (make-type))
  (define (make-prompt) (tag-prompt #void))
  (define-syntax (push-prompt p . es) env
    (push-prompt* (eval p env) (eval (list* lambda () es) env)))
  (define-syntax (take-subcont p k . body) env
    (take-subcont* (eval p env) (eval (list* lambda (list k) body) env)))
  (define-syntax (push-subcont k . es) env
    (push-subcont* (eval k env) (eval (list* lambda () es) env)))
  (define (shift* p f)
    (take-subcont p sk (push-prompt p (f (reifyP p sk)))))
  (define (reifyP p sk)
    (lambda (v) (push-prompt p (push-subcont sk v))))
  (define-syntax (shift p sk . es) env
    (eval (list shift* p (list* lambda (list sk) es)) env))
)

(define-syntax (define-js-method name) env
  (define method (js-method (symbol->string name)))
  (eval (list def name (lambda args (from-js (apply method (map to-js args))))) env))

(provide (Option some none if-option)
  (define-record-type Option
    (make-option supplied? value)
    option?
    (supplied? supplied?)
    (value value))
  (define (some a) (make-option #t a))
  (define none (make-option #f #void))
  (define-syntax (if-option (name option) then . else) env
    (let ((o (eval option env)))
      (if (supplied? o)
          (eval (list let (list (list name (value o))) then) env)
          (unless (null? else)
            (eval (car else) env)))))
)

(provide (handle
          catch
          throw
          default-handler
          restart-bind
          invoke-restart
          associated-exception)
  ;; API
  (define-syntax (handle body . handler-specs) env)
  (define-syntax (catch body . handler-specs) env)
  (define-syntax (throw exc . handler-specs) env)
  (define-generic (default-handler exc) #void)
  (define-syntax (restart-bind body . handler-specs) env)
  (define (invoke-restart rst))
  (define-generic (associated-exception rst) none)
  ;; Implementation
  (define *current-exception-handler-set* (dnew none))
  (define *current-restart-handler-set* (dnew none))
)

(define-record-type Blocking
  (make-blocking)
  blocking?)

(define-syntax (time . exprs) env
  (let* ((ms (current-milliseconds))
         (res (eval (list* begin exprs) env)))
    (display (strcat "TIME " (->string (- (current-milliseconds) ms)) "ms " (pair->string exprs)))
    res))

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

;(start-profile)

(def quote (vau (x) #ign x))
(set-label! quote "quote")

(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)))
(set-label! list "list")

;; (def list*
;;   (wrap (vau args #ign
;;           (begin
;;             (def aux
;;               (wrap (vau ((head . tail)) #ign
;;                       (if (null? tail)
;; 			  head
;; 			  (cons head (aux tail))))))
;; 	    (aux args)))))
;; (set-label! list* "list*")

(def vau
  ((wrap (vau (vau) #ign
           (vau (formals eformal . body) env
             (eval (list vau formals eformal (cons begin body)) env))))
   vau))
(set-label! vau "vau")

(def lambda
  (vau (formals . body) env
    (wrap (eval (list* vau formals #ign body) env))))
(set-label! lambda "lambda")

(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
  (macro (vau (bindings . body) #ign
           (cons (list* lambda (map car bindings) body)
                 (map cadr bindings)))))

(def let*
  (macro (vau (bindings . body) #ign
           (if (null? bindings)
               (list* let bindings body)
               (list let
                     (list (car bindings))
                     (list* let* (cdr bindings) body))))))

(def letrec
  (macro (vau (bindings . body) #ign
           (list* let ()
                  (list def
                        (map car bindings)
                        (list* list (map cadr bindings)))
                  body))))

(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 (macro (vau (test . body) #ign (list if test (list* begin body) #void))))

(def unless (macro (vau (test . body) #ign (list* when (list not test) body))))

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

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

(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))))

(def define-macro
  (vau ((name . ptree) . body) env
    (eval (list def name (list macro (list* vau ptree #ign body))) 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-macro (dlet dv val . exprs)
  (list dlet* dv val (list* lambda () exprs)))

(define-macro (unwind-protect protected . cleanup)
  (list finally protected (list* begin cleanup)))

(define-macro (loop . forms)
  (list loop1 (list* begin forms)))

(define-syntax (dotimes (var times . optional-result-form) . exprs) env
  (define wrapped-exprs (list* begin exprs))
  (define evaled-times (eval times env))
  (define result-form (if (null? optional-result-form) #void (car optional-result-form)))
  (let ((subenv (make-environment env)))
    (eval (list def var 0) subenv)
    (while (< (eval var subenv) evaled-times)
      (eval wrapped-exprs subenv)
      (eval (list def var (+ 1 (eval var subenv))) subenv))
    (eval result-form subenv)))

(provide (block return-from)
  (define (call-with-escape fun)
    (define extent-ended? #f)
    (define *env* (current-environment))
    (define (escape val)
      (if extent-ended?
          (fail "extent ended")
          (throw* escape val)))
    (unwind-protect (catch* escape (lambda () (fun escape)))
      (set! *env* extent-ended? #t)))
  (define-macro (block name . body)
    (list call-with-escape (list* lambda (list name) body)))
  (define (return-from esc . val) (esc (if (null? val) #void (car val))))
)

(define-syntax (while test . body) env
  (block exit
    (loop
      (if (eval test env)
          (eval (list* begin body) env)
          (return-from exit #void)))))

(define-macro (until test . body)
  (list* while (list not test) body))

(provide (define-generic define-method)
  (define-syntax (define-generic (name . args) . body) env
    (define str-name (symbol->string name))
    (define default-method (if (null? body)
                               (lambda #ign (fail (strcat "method not found: " str-name)))
                               (eval (list* lambda args body) env)))
    (define (generic self . arg)
      (apply (find-method (type-of self) str-name default-method) (cons self arg)))
    (set-label! generic str-name)
    (eval (list def name generic) env)
    generic)
  (define-syntax (define-method (name (self type) . args) . body) env
    (define method (eval (list* lambda (list* self args) body) env))
    (put-method! (eval type env) (symbol->string name) 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-method (= (a Pair) b) (and (pair? b) (and (= (car a) (car b)) (= (cdr a) (cdr 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 pair->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)) (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]")
  (define (pair->string (kar . kdr))
    (if (null? kdr)
        (->string kar)
        (if (pair? kdr)
            (strcat (->string kar) " " (pair->string kdr))
            (strcat (->string kar) " . " (->string kdr)))))
)

(provide (->number)
  (define-generic (->number obj))
  (define-method (->number (obj Number)) obj)
  (define-method (->number (obj String)) (string->number obj))
  (define-method (->number (obj Symbol)) (string->number (symbol->string obj)))
)

(define (display-stacktrace trace)
  (for-each (lambda (frame) (display (->string frame))) trace))

(define (trap exc)
  (define trace (stacktrace))
  (display "ERROR")
  (display exc)
  (display-stacktrace trace))

(provide (make-prompt push-prompt take-subcont push-subcont shift)
  (def (prompt-type tag-prompt #ign) (make-type))
  (define (make-prompt) (tag-prompt #void))
  (define-syntax (push-prompt p . es) env
    (push-prompt* (eval p env) (eval (list* lambda () es) env)))
  (define-syntax (take-subcont p k . body) env
    (take-subcont* (eval p env) (eval (list* lambda (list k) body) env)))
  (define-syntax (push-subcont k . es) env
    (push-subcont* (eval k env) (eval (list* lambda () es) env)))
  (define (shift* p f)
    (take-subcont p sk (push-prompt p (f (reifyP p sk)))))
  (define (reifyP p sk)
    (lambda (v) (push-prompt p (push-subcont sk v))))
  (define-syntax (shift p sk . es) env
    (eval (list shift* p (list* lambda (list sk) es)) env))
)

(define-syntax (define-js-method name) env
  (define method (js-method (symbol->string name)))
  (eval (list def name (lambda args (from-js (apply method (map to-js args))))) env))

(provide (Option some none if-option)
  (define-record-type Option
    (make-option supplied? value)
    option?
    (supplied? supplied?)
    (value value))
  (define (some a) (make-option #t a))
  (define none (make-option #f #void))
  (define-syntax (if-option (name option) then . else) env
    (let ((o (eval option env)))
      (if (supplied? o)
          (eval (list let (list (list name (value o))) then) env)
          (unless (null? else)
            (eval (car else) env)))))
)

(provide (handle
          catch
          throw
          default-handler
          restart-bind
          invoke-restart
          associated-exception)
  ;; API
  (define-syntax (handle body . handler-specs) env)
  (define-syntax (catch body . handler-specs) env)
  (define-syntax (throw exc . handler-specs) env)
  (define-generic (default-handler exc) #void)
  (define-syntax (restart-bind body . handler-specs) env)
  (define (invoke-restart rst))
  (define-generic (associated-exception rst) none)
  ;; Implementation
  (define *current-exception-handler-set* (dnew none))
  (define *current-restart-handler-set* (dnew none))
)

(define-record-type Blocking
  (make-blocking)
  blocking?)

(define-syntax (time . exprs) env
  (let* ((ms (current-milliseconds))
         (res (eval (list* begin exprs) env)))
    (display (strcat "TIME " (->string (- (current-milliseconds) ms)) "ms " (pair->string exprs)))
    res))


feat: `get_local` ❌ WebAssembly draft vs `local.get` ✅ WebAssembly Specification


Update fail.wat

Update fail.wat

(module
  (func (export "fail_me") (result i32)
    i32.const 1
    i32.const 0
    i32.div_s
  )
)

(module
  (func (export "fail_me") (result i32)
    i32.const 1
    i32.const 0
    i32.div_s)
)


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))
)


Reformat and and or

Reformat and and or

;; -*- mode: scheme -*-

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

;; Rename ur-define
(vm-def _define vm-def)

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

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

;; Macro and vau
(_define make-macro-expander
  (wrap
    (vm-vau (expander) #ignore
      (vm-vau operands env
        (eval (eval (cons expander operands) (make-environment)) env)))))

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

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

;; Ur-lambda
(_define _lambda
  (macro (params . body)
    (list wrap (list* _vau params #ignore body))))

;; Wrap incomplete VM forms
(_define loop
  (macro body
    (list vm-loop (list* begin body))))

(_define catch
  (_vau (protected handler) e
    (eval (list vm-catch protected (eval handler e)) e)))

(_define push-prompt
  (_vau (prompt . body) e
    (eval (list vm-push-prompt (eval prompt e) (list* begin body)) e)))

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

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

;; List utilities
(_define compose (_lambda (f g) (_lambda (arg) (f (g arg)))))

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

;; Important macros and functions
(_define define-macro
  (macro ((name . params) . body)
    (list _define name (list* macro params body))))

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

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

(define-macro (let bindings . body)
  (cons
   (list* _lambda (map-list car bindings) body)
   (map-list cadr bindings)))

(define-macro (let* bindings . body)
  (if (nil? bindings)
    (list* let () body)
    (list let (list (car bindings)) (list* let* (cdr bindings) body))))

(_define lambda
  (_vau (params . body) e
    (_define 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)))
      (eval (list* _lambda untyped-names (list* begin type-checks) body) e))))

(define-macro (define lhs . rhs)
  (if (cons? lhs)
    (list _define (car lhs) (list* lambda (cdr lhs) rhs))
    (list _define lhs (car rhs))))

(define (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
(define cond
  (_vau 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))))))

(define else #t)

(define and
  (_vau 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))))

(define or
  (_vau 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)))))

(define (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))))))

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

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

(define-macro (while test . body)
  (list call-while
        (list _lambda () test)
        (list* _lambda () body)))

(define-macro (when test . body)
  (list if test (list* begin body) #null))

(define-macro (unless test . body)
  (list* when (list not test) body))

(define-macro (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.
(define dlet
  (_vau (bindings . body) e
     (define (process-bindings bs)
       (if (nil? bs)
           (list* begin body)
           (let* ((((name expr) . rest-bs) bs)
                  (value (eval expr e)))
             (list vm-dlet name value (process-bindings rest-bs)))))
     (eval (process-bindings bindings) e)))

;; Prototypes
(define define-prototype
  (_vau (name super prop-names) e
    (let ((p (apply vm-js-make-prototype (list* (symbol-name name) (map-list symbol-name prop-names)))))
      (set! (.prototype (.constructor p)) (new (eval super e)))
      (eval (list _define name p) e))))

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

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

(define-macro (define-generic (name . #ignore))
  (list _define name (vm-js-invoker (symbol-name name))))

;; Modules
(define provide
  (_vau (symbols . body) env
    (eval (list _define symbols
                (list let ()
                      (list* begin body)
                      (list* list symbols)))
          env)))

(define module
  (_vau (exports . body) e
    (let ((env (make-environment e)))
      (eval (list* provide exports body) env)
      (make-environment env))))

(define define-module
  (_vau (name exports . body) e
    (eval (list _define name (list* module exports body)) e)))

(define import
  (_vau (module imports) e
    (let* ((m (eval module e))
           (values (map-list (_lambda (import) (eval import m)) imports)))
      (eval (list _define imports (list* list values)) e))))

;; JavaScript

(define (relational-js-binop name)
  (let ((binop (vm-js-binop name)))
    (define (fun arg1 arg2 . rest)
      (if (binop arg1 arg2)
          (if (nil? rest)
              #t
              (apply fun (list* arg2 rest)))
          #f))
    fun))

(define === (relational-js-binop "==="))
(define == (relational-js-binop "=="))
(define < (relational-js-binop "<"))
(define > (relational-js-binop ">"))
(define <= (relational-js-binop "<="))
(define >= (relational-js-binop ">="))

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

(define * (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
(define + (let ((vm+ (vm-js-binop "+")))
            (lambda args
              (if (nil? args)
                  0
                  (fold-list vm+ (car args) (cdr args))))))

(define (folding-js-op-neg binop unit)
  (lambda (arg1 . rest)
    (if (nil? rest)
        (binop unit arg1)
        (fold-list binop arg1 rest))))

(define - (folding-js-op-neg (vm-js-binop "-") 0))
(define / (folding-js-op-neg (vm-js-binop "/") 1))

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

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

(define object
  (_vau pairs e
    (let ((obj (vm-js-make-object)))
      (map-list (_lambda ((name value))
                  (set! ((js-getter (eval name e)) obj) (eval value e)))
                pairs)
      obj)))

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

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

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

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

(define-macro (type? obj type)
  (list vm-type? obj type (symbol-name type)))

(define-macro (the type obj)
  (list if (list type? obj type) obj (list error (list + obj " is not a: " type))))

(define Arguments $Arguments)
(define Array $Array)
(define Date $Date)
(define Function $Function)
(define Number $Number)
(define Object $Object)
(define RegExp $RegExp)
(define String $String)

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

;; Final events

(define (user-break err)
  (define (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
        (throw err)))))

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

(define bindings->environment
  (_vau bindings denv
    (eval (list let-redirect
                (make-environment)
                bindings
                (list the-environment))
          denv)))

(define slurp-environment
  (_vau bindings e
    (eval (list* bindings->environment (map-list (lambda (b) (list b b)) bindings)) e)))

;; Export bindings to userland

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

(make-environment
  (slurp-environment
   _define _lambda _vau apply eval make-environment the-environment unwrap wrap
   begin define define-macro lambda let let* quote symbol-name symbol?
   caar cadr car cdar cddr cdr cons cons? fold-list list list* map-list nil? reverse-list
   define-generic define-prototype define-method new the type?
   catch cond else if label loop throw unless when while error
   set! setter
   push-prompt push-subcont take-subcont
   dlet dnew dref
   define-module 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
   ))


Fix indentation

Fix indentation

;; -*- mode: scheme -*-

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

;; Rename ur-define
(vm-def _define vm-def)

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

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

;; Macro and vau
(_define make-macro-expander
  (wrap
    (vm-vau (expander) #ignore
      (vm-vau operands env
        (eval (eval (cons expander operands) (make-environment)) env)))))

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

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

(_define define-macro
  (macro ((name . params) . body)
    (list _define name (list* macro params body))))

(define-macro (define-operative (name . params) envparam . body)
  (list _define name (list* _vau params envparam body)))

(define-macro (_lambda params . body)
  (list wrap (list* _vau params #ignore body)))

;; Wrap incomplete VM forms
(define-macro (loop . body)
  (list vm-loop (list* begin body)))

(define-operative (catch protected handler) env
  (eval (list vm-catch protected (eval handler env)) env))

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

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

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

;; List utilities
(_define compose (_lambda (f g) (_lambda (arg) (f (g arg)))))

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

;; Important macros and functions
(_define map-list
  (_lambda (f lst)
    (if (nil? lst)
        ()
        (cons (f (car lst)) (map-list f (cdr lst))))))

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

(define-macro (let bindings . body)
  (cons
   (list* _lambda (map-list car bindings) body)
   (map-list cadr bindings)))

(define-macro (let* bindings . body)
  (if (nil? bindings)
      (list* let () body)
      (list let (list (car bindings)) (list* let* (cdr bindings) body))))

(define-macro (lambda params . body)
  (_define 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)))

(define-macro (define lhs . rhs)
  (if (cons? lhs)
    (list _define (car lhs) (list* lambda (cdr lhs) rhs))
    (list _define lhs (car rhs))))

(define (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
(define-operative (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)))))

(define else #t)

(define-operative (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)))

(define-operative (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))))

(define (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))))))

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

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

(define-macro (while test . body)
  (list call-while
        (list _lambda () test)
        (list* _lambda () body)))

(define-macro (when test . body)
  (list if test (list* begin body) #null))

(define-macro (unless test . body)
  (list* when (list not test) body))

(define-macro (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.
(define-operative (dlet bindings . body) env
  (define (process-bindings bs)
    (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)))))
  (eval (process-bindings bindings) env))

;; Prototypes
(define-operative (define-prototype 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 _define name p) env)))

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

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

(define-macro (define-generic (name . #ignore))
  (list _define name (vm-js-invoker (symbol-name name))))

;; Modules
(define-operative (provide symbols . body) env
  (eval (list _define symbols
              (list let ()
                    (list* begin body)
                    (list* list symbols)))
        env))

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

(define-macro (define-module name exports . body)
  (list _define name (list* module exports body)))

(define-operative (import module imports) env
  (let* ((m (eval module env))
         (values (map-list (_lambda (import) (eval import m)) imports)))
    (eval (list _define imports (list* list values)) env)))

;; JavaScript

(define (relational-js-binop name)
  (let ((binop (vm-js-binop name)))
    (define (fun arg1 arg2 . rest)
      (if (binop arg1 arg2)
          (if (nil? rest)
              #t
              (apply fun (list* arg2 rest)))
          #f))
    fun))

(define = (relational-js-binop "==="))
(define < (relational-js-binop "<"))
(define > (relational-js-binop ">"))
(define <= (relational-js-binop "<="))
(define >= (relational-js-binop ">="))

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

(define * (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
(define + (let ((vm+ (vm-js-binop "+")))
            (lambda args
              (if (nil? args)
                  0
                  (fold-list vm+ (car args) (cdr args))))))

(define (folding-js-op-neg binop unit)
  (lambda (arg1 . rest)
    (if (nil? rest)
        (binop unit arg1)
        (fold-list binop arg1 rest))))

(define - (folding-js-op-neg (vm-js-binop "-") 0))
(define / (folding-js-op-neg (vm-js-binop "/") 1))

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

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

(define-operative (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))

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

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

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

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

(define-macro (type? obj type)
  (list vm-type? obj type (symbol-name type)))

(define-macro (the type obj)
  (list if (list type? obj type) obj (list error (list + obj " is not a: " type))))

(define Arguments $Arguments)
(define Array $Array)
(define Date $Date)
(define Function $Function)
(define Number $Number)
(define Object $Object)
(define RegExp $RegExp)
(define String $String)

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

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

(define (user-break err)
  (define (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
        (throw err)))))

;; Final events

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

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

(define-operative (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
   define-operative _define _lambda _vau apply eval make-environment the-environment unwrap wrap
   begin define define-macro lambda let let* quote symbol-name symbol?
   caar cadr car cdar cddr cdr cons cons? fold-list list list* map-list nil? reverse-list
   define-generic define-prototype define-method new the type?
   catch cond else if label loop throw unless when while error
   set! setter
   push-prompt push-subcont take-subcont
   dlet dnew dref
   define-module 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
   ))


letrec

letrec

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

(def null? (wrap (vau (val) #ign (eq? () val))))

(def pair? (wrap (vau (val) #ign (eq? (type-of val) (type-of (cons #void #void))))))

(def symbol? (wrap (vau (val) #ign (eq? (type-of val) (type-of 'foo)))))

(def procedure? (wrap (vau (val) #ign (eq? (type-of val) (type-of (wrap (vau #ign #ign #void)))))))

;; (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 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 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 quote (vau (x) #ign x))

(def define
  (vau (lhs . rhs) env
    (if (pair? lhs)
	(let (((name . args) lhs))
	  (eval (list def name (list* lambda args rhs)) env))
	(eval (list* def lhs rhs) env))))

(def define-syntax def)

(define (assq obj alist)
  (if (null? alist) () (if (eq? obj (caar alist)) (car alist) (assq obj (cdr alist)))))

(provide (define-method define-generic send)
  (define (put-method type name method)
    (eval (list def name method) (type-environment type)))
  (define (find-method type name)
    (eval name (type-environment type)))
  (define (send obj message arg)
    (apply (find-method (type-of obj) message) (list* obj arg)))
  (define-syntax define-generic
    (vau ((name . #ign)) env
      (eval (list def name (lambda (self . arg) (send self name arg))) env)))
  (define-syntax define-method
    (vau ((name (self type) . args) . body) env
      (put-method (eval type env) name
		  (eval (list* lambda (list* self args) body) env))))
)

(define-generic (to-string obj -> string))

(def String (type-of "foo"))
(define (string? s) (eq? (type-of s) String))
(define-method (to-string (self String)) self)

(define (newline) (display "newline")) ; huh?

(provide (make-prompt push-prompt take-sub-cont push-sub-cont shift)
  (define prompt-type (make-type))
  (define (make-prompt) (tag prompt-type #void))
  (define-syntax push-prompt
    (vau (p . es) env
      (push-prompt* (eval p env)
        (lambda () (eval (list* begin es) env)))))
  (define-syntax take-sub-cont
    (vau (p k . body) env
      (take-sub-cont* (eval p env) (eval (list* lambda (list k) body) env))))
  (define-syntax push-sub-cont
    (vau (k . es) env
      (push-sub-cont* (eval k env)
        (lambda () (eval (list* begin es) env)))))
  (define (shift* p f)
    (take-sub-cont p sk (push-prompt p (f (reifyP p sk)))))
  (define (reifyP p sk)
    (lambda (v) (push-prompt p (push-sub-cont sk v))))
  (define-syntax shift
    (vau (p sk . es) env
      (eval (list shift* p (list* lambda (list sk) es)) env)))
)

(provide (dnew dref dlet dlet*)
  (define parameter-type (make-type))
  (define (dnew) (tag parameter-type #void))
  (define (dref p) (shift p sk (lambda (y) ((sk y) y))))
  (define (dlet* p val thunk)
    ((push-prompt p
       (let ((r (thunk)))
          (lambda (y) r)))
     val))
  (define-syntax dlet
    (vau (key val . body) env
      (eval (list dlet* key val (list* lambda () body)) env)))
)

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

(def null? (wrap (vau (val) #ign (eq? () val))))

(def pair? (wrap (vau (val) #ign (eq? (type-of val) (type-of (cons #void #void))))))

(def symbol? (wrap (vau (val) #ign (eq? (type-of val) (type-of 'foo)))))

(def procedure? (wrap (vau (val) #ign (eq? (type-of val) (type-of (wrap (vau #ign #ign #void)))))))

;; (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 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 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 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 quote (vau (x) #ign x))

(def define
  (vau (lhs . rhs) env
    (if (pair? lhs)
	(let (((name . args) lhs))
	  (eval (list def name (list* lambda args rhs)) env))
	(eval (list* def lhs rhs) env))))

(def define-syntax def)

(define (assq obj alist)
  (if (null? alist) () (if (eq? obj (caar alist)) (car alist) (assq obj (cdr alist)))))

(provide (define-method define-generic send)
  (define (put-method type name method)
    (eval (list def name method) (type-environment type)))
  (define (find-method type name)
    (eval name (type-environment type)))
  (define (send obj message arg)
    (apply (find-method (type-of obj) message) (list* obj arg)))
  (define-syntax define-generic
    (vau ((name . #ign)) env
      (eval (list def name (lambda (self . arg) (send self name arg))) env)))
  (define-syntax define-method
    (vau ((name (self type) . args) . body) env
      (put-method (eval type env) name
		  (eval (list* lambda (list* self args) body) env))))
)

(define-generic (to-string obj -> string))

(def String (type-of "foo"))
(define (string? s) (eq? (type-of s) String))
(define-method (to-string (self String)) self)

(define (newline) (display "newline")) ; huh?

(provide (make-prompt push-prompt take-sub-cont push-sub-cont shift)
  (define prompt-type (make-type))
  (define (make-prompt) (tag prompt-type #void))
  (define-syntax push-prompt
    (vau (p . es) env
      (push-prompt* (eval p env)
        (lambda () (eval (list* begin es) env)))))
  (define-syntax take-sub-cont
    (vau (p k . body) env
      (take-sub-cont* (eval p env) (eval (list* lambda (list k) body) env))))
  (define-syntax push-sub-cont
    (vau (k . es) env
      (push-sub-cont* (eval k env)
        (lambda () (eval (list* begin es) env)))))
  (define (shift* p f)
    (take-sub-cont p sk (push-prompt p (f (reifyP p sk)))))
  (define (reifyP p sk)
    (lambda (v) (push-prompt p (push-sub-cont sk v))))
  (define-syntax shift
    (vau (p sk . es) env
      (eval (list shift* p (list* lambda (list sk) es)) env)))
)

(provide (dnew dref dlet dlet*)
  (define parameter-type (make-type))
  (define (dnew) (tag parameter-type #void))
  (define (dref p) (shift p sk (lambda (y) ((sk y) y))))
  (define (dlet* p val thunk)
    ((push-prompt p
       (let ((r (thunk)))
          (lambda (y) r)))
     val))
  (define-syntax dlet
    (vau (key val . body) env
      (eval (list dlet* key val (list* lambda () body)) env)))
)


Fix a comment

Fix a comment

;; Filename: memory.wat
(module
  ;; Create memory with a size of 1 page (= 64KiB)
  ;; that is growable to up to 100 pages.
  (memory $mem 1 100)
  ;; Export that memory
  (export "memory" (memory $mem))
  ;; Our function with no parameters and no return value,
  ;; but with a local variable for temporary storage.
  (func $add2 (param) (result) (local $tmp i32)
    ;; Load an i32 from address 0 and put it on the stack
    i32.const 0
    i32.load

    ;; Push 2 onto the stack and add the values
    i32.const 2
    i32.add

    ;; Temporarily store the result in the parameter
    local.set $tmp

    ;; Store that value at address 4
    i32.const 4
    local.get $tmp
    i32.store
  )
  (export "add2" (func $add2))
)

;; Filename: memory.wat
(module
  ;; Create memory with a size of 1 page (= 64KiB)
  ;; that is growable to up to 100 pages.
  (memory $mem 1 100)
  ;; Export that memory
  (export "memory" (memory $mem))
  ;; Our function with no parameters and no return value,
  ;; but with a local variable for temporary storage.
  (func $add2 (param) (result) (local $tmp i32)
    ;; Load an i32 from address 0 and put it on the stack
    i32.const 0
    i32.load

    ;; Put the parameter on the stack and add the values
    i32.const 2
    i32.add

    ;; Temporarily store the result in the parameter
    local.set $tmp

    ;; Store that value at address 4
    i32.const 4
    local.get $tmp
    i32.store
  )
  (export "add2" (func $add2))
)


Fix syntax error (put imports first) (#2168)

(module
  (import "console" "log" (func $log (param i32)))

  ;; import a global variable from js
  (global $from_js (import "env" "from_js") i32)

  ;; create a global variable
  (global $from_wasm i32 (i32.const 10))

  (func $main
    ;; load both global variables onto the stack
    global.get $from_js
    global.get $from_wasm

    i32.add ;; add up both globals
    call $log ;; log the result
  )
  (start $main)
)

(module
  (import "console" "log" (func $log (param i32)))

  ;; create a global variable
  (global $from_wasm i32 (i32.const 10))

  ;; import a global variable from js
  (global $from_js (import "env" "from_js") i32)

  (func $main
    ;; load both global variables onto the stack
    global.get $from_js
    global.get $from_wasm

    i32.add ;; add up both globals
    call $log ;; log the result
  )
  (start $main)
)


Another fix

Another fix

;; Name: Fixed-Width SIMD
;; Proposal: https://github.com/webassembly/simd
;; Features: simd

(module
  (func (result v128)
    i32.const 0
    i8x16.splat
    i8x16.popcnt
  )
)

;; Name: Fixed-Width SIMD
;; Proposal: https://github.com/webassembly/simd
;; Features: simd

(module
  (func
    i32.const 0
    i8x16.splat
    i8x16.popcnt
    drop
  )
)


Update memory.wat

Update memory.wat

(module
  (memory (import "js" "mem") 1)
  (func (export "accumulate") (param $ptr i32) (param $len i32) (result i32)
    (local $end i32)
    (local $sum i32)
    (local.set $end
      (i32.add
        (local.get $ptr)
        (i32.mul
          (local.get $len)
          (i32.const 4))))
    (block $break
      (loop $top
        (br_if $break
          (i32.eq
            (local.get $ptr)
            (local.get $end)))
        (local.set $sum
          (i32.add
            (local.get $sum)
            (i32.load
              (local.get $ptr))))
        (local.set $ptr
          (i32.add
            (local.get $ptr)
            (i32.const 4)))
        (br $top)
      )
    )
    (local.get $sum)
  )
)

(module
  (memory (import "js" "mem") 1)
  (func (export "accumulate") (param $ptr i32) (param $len i32) (result i32)
    (local $end i32)
    (local $sum i32)
    (local.set $end
      (i32.add
        (local.get $ptr)
        (i32.mul
          (local.get $len)
          (i32.const 4))))
    (block $break
      (loop $top
        (br_if $break
          (i32.eq
            (local.get $ptr)
            (local.get $end)))
        (local.set $sum
          (i32.add
            (local.get $sum)
            (i32.load
              (local.get $ptr))))
        (local.set $ptr
          (i32.add
            (local.get $ptr)
            (i32.const 4)))
        (br $top)))
    (local.get $sum)))


Update call.wat

Update call.wat

(module
  (func $getAnswer (result i32) i32.const 42)
  (func (export "getAnswerPlus1") (result i32)
    call $getAnswer
    i32.const 1
    i32.add
  )
)

(module
  (func $getAnswer (result i32) i32.const 42)
  (func (export "getAnswerPlus1") (result i32)
    call $getAnswer
    i32.const 1
    i32.add))


Update shared1.wat

Update shared1.wat

(module
  (import "js" "memory" (memory 1))
  (import "js" "table" (table 1 anyfunc))
  (type $void_to_i32 (func (result i32)))
  (func (export "doIt") (result i32)
    (i32.store (i32.const 0) (i32.const 42))  ;; store 42 at address 0
    (call_indirect $void_to_i32 (i32.const 0))
  )
)

(module
  (import "js" "memory" (memory 1))
  (import "js" "table" (table 1 anyfunc))
  (type $void_to_i32 (func (result i32)))
  (func (export "doIt") (result i32)
    (i32.store (i32.const 0) (i32.const 42))  ;; store 42 at address 0
    (call_indirect $void_to_i32 (i32.const 0))))