Remove letrec.

Remove letrec.

;; -*- 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 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 (instance? obj type)
  (eq? (type-of obj) 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))
)

(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-string-hashtable)))
                   (map2 (lambda (field-name arg)
                           (string-hashtable-put! fields-dict (symbol->string field-name) arg))
                         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))
             (unless (defined? accessor-name env)
               (eval (list define-generic (list accessor-name)) env))
             (put-method! type (symbol->string accessor-name)
                          (lambda (obj)
                            (let ((fields-dict (untagger obj)))
                              (string-hashtable-get fields-dict (symbol->string name)))))
             (unless (null? opt)
               (let (((modifier-name) opt))
                 (unless (defined? modifier-name env)
                   (eval (list define-generic (list modifier-name)) env))
                 (put-method! type (symbol->string modifier-name)
                              (lambda (obj new-val)
                                (let ((fields-dict (untagger obj)))
                                  (string-hashtable-put! fields-dict (symbol->string name) new-val))))))))
         field-specs)
    type))

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

(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 (instance? obj type)
  (eq? (type-of obj) 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))
)

(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-string-hashtable)))
                   (map2 (lambda (field-name arg)
                           (string-hashtable-put! fields-dict (symbol->string field-name) arg))
                         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))
             (unless (defined? accessor-name env)
               (eval (list define-generic (list accessor-name)) env))
             (put-method! type (symbol->string accessor-name)
                          (lambda (obj)
                            (let ((fields-dict (untagger obj)))
                              (string-hashtable-get fields-dict (symbol->string name)))))
             (unless (null? opt)
               (let (((modifier-name) opt))
                 (unless (defined? modifier-name env)
                   (eval (list define-generic (list modifier-name)) env))
                 (put-method! type (symbol->string modifier-name)
                              (lambda (obj new-val)
                                (let ((fields-dict (untagger obj)))
                                  (string-hashtable-put! fields-dict (symbol->string name) new-val))))))))
         field-specs)
    type))

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

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


Don't print internal stuff in stacktrace.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

(define-syntax (let-loop a . b) env
  (cond ((pair? a) (eval (list* let a b) env))
	((null? a) (eval (list* let a b) env))
	((symbol? a)
	 (let (((bindings . body) b))
	   (eval (list letrec (list (list a (list* lambda (map car bindings) body)))
		       (list* a (map cadr bindings)))
		 env)))
	(#t (fail "let: not a symbol or list"))))

(define (sublist l i) (if (<= i 0) l (sublist (cdr l) (- i 1))))

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

(provide (make-prompt push-prompt take-sub-cont push-sub-cont 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) (lambda () (eval (list* begin es) env))))
  (define-syntax (take-sub-cont p k . body) env
    (take-sub-cont* (eval p env) (eval (list* lambda (list k) body) env)))
  (define-syntax (push-sub-cont 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 p sk . es) env
    (eval (list shift* p (list* lambda (list sk) es)) env))
)

(provide (dnew dref dlet dlet*)
  (def (parameter-type tag-parameter #ign) (make-type))
  (define (dnew) (tag-parameter #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 key val . body) env
    (eval (list dlet* key val (list* lambda () body)) env))
)

(provide (run yield dynamic-wind for*)
  (def (yield-record-type tag-yield-record untag-yield-record) (make-type))
  (define (make-yield-record v k)
    (tag-yield-record (list v k)))
  (define (try-yield* exp on-r on-y)
    (if (eq? (type-of exp) yield-record-type)
	(let (((v k) (untag-yield-record exp))) (on-y v k))
	(on-r exp)))
  (define yield-prompt (make-prompt))
  (define-syntax (run e) env (push-prompt* yield-prompt (eval (list lambda () e) env)))
  (define (yield v) (shift yield-prompt k (make-yield-record v k)))
  (define (dynamic-wind before-thunk thunk after-thunk)
    (let-loop loop ((th (lambda () (run-thunk))))
      (before-thunk)
      (let ((res (th)))
	(after-thunk)
	(try-yield* res
		    (lambda (r) r)
		    (lambda (v k)
		      (let ((reenter (yield v)))
			(loop (lambda () (k reenter)))))))))
  (define (for* gen body)
    (let-loop loop ((thr (run (gen))))
      (try-yield* thr
		  (lambda (r) r)
		  (lambda (v k)
		    (body v)
		    (loop (k #f))))))
)

(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 *top-level* '*top-level*)

(define (trap exc)
  (display (strcat "An error occurred: " (->string (from-js exc))))
  (display (strcat "Stacktrace:"))
  (print-stacktrace 20)
  (take-sub-cont *top-level* k (push-prompt *top-level* #void)))

(provide (Hashtable hashtable? make-hashtable hashtable-put! hashtable-get make-identity-hashtable)
  (define-record-type Hashtable
    (construct-hashtable hashfn eqfn env)
    hashtable?
    (hashfn hashfn)
    (eqfn eqfn)
    (env env))
  (define (make-hashtable hashfn eqfn)
    (construct-hashtable hashfn eqfn (make-environment)))
  (define (hashtable-put! ht k v)
    (define hash (string->symbol (number->string ((hashfn ht) k))))
    (if (bound? hash (env ht))
        (let ((buckets (eval hash (env ht))))
          (eval (list def hash (buckets-add/replace buckets k v (eqfn ht)))
                (env ht)))
        (eval (list def hash (list list (list cons k v))) (env ht)))
    v)
  (define (buckets-add/replace buckets k v eqfn)
    (if (null? buckets)
        (list (cons k v))
        (if (eqfn k (caar buckets))
            (list* (cons k v) (cdr buckets))
            (list* (car buckets) (buckets-add/replace (cdr buckets) k v eqfn)))))
  (define (hashtable-get ht k . opt)
    (define hash (string->symbol (number->string ((hashfn ht) k))))
    (define default (if (null? opt) () (car opt)))
    (if (bound? hash (env ht))
        (let ((buckets (eval hash (env ht))))
          (buckets-find buckets k (eqfn ht) default))
        default))
  (define (buckets-find buckets k eqfn default)
    (if (null? buckets)
        default
        (if (eqfn k (caar buckets))
            (cdar buckets)
            (buckets-find (cdr buckets) k eqfn default))))
  (define (make-identity-hashtable) (make-hashtable identity-hash-code eq?))
)

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

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

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

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

(define (make-generic-hashtable) (make-hashtable hash-code =))

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

(define (print-stacktrace depth)
  (map (lambda (k) (display (strcat "- " (->string (debug-info k))))) (sublist (stacktrace (+ depth 6)) 6))
  #void)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

(define-syntax (let-loop a . b) env
  (cond ((pair? a) (eval (list* let a b) env))
	((null? a) (eval (list* let a b) env))
	((symbol? a)
	 (let (((bindings . body) b))
	   (eval (list letrec (list (list a (list* lambda (map car bindings) body)))
		       (list* a (map cadr bindings)))
		 env)))
	(#t (fail "let: not a symbol or list"))))

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

(provide (make-prompt push-prompt take-sub-cont push-sub-cont 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) (lambda () (eval (list* begin es) env))))
  (define-syntax (take-sub-cont p k . body) env
    (take-sub-cont* (eval p env) (eval (list* lambda (list k) body) env)))
  (define-syntax (push-sub-cont 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 p sk . es) env
    (eval (list shift* p (list* lambda (list sk) es)) env))
)

(provide (dnew dref dlet dlet*)
  (def (parameter-type tag-parameter #ign) (make-type))
  (define (dnew) (tag-parameter #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 key val . body) env
    (eval (list dlet* key val (list* lambda () body)) env))
)

(provide (run yield dynamic-wind for*)
  (def (yield-record-type tag-yield-record untag-yield-record) (make-type))
  (define (make-yield-record v k)
    (tag-yield-record (list v k)))
  (define (try-yield* exp on-r on-y)
    (if (eq? (type-of exp) yield-record-type)
	(let (((v k) (untag-yield-record exp))) (on-y v k))
	(on-r exp)))
  (define yield-prompt (make-prompt))
  (define-syntax (run e) env (push-prompt* yield-prompt (eval (list lambda () e) env)))
  (define (yield v) (shift yield-prompt k (make-yield-record v k)))
  (define (dynamic-wind before-thunk thunk after-thunk)
    (let-loop loop ((th (lambda () (run-thunk))))
      (before-thunk)
      (let ((res (th)))
	(after-thunk)
	(try-yield* res
		    (lambda (r) r)
		    (lambda (v k)
		      (let ((reenter (yield v)))
			(loop (lambda () (k reenter)))))))))
  (define (for* gen body)
    (let-loop loop ((thr (run (gen))))
      (try-yield* thr
		  (lambda (r) r)
		  (lambda (v k)
		    (body v)
		    (loop (k #f))))))
)

(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 *top-level* '*top-level*)

(define (trap exc)
  (display (strcat "An error occurred: " (->string (from-js exc))))
  (display (strcat "Stacktrace:"))
  (print-stacktrace 20)
  (take-sub-cont *top-level* k (push-prompt *top-level* #void)))

(provide (Hashtable hashtable? make-hashtable hashtable-put! hashtable-get make-identity-hashtable)
  (define-record-type Hashtable
    (construct-hashtable hashfn eqfn env)
    hashtable?
    (hashfn hashfn)
    (eqfn eqfn)
    (env env))
  (define (make-hashtable hashfn eqfn)
    (construct-hashtable hashfn eqfn (make-environment)))
  (define (hashtable-put! ht k v)
    (define hash (string->symbol (number->string ((hashfn ht) k))))
    (if (bound? hash (env ht))
        (let ((buckets (eval hash (env ht))))
          (eval (list def hash (buckets-add/replace buckets k v (eqfn ht)))
                (env ht)))
        (eval (list def hash (list list (list cons k v))) (env ht)))
    v)
  (define (buckets-add/replace buckets k v eqfn)
    (if (null? buckets)
        (list (cons k v))
        (if (eqfn k (caar buckets))
            (list* (cons k v) (cdr buckets))
            (list* (car buckets) (buckets-add/replace (cdr buckets) k v eqfn)))))
  (define (hashtable-get ht k . opt)
    (define hash (string->symbol (number->string ((hashfn ht) k))))
    (define default (if (null? opt) () (car opt)))
    (if (bound? hash (env ht))
        (let ((buckets (eval hash (env ht))))
          (buckets-find buckets k (eqfn ht) default))
        default))
  (define (buckets-find buckets k eqfn default)
    (if (null? buckets)
        default
        (if (eqfn k (caar buckets))
            (cdar buckets)
            (buckets-find (cdr buckets) k eqfn default))))
  (define (make-identity-hashtable) (make-hashtable identity-hash-code eq?))
)

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

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

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

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

(define (make-generic-hashtable) (make-hashtable hash-code =))

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

(define (print-stacktrace depth)
  (map (lambda (k) (display (strcat (->string k) " " (->string (debug-info k))))) (stacktrace depth))
  #void)


[WASM] needed all the pieces setup

[WASM] needed all the pieces setup

plus had 1 small bug in variable in is crowned or some such

(module
  (import "events" "piecemoved"
          (func $notify_piecemoved (param $fromX i32) (param $fromY i32)
                                  (param $toX i32) (param $toY i32)))
  (import "events" "piececrowned"
          (func $notify_piececrowned (param $pieceX i32) (param $pieceY i32)))
  (memory $mem 1)
  (global $currentTurn (mut i32) (i32.const 0))
  (global $WHITE i32 (i32.const 2))
  (global $BLACK i32 (i32.const 1))
  (global $CROWN i32 (i32.const 4))

  (func $indexForPosition (param $x i32) (param $y i32) (result i32)
    (i32.add
      (i32.mul
        (i32.const 8)
        (get_local $y)
      )
      (get_local $x)
    )
  )

  ;; Offsset = ( x + y * 8 ) * 4
  (func $offsetForPosition (param $x i32) (param $y i32) (result i32)
    (i32.mul
      (call $indexForPosition (get_local $x) (get_local $y))
      (i32.const 4)
    )
  )

  ;; Sets a piece on the board.
  (func $setPiece (param $x i32) (param $y i32) (param $piece i32)
    (i32.store
      (call $offsetForPosition
        (get_local $x)
        (get_local $y)
      )
      (get_local $piece)
    )
  )

  ;; Gets a piece from the board. Out of range causes a trap
  (func $getPiece (param $x i32) (param $y i32) (result i32)
    (if (result i32)
      (block (result i32)
        (i32.and
          (call $inRange
            (i32.const 0)
            (i32.const 7)
            (get_local $x)
          )
          (call $inRange
            (i32.const 0)
            (i32.const 7)
            (get_local $y)
          )
        )
      )
    (then
      (i32.load
        (call $offsetForPosition
          (get_local $x)
          (get_local $y)
        )
      )
    )
    (else
      (unreachable)
    )
   )
  )

  ;; Detect if values are within range (inclusive high and low)
  (func $inRange (param $low i32) (param $high i32)
                 (param $value i32) (result i32)
    (i32.and
      (i32.ge_s (get_local $value) (get_local $low))
      (i32.le_s (get_local $value) (get_local $high))
    )
  )

  ;; Gets the current tuurn owener (white or black)
  (func $getTurnOwner (result i32)
    (get_global $currentTurn)
  )

  ;; At the end of a turn, switch turn owner to the other player
  (func $toggleTurnOwner
    (if (i32.eq (call $getTurnOwner) (i32.const 1))
      (then (call $setTurnOwner (i32.const 2)))
      (else (call $setTurnOwner (i32.const 1)))
    )
  )

    ;; Sets the turn owner
  (func $setTurnOwner (param $piece i32)
    (set_global $currentTurn (get_local $piece))
  )

  ;; Determine if it's a player's turn
  (func $isPlayersTurn (param $player i32) (result i32)
    (i32.gt_s
      (i32.and (get_local $player) (call $getTurnOwner))
      (i32.const 0)
    )
  )

  ;; Determine if a piece has been crowned
  (func $isCrowned (param $piece i32) (result i32)
    (i32.eq
      (i32.and (get_local $piece) (get_global $CROWN))
      (get_global $CROWN)
    )
  )

  ;; Determine if a piece is white
  (func $isWhite (param $piece i32) (result i32)
    (i32.eq
      (i32.and (get_local $piece) (get_global $WHITE))
      (get_global $WHITE)
    )
  )

  ;; Determine if a piece is black
  (func $isBlack (param $piece i32) (result i32)
    (i32.eq
      (i32.and (get_local $piece) (get_global $BLACK))
      (get_global $BLACK)
    )
  )

  ;; Adds a crown to a given piece (no mutation)
  (func $withCrown (param $piece i32) (result i32)
    (i32.or (get_local $piece) (get_global $CROWN))
  )

  ;; Removes a crown from a given piece (no mutation)
  (func $withoutCrown (param $piece i32) (result i32)
  (i32.and (get_local $piece) (i32.const 3))
  )

  ;; Should this piece get crowned?
  ;; We crown balck pieces in row 0, white pices in row 7
  (func $shouldCrown (param $pieceY i32) (param $piece i32) (result i32)
    (i32.or
      (i32.and
        (i32.eq
          (get_local $pieceY)
          (i32.const 0)
        )
        (call $isBlack (get_local $piece))
      )
      (i32.and
        (i32.eq
          (get_local $pieceY)
          (i32.const 7)
        )
        (call $isWhite (get_local $piece))
      )
    )
  )

  ;; Converts a piece into a croned piece and invokes
  ;; a host notifier
  (func $crownPiece (param $x i32) (param $y i32)
    (local $piece i32)
    (set_local $piece (call $getPiece (get_local $x)(get_local $y)))
    (call $setPiece (get_local $x) (get_local $y)
      (call $withCrown (get_local $piece)))
    (call $notify_piececrowned (get_local $x)(get_local $y))
  )

  (func $distance (param $x i32) (param $y i32) (result i32)
    (i32.sub (get_local $x) (get_local $y))
  )

  ;; Determine if the move is valid
  (func $isValidMove (param $fromX i32) (param $fromY i32)
                     (param $toX i32) (param $toY i32) (result i32)
    (local $player i32)
    (local $target i32)
    (set_local $player (call $getPiece (get_local $fromX) (get_local $fromY)))
    (set_local $target (call $getPiece (get_local $toX) (get_local $toY)))
    (if (result i32)
      (block (result i32)
        (i32.and
          (call $validJumpDistance (get_local $fromY) (get_local $toY))
          (i32.and
            (call $isPlayersTurn (get_local $player))
            ;; target must be unoccupied
            (i32.eq (get_local $target) (i32.const 0))
          )
        )
      )
      (then
        (i32.const 1)
      )
      (else
        (i32.const 0)
      )
    )
  )

  ;; Ensures travel is 1 or 2 squares
  (func $validJumpDistance (param $from i32) (param $to i32) (result i32)
    (local $d i32)
    (set_local $d
    (if (result i32)
      (i32.gt_s (get_local $to) (get_local $from))
      (then
        (call $distance (get_local $to) (get_local $from))
      )
      (else
        (call $distance (get_local $from) (get_local $to))
      ))
    )
    (i32.le_u
      (get_local $d)
      (i32.const 2)
    )
  )

  ;; Exported move function to be called by the game host
  (func $move (param $fromX i32) (param $fromY i32)
              (param $toX i32) (param $toY i32) (result i32)
    (if (result i32)
      (block (result i32)
        (call $isValidMove (get_local $fromX) (get_local $fromY)
                           (get_local $toX) (get_local $toY))
      )
      (then
        (call $do_move (get_local $fromX) (get_local $fromY)
                       (get_local $toX) (get_local $toY))
      )
      (else
        (i32.const 0)
      )
    )
  )

  ;; Internal move function, performs actual move post-validation of target.
  ;; Currently not handled:
  ;;    - removing opponent piece during a jump
  ;;    - detecting win condition
  (func $do_move (param $fromX i32) (param $fromY i32)
                 (param $toX i32) (param $toY i32) (result i32)
    (local $curpiece i32)
    (set_local $curpiece (call $getPiece (get_local $fromX)(get_local $fromY)))
    (call $toggleTurnOwner)
    (call $setPiece (get_local $toX) (get_local $toY) (get_local $curpiece))
    (call $setPiece (get_local $fromX) (get_local $fromY) (i32.const 0))
    (if (call $shouldCrown (get_local $toY) (get_local $curpiece))
      (then (call $crownPiece (get_local $toX) (get_local $toY))))
    (call $notify_piecemoved (get_local $fromX) (get_local $fromY)
                             (get_local $toX) (get_local $toY))
    (i32.const 1)
  )

  ;; Manually place each piece on the board to initialize the game
  (func $initBoard
    ;; Place the white pieces at the top of the board
    (call $setPiece (i32.const 1) (i32.const 0) (i32.const 2))
    (call $setPiece (i32.const 3) (i32.const 0) (i32.const 2))
    (call $setPiece (i32.const 5) (i32.const 0) (i32.const 2))
    (call $setPiece (i32.const 7) (i32.const 0) (i32.const 2))

    (call $setPiece (i32.const 0) (i32.const 1) (i32.const 2))
    (call $setPiece (i32.const 2) (i32.const 1) (i32.const 2))
    (call $setPiece (i32.const 4) (i32.const 1) (i32.const 2))
    (call $setPiece (i32.const 6) (i32.const 1) (i32.const 2))

    (call $setPiece (i32.const 1) (i32.const 2) (i32.const 2))
    (call $setPiece (i32.const 3) (i32.const 2) (i32.const 2))
    (call $setPiece (i32.const 5) (i32.const 2) (i32.const 2))
    (call $setPiece (i32.const 7) (i32.const 2) (i32.const 2))

    ;; Place the black pieces at the bottom of the board
    (call $setPiece (i32.const 0) (i32.const 5) (i32.const 1))
    (call $setPiece (i32.const 2) (i32.const 5) (i32.const 1))
    (call $setPiece (i32.const 4) (i32.const 5) (i32.const 1))
    (call $setPiece (i32.const 6) (i32.const 5) (i32.const 1))

    (call $setPiece (i32.const 1) (i32.const 6) (i32.const 1))
    (call $setPiece (i32.const 3) (i32.const 6) (i32.const 1))
    (call $setPiece (i32.const 5) (i32.const 6) (i32.const 1))
    (call $setPiece (i32.const 7) (i32.const 6) (i32.const 1))

    (call $setPiece (i32.const 0) (i32.const 7) (i32.const 1))
    (call $setPiece (i32.const 2) (i32.const 7) (i32.const 1))
    (call $setPiece (i32.const 4) (i32.const 7) (i32.const 1))
    (call $setPiece (i32.const 6) (i32.const 7) (i32.const 1))

    (call $setTurnOwner (i32.const 1)) ;; Black goes first
  )

  (export "getPiece" (func $getPiece))
  (export "isCrowned" (func $isCrowned))
  (export "initBoard" (func $initBoard))
  (export "getTurnOwner" (func $getTurnOwner))
  (export "move" (func $move))
  (export "memory" (memory $mem))

)

(module
  (import "events" "piecemoved"
          (func $notify_piecemoved (param $fromX i32) (param $fromY i32)
                                  (param $toX i32) (param $toY i32)))
  (import "events" "piececrowned"
          (func $notify_piececrowned (param $pieceX i32) (param $pieceY i32)))
  (memory $mem 1)
  (global $currentTurn (mut i32) (i32.const 0))
  (global $WHITE i32 (i32.const 2))
  (global $BLACK i32 (i32.const 1))
  (global $CROWN i32 (i32.const 4))

(func $indexForPosition (param $x i32) (param $y i32) (result i32)
  (i32.add
    (i32.mul
      (i32.const 8)
      (get_local $y)
    )
    (get_local $x)
  )
)

;; Offsset = ( x + y * 8 ) * 4
(func $offsetForPosition (param $x i32) (param $y i32) (result i32)
  (i32.mul
    (call $indexForPosition (get_local $x) (get_local $y))
    (i32.const 4)
  )
)

;; Determine if a piece has been crowned
(func $isCrowned (param $piece i32) (result i32)
  (i32.eq
    (i32.and (get_local $piece) (get_global $CROWN))
    (get_global $CROWN)
  )
)

;; Determine if a piece is white
(func $isWhite (param $piece i32) (result i32)
  (i32.eq
    (i32.and (get_local $piece) (get_global $WHITE))
    (get_global $WHITE)
  )
)

;; Determine if a piece is black
(func $isBlack (param $piece i32) (result i32)
  (i32.eq
    (i32.and (get_local $piece) (get_global $BLACK))
    (get_global $BLACK)
  )
)

;; Adds a crown to a given piece (no mutation)
(func $withCrown (param $piece i32) (result i32)
  (i32.or (get_local $piece) (get_global $CROWN))
)

;; Removes a crown from a given piece (no mutation)
(func $withoutCrown (param $piece i32) (result i32)
  (i32.and (get_local $piece) (i32.const 3))
)

;; Sets a piece on the board.
(func $setPiece (param $x i32) (param $y i32) (param $piece i32)
  (i32.store
    (call $offsetForPosition
      (get_local $x)
      (get_local $y)
    )
    (get_local $piece)
  )
)

;; Gets a piece from the board. Out of range causes a trap
(func $getPiece (param $x i32) (param $y i32) (result i32)
  (if (result i32)
    (block (result i32)
      (i32.and
        (call $inRange
          (i32.const 0)
          (i32.const 7)
          (get_local $x)
        )
        (call $inRange
          (i32.const 0)
          (i32.const 7)
          (get_local $y)
        )
      )
    )
    (then
      (i32.load
        (call $offsetForPosition
          (get_local $x)
          (get_local $y)
        )
      )
    )
    (else
      (unreachable)
    )
  )
)

;; Detect if values are within range (inclusive high and low)
(func $inRange (param $low i32) (param $high i32) (param $value i32) (result i32)
  (i32.and
    (i32.ge_s (get_local $value) (get_local $low))
    (i32.le_s (get_local $value) (get_local $high))
  )
)

;; Gets the current tuurn owener (white or black)
(func $getTurnOwner (result i32)
  (get_global $currentTurn)
)

;; At the end of a turn, switch turn owner to the other player
(func $toggleTurnOwner
  (if (i32.eq (call $getTurnOwner) (i32.const 1))
    (then (call $setTurnOwner (i32.const 2)))
    (else (call $setTurnOwner (i32.const 1)))
  )
)

;; Sets the turn owner
(func $setTurnOwner (param $piece i32)
  (set_global $currentTurn (get_local $piece))
)

;; Determine if it's a player's turn
(func $isPlayersTurn (param $player i32) (result i32)
  (i32.gt_s
    (i32.and (get_local $player) (call $getTurnOwner))
    (i32.const 0)
  )
)

;; Should this piece get crowned?
;; We crown balck pieces in row 0, white pices in row 7
(func $shouldCrown (param $pieceY i32) (param $piece i32) (result i32)
  (i32.or
    (i32.and
      (i32.eq
        (get_local $pieceY)
        (i32.const 0)
      )
      (call $isBlack (get_local $piece))
    )
    (i32.and
      (i32.eq
        (get_local $pieceY)
        (i32.const 7)
      )
      (call $isWhite (get_local $piece))
    )
  )
)

;; Converts a piece into a croned piece and invokes
;; a host notifier
(func $crownPiece (param $x i32) (param $y i32)
  (local $piece i32)
  (set_local $piece (call $getPiece (get_local $x)(get_local $y)))
  (call $setPiece (get_local $x)(get_local $y)
    (call $withCrown (get_local $piece)))
  (call $notify_piececrowned (get_local $x)(get_local $y))
)
(func $distance (param $x i32) (param $y i32) (result i32)
  (i32.sub (get_local $x) (get_local $y))
)

;; Determine if the move is valid
(func $isValidMove (param $fromX i32) (param $fromY i32)
                   (param $toX i32) (param $toY i32) (result i32)
  (local $player i32)
  (local $target i32)
  (set_local $player (call $getPiece (get_local $fromX) (get_local $fromY)))
  (set_local $target (call $getPiece (get_local $toX) (get_local $toY)))
  (if (result i32)
    (block (result i32)
      (i32.and
        (call $validJumpDistance (get_local $fromY) (get_local $toY))
        (i32.and
          (call $isPlayersTurn (get_local $player))
          (i32.eq (get_local $target) (i32.const 0)) ;; target must be unoccupied
        )
      )
    )
    (then
      (i32.const 1)
    )
    (else
      (i32.const 0)
    )
  )
)

;; Ensures travel is 1 or 2 squares
(func $validJumpDistance (param $from i32) (param $to i32) (result i32)
  (local $d i32)
  (set_local $d
  (if (result i32)
    (i32.gt_s (get_local $to) (get_local $from))
    (then
      (call $distance (get_local $to) (get_local $from))
    )
    (else
      (call $distance (get_local $from) (get_local $to))
    ))
  )
  (i32.le_u
    (get_local $d)
    (i32.const 2)
  )
)

;; Exported move function to be called by the game host
(func $move (param $fromX i32) (param $fromY i32)
  (param $toX i32) (param $toY i32) (result i32)
  (if (result i32)
    (block (result i32)
      (call $isValidMove (get_local $fromX) (get_local $fromY)
        (get_local $toX) (get_local $toY))
    )
    (then
      (call $do_move (get_local $fromX) (get_local $fromY)
        (get_local $toX) (get_local $toY))
    )
    (else
      (i32.const 0)
    )
  )
)

;; Internal move function, performs actual move post-validation of target.
;; Currently not handled:
;;    - removing opponent piece during a jump
;;    - detecting win condition
(func $do_move (param $fromX i32) (param $fromY i32)
               (param $toX i32) (param $toY i32) (result i32)
  (local $curpiece i32)
  (set_local $curpiece (call $getPiece (get_local $fromX)(get_local $fromY)))
  (call $toggleTurnOwner)
  (call $setPiece (get_local $toX) (get_local $toY) (get_local $curpiece))
  (call $setPiece (get_local $fromX) (get_local $fromY) (i32.const 0))
  (if (call $shouldCrown (get_local $toX) (get_local $toY))
    (then (call $crownPiece (get_local $toX) (get_local $toY))))
  (call $notify_piecemoved (get_local $fromX) (get_local $fromY)
                           (get_local $toX) (get_local $toY))
  (i32.const 1)
)

;; Manually place each piece on the board to initialize the game
(func $initBoard
  ;; Place the white pieces at the top of the board
  (call $setPiece (i32.const 1) (i32.const 0) (i32.const 2))
  (call $setPiece (i32.const 3) (i32.const 0) (i32.const 2))
  (call $setPiece (i32.const 5) (i32.const 0) (i32.const 2))
  (call $setPiece (i32.const 7) (i32.const 0) (i32.const 2))
  (call $setTurnOwner (i32.const 1)) ;; Black goes first
)

  ;; (export "offsetForPosition" (func $offsetForPosition))
  ;; (export "isCrowned" (func $isCrowned))
  ;; (export "isWhite" (func $isWhite))
  ;; (export "isBlack" (func $isBlack))
  ;; (export "whiteCrown" (func $withCrown))
  ;; (export "withoutCrown" (func $withoutCrown))
  (export "getPiece" (func $getPiece))
  (export "isCrowned" (func $isCrowned))
  (export "initBoard" (func $initBoard))
  (export "getTurnOwner" (func $getTurnOwner))
  (export "move" (func $move))
  (export "memory" (memory $mem))

)


Export letrec

Export letrec

;; -*- mode: lisp -*-

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

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

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

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

;;;; Macro and vau

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

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

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

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

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

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

;;;; Wrap incomplete VM forms

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

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

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

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

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

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

;;;; List utilities

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

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

;;;; Important macros and functions

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

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

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

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

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

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

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

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

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

;;;; Simple control

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

(def else #t)

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

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

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

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

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

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

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

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

;;;; Delimited dynamic binding

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

;;;; Prototypes

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

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

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

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

;;;; Modules

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

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

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

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

;;;; JavaScript

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

;;;; Final events

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

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

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

;;;; Export bindings to userland

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

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

;; -*- mode: lisp -*-

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

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

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

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

;;;; Macro and vau

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

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

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

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

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

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

;;;; Wrap incomplete VM forms

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

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

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

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

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

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

;;;; List utilities

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

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

;;;; Important macros and functions

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

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

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

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

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

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

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

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

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

;;;; Simple control

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

(def else #t)

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

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

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

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

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

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

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

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

;;;; Delimited dynamic binding

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

;;;; Prototypes

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

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

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

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

;;;; Modules

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

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

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

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

;;;; JavaScript

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

;;;; Final events

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

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

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

;;;; Export bindings to userland

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

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


Add sample.wat

Add sample.wat

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

error: pathspec 'sample.wat' did not match any file(s) known to git


Create simple-arg.wat

Create simple-arg.wat

;; simple-arg.wat
;; local.get
(module
  (func $getYear (import "imports" "getYear") (param i32))
  (func (export "printYear") (param $year i32)
    (call $getYear(local.get $year))
  )
)

error: pathspec 'webassembly/imports-exports/simple-arg.wat' did not match any file(s) known to git


Write detector

Write detector

;; Name: Memory64
;; Proposal: https://github.com/WebAssembly/memory64
;; Features: memory64

(module
  ;; The syntax support in wabt is currently buggy/incomplete. This works, tho.
  ;; See https://github.com/WebAssembly/wabt/issues/1532
  (memory i64 1)
)

error: pathspec 'src/detectors/memory64/module.wat' did not match any file(s) known to git


Create makefile.wat

Create makefile.wat

#
# Makefile for WATCOM
#
# Created by Julian Smart, January 1999
#
#

WXDIR = $(%WXWIN)

PROGRAM = minimal
OBJECTS = $(PROGRAM).obj

!include $(WXDIR)\src\makeprog.wat

error: pathspec 'oldversions/0.51/makefile.wat' did not match any file(s) known to git


Delete math.wat

Delete math.wat

deleted duplicate wat file

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/eyamil/wasm-utils.git/'