Export the memory instead of importing

Export the memory instead of importing

(module
  (memory (export "mem") 1)

  (global $PRIME32_1 i32 (i32.const 2654435761))
  (global $PRIME32_2 i32 (i32.const 2246822519))
  (global $PRIME32_3 i32 (i32.const 3266489917))
  (global $PRIME32_4 i32 (i32.const 668265263))
  (global $PRIME32_5 i32 (i32.const 374761393))

  (global $PRIME64_1 i64 (i64.const 11400714785074694791))
  (global $PRIME64_2 i64 (i64.const 14029467366897019727))
  (global $PRIME64_3 i64 (i64.const  1609587929392839161))
  (global $PRIME64_4 i64 (i64.const  9650029242287828579))
  (global $PRIME64_5 i64 (i64.const  2870177450012600261))

  (func (export "xxh32") (param $ptr i32) (param $len i32) (param $seed i32) (result i32)
        (local $h32 i32)
        (local $end i32)
        (local $limit i32)
        (local $v1 i32)
        (local $v2 i32)
        (local $v3 i32)
        (local $v4 i32)
        (set_local $end (i32.add (get_local $ptr) (get_local $len)))
        (if
          (i32.ge_u (get_local $len) (i32.const 16))
          (block
            (set_local $limit (i32.sub (get_local $end) (i32.const 16)))
            (set_local $v1 (i32.add (i32.add (get_local $seed) (get_global $PRIME32_1)) (get_global $PRIME32_2)))
            (set_local $v2 (i32.add (get_local $seed) (get_global $PRIME32_2)))
            (set_local $v3 (i32.add (get_local $seed) (i32.const 0)))
            (set_local $v4 (i32.sub (get_local $seed) (get_global $PRIME32_1)))
            ;; For every chunk of 4 words, so 4 * 32bits = 16 bytes
            (loop $4words-loop
                  (set_local $v1 (call $round32 (get_local $v1) (i32.load (get_local $ptr))))
                  (set_local $ptr (i32.add (get_local $ptr) (i32.const 4)))
                  (set_local $v2 (call $round32 (get_local $v2) (i32.load (get_local $ptr))))
                  (set_local $ptr (i32.add (get_local $ptr) (i32.const 4)))
                  (set_local $v3 (call $round32 (get_local $v3) (i32.load (get_local $ptr))))
                  (set_local $ptr (i32.add (get_local $ptr) (i32.const 4)))
                  (set_local $v4 (call $round32 (get_local $v4) (i32.load (get_local $ptr))))
                  (set_local $ptr (i32.add (get_local $ptr) (i32.const 4)))
                  (br_if $4words-loop (i32.le_u (get_local $ptr) (get_local $limit))))
            (set_local $h32 (i32.add
                              (i32.rotl (get_local $v1) (i32.const 1))
                              (i32.add
                                (i32.rotl (get_local $v2) (i32.const 7))
                                (i32.add
                                  (i32.rotl (get_local $v3) (i32.const 12))
                                  (i32.rotl (get_local $v4) (i32.const 18)))))))
          ;; else block, when input is smaller than 16 bytes
          (set_local $h32 (i32.add (get_local $seed) (get_global $PRIME32_5))))
        (set_local $h32 (i32.add (get_local $h32) (get_local $len)))
        ;; For the remaining words not covered above, either 0, 1, 2 or 3
        (block $exit-remaining-words
               (loop $remaining-words-loop
                     (br_if $exit-remaining-words (i32.gt_u (i32.add (get_local $ptr) (i32.const 4)) (get_local $end)))
                     (set_local $h32 (i32.add (get_local $h32) (i32.mul (i32.load (get_local $ptr)) (get_global $PRIME32_3))))
                     (set_local $h32 (i32.mul (i32.rotl (get_local $h32) (i32.const 17)) (get_global $PRIME32_4)))
                     (set_local $ptr (i32.add (get_local $ptr) (i32.const 4)))
                     (br $remaining-words-loop)))
        ;; For the remaining bytes that didn't make a whole word,
        ;; either 0, 1, 2 or 3 bytes, as 4bytes = 32bits = 1 word.
        (block $exit-remaining-bytes
               (loop $remaining-bytes-loop
                     (br_if $exit-remaining-bytes (i32.ge_u (get_local $ptr) (get_local $end)))
                     (set_local $h32 (i32.add (get_local $h32) (i32.mul (i32.load8_u (get_local $ptr)) (get_global $PRIME32_5))))
                     (set_local $h32 (i32.mul (i32.rotl (get_local $h32) (i32.const 11)) (get_global $PRIME32_1)))
                     (set_local $ptr (i32.add (get_local $ptr) (i32.const 1)))
                     (br $remaining-bytes-loop)))
        ;; Finalise
        (set_local $h32 (i32.xor (get_local $h32) (i32.shr_u (get_local $h32) (i32.const 15))))
        (set_local $h32 (i32.mul (get_local $h32) (get_global $PRIME32_2)))
        (set_local $h32 (i32.xor (get_local $h32) (i32.shr_u (get_local $h32) (i32.const 13))))
        (set_local $h32 (i32.mul (get_local $h32) (get_global $PRIME32_3)))
        (set_local $h32 (i32.xor (get_local $h32) (i32.shr_u (get_local $h32) (i32.const 16))))
        (get_local $h32))

  (func $round32 (param $seed i32) (param $value i32) (result i32)
        (set_local $seed (i32.add  (get_local $seed) (i32.mul (get_local $value) (get_global $PRIME32_2))))
        (set_local $seed (i32.rotl (get_local $seed) (i32.const 13)))
        (set_local $seed (i32.mul (get_local $seed) (get_global $PRIME32_1)))
        (get_local $seed))

  ;; This is the actual WebAssembly implementation.
  ;; It cannot be used directly from JavaScript because of the lack of support
  ;; for i64.
  (func $xxh64 (param $ptr i32) (param $len i32) (param $seed i64) (result i64)
        (local $h64 i64)
        (local $end i32)
        (local $limit i32)
        (local $v1 i64)
        (local $v2 i64)
        (local $v3 i64)
        (local $v4 i64)
        (set_local $end (i32.add (get_local $ptr) (get_local $len)))
        (if
          (i32.ge_u (get_local $len) (i32.const 32))
          (block
            (set_local $limit (i32.sub (get_local $end) (i32.const 32)))
            (set_local $v1 (i64.add (i64.add (get_local $seed) (get_global $PRIME64_1)) (get_global $PRIME64_2)))
            (set_local $v2 (i64.add (get_local $seed) (get_global $PRIME64_2)))
            (set_local $v3 (i64.add (get_local $seed) (i64.const 0)))
            (set_local $v4 (i64.sub (get_local $seed) (get_global $PRIME64_1)))
            ;; For every chunk of 4 words, so 4 * 64bits = 32 bytes
            (loop $4words-loop
                  (set_local $v1 (call $round64 (get_local $v1) (i64.load (get_local $ptr))))
                  (set_local $ptr (i32.add (get_local $ptr) (i32.const 8)))
                  (set_local $v2 (call $round64 (get_local $v2) (i64.load (get_local $ptr))))
                  (set_local $ptr (i32.add (get_local $ptr) (i32.const 8)))
                  (set_local $v3 (call $round64 (get_local $v3) (i64.load (get_local $ptr))))
                  (set_local $ptr (i32.add (get_local $ptr) (i32.const 8)))
                  (set_local $v4 (call $round64 (get_local $v4) (i64.load (get_local $ptr))))
                  (set_local $ptr (i32.add (get_local $ptr) (i32.const 8)))
                  (br_if $4words-loop (i32.le_u (get_local $ptr) (get_local $limit))))
            (set_local $h64 (i64.add
                              (i64.rotl (get_local $v1) (i64.const 1))
                              (i64.add
                                (i64.rotl (get_local $v2) (i64.const 7))
                                (i64.add
                                  (i64.rotl (get_local $v3) (i64.const 12))
                                  (i64.rotl (get_local $v4) (i64.const 18))))))
            (set_local $h64 (call $merge-round64 (get_local $h64) (get_local $v1)))
            (set_local $h64 (call $merge-round64 (get_local $h64) (get_local $v2)))
            (set_local $h64 (call $merge-round64 (get_local $h64) (get_local $v3)))
            (set_local $h64 (call $merge-round64 (get_local $h64) (get_local $v4))))
          ;; else block, when input is smaller than 32 bytes
          (set_local $h64 (i64.add (get_local $seed) (get_global $PRIME64_5))))
        (set_local $h64 (i64.add (get_local $h64) (i64.extend_u/i32 (get_local $len))))
        ;; For the remaining words not covered above, either 0, 1, 2 or 3
        (block $exit-remaining-words
               (loop $remaining-words-loop
                     (br_if $exit-remaining-words (i32.gt_u (i32.add (get_local $ptr) (i32.const 8)) (get_local $end)))
                     (set_local $h64 (i64.xor (get_local $h64) (call $round64 (i64.const 0) (i64.load (get_local $ptr)))))
                     (set_local $h64 (i64.add
                                       (i64.mul
                                         (i64.rotl (get_local $h64) (i64.const 27))
                                         (get_global $PRIME64_1))
                                       (get_global $PRIME64_4)))
                     (set_local $ptr (i32.add (get_local $ptr) (i32.const 8)))
                     (br $remaining-words-loop)))
        ;; For the remaining half word. That is when there are more than 32bits
        ;; remaining which didn't make a whole word.
        (if
          (i32.le_u (i32.add (get_local $ptr) (i32.const 4)) (get_local $end))
          (block
            (set_local $h64 (i64.xor (get_local $h64) (i64.mul (i64.load32_u (get_local $ptr)) (get_global $PRIME64_1))))
            (set_local $h64 (i64.add
                              (i64.mul
                                (i64.rotl (get_local $h64) (i64.const 23))
                                (get_global $PRIME64_2))
                              (get_global $PRIME64_3)))
            (set_local $ptr (i32.add (get_local $ptr) (i32.const 4)))))
        ;; For the remaining bytes that didn't make a half a word (32bits),
        ;; either 0, 1, 2 or 3 bytes, as 4bytes = 32bits = 1/2 word.
        (block $exit-remaining-bytes
               (loop $remaining-bytes-loop
                     (br_if $exit-remaining-bytes (i32.ge_u (get_local $ptr) (get_local $end)))
                     (set_local $h64 (i64.xor (get_local $h64) (i64.mul (i64.load8_u (get_local $ptr)) (get_global $PRIME64_5))))
                     (set_local $h64 (i64.mul (i64.rotl (get_local $h64) (i64.const 11)) (get_global $PRIME64_1)))
                     (set_local $ptr (i32.add (get_local $ptr) (i32.const 1)))
                     (br $remaining-bytes-loop)))
        ;; Finalise
        (set_local $h64 (i64.xor (get_local $h64) (i64.shr_u (get_local $h64) (i64.const 33))))
        (set_local $h64 (i64.mul (get_local $h64) (get_global $PRIME64_2)))
        (set_local $h64 (i64.xor (get_local $h64) (i64.shr_u (get_local $h64) (i64.const 29))))
        (set_local $h64 (i64.mul (get_local $h64) (get_global $PRIME64_3)))
        (set_local $h64 (i64.xor (get_local $h64) (i64.shr_u (get_local $h64) (i64.const 32))))
        (get_local $h64))

  (func $round64 (param $acc i64) (param $value i64) (result i64)
        (set_local $acc (i64.add  (get_local $acc) (i64.mul (get_local $value) (get_global $PRIME64_2))))
        (set_local $acc (i64.rotl (get_local $acc) (i64.const 31)))
        (set_local $acc (i64.mul (get_local $acc) (get_global $PRIME64_1)))
        (get_local $acc))

  (func $merge-round64 (param $acc i64) (param $value i64) (result i64)
        (set_local $value (call $round64 (i64.const 0) (get_local $value)))
        (set_local $acc (i64.xor (get_local $acc) (get_local $value)))
        (set_local $acc (i64.add (i64.mul (get_local $acc) (get_global $PRIME64_1)) (get_global $PRIME64_4)))
        (get_local $acc))

  ;; This function can be called from JavaScript and it expects that the
  ;; first word in the memory is the u64 seed, which is followed by the actual
  ;; data that is being hashed.
  ;; $ptr indicates the beginning of the memory where it's stored (with seed).
  ;; $len is the length of the actual data (without the 8bytes for the seed).
  ;; The function itself doesn't return anything, since the u64 wouldn't work
  ;; in JavaScript, so instead it is stored in place of the seed.
  (func (export "xxh64") (param $ptr i32) (param $len i32)
        (local $seed i64)
        (local $initial-ptr i32)
        (local $h64 i64)
        (set_local $initial-ptr (i32.add (get_local $ptr) (i32.const 0)))
        ;; Assemble the u64 seed from two u32 that were stored from JavaScript.
        ;; I would have thought it would be okay to just load an i64 directly,
        ;; but apparently that is not the case.
        (set_local $seed (i64.or
                           (i64.shl
                             (i64.load32_u (get_local $ptr))
                             (i64.const 32))
                           (i64.load32_u (i32.add (get_local $ptr) (i32.const 4)))))
        (set_local $ptr (i32.add (get_local $ptr) (i32.const 8)))
        (set_local $h64 (call $xxh64 (get_local $ptr) (get_local $len) (get_local $seed)))
        ;; Disassemble the u64 hash result to two u32 that can be read from
        ;; JavaScript. Again, I would have thought just storing the i64 would be
        ;; good enough.
        (i32.store (get_local $initial-ptr) (i32.wrap/i64 (i64.shr_u (get_local $h64) (i64.const 32))))
        (i32.store (i32.add (get_local $initial-ptr) (i32.const 4)) (i32.wrap/i64 (get_local $h64)))))

(module
  (import "data" "memory" (memory 1))

  (global $PRIME32_1 i32 (i32.const 2654435761))
  (global $PRIME32_2 i32 (i32.const 2246822519))
  (global $PRIME32_3 i32 (i32.const 3266489917))
  (global $PRIME32_4 i32 (i32.const 668265263))
  (global $PRIME32_5 i32 (i32.const 374761393))

  (global $PRIME64_1 i64 (i64.const 11400714785074694791))
  (global $PRIME64_2 i64 (i64.const 14029467366897019727))
  (global $PRIME64_3 i64 (i64.const  1609587929392839161))
  (global $PRIME64_4 i64 (i64.const  9650029242287828579))
  (global $PRIME64_5 i64 (i64.const  2870177450012600261))

  (func (export "xxh32") (param $ptr i32) (param $len i32) (param $seed i32) (result i32)
        (local $h32 i32)
        (local $end i32)
        (local $limit i32)
        (local $v1 i32)
        (local $v2 i32)
        (local $v3 i32)
        (local $v4 i32)
        (set_local $end (i32.add (get_local $ptr) (get_local $len)))
        (if
          (i32.ge_u (get_local $len) (i32.const 16))
          (block
            (set_local $limit (i32.sub (get_local $end) (i32.const 16)))
            (set_local $v1 (i32.add (i32.add (get_local $seed) (get_global $PRIME32_1)) (get_global $PRIME32_2)))
            (set_local $v2 (i32.add (get_local $seed) (get_global $PRIME32_2)))
            (set_local $v3 (i32.add (get_local $seed) (i32.const 0)))
            (set_local $v4 (i32.sub (get_local $seed) (get_global $PRIME32_1)))
            ;; For every chunk of 4 words, so 4 * 32bits = 16 bytes
            (loop $4words-loop
                  (set_local $v1 (call $round32 (get_local $v1) (i32.load (get_local $ptr))))
                  (set_local $ptr (i32.add (get_local $ptr) (i32.const 4)))
                  (set_local $v2 (call $round32 (get_local $v2) (i32.load (get_local $ptr))))
                  (set_local $ptr (i32.add (get_local $ptr) (i32.const 4)))
                  (set_local $v3 (call $round32 (get_local $v3) (i32.load (get_local $ptr))))
                  (set_local $ptr (i32.add (get_local $ptr) (i32.const 4)))
                  (set_local $v4 (call $round32 (get_local $v4) (i32.load (get_local $ptr))))
                  (set_local $ptr (i32.add (get_local $ptr) (i32.const 4)))
                  (br_if $4words-loop (i32.le_u (get_local $ptr) (get_local $limit))))
            (set_local $h32 (i32.add
                              (i32.rotl (get_local $v1) (i32.const 1))
                              (i32.add
                                (i32.rotl (get_local $v2) (i32.const 7))
                                (i32.add
                                  (i32.rotl (get_local $v3) (i32.const 12))
                                  (i32.rotl (get_local $v4) (i32.const 18)))))))
          ;; else block, when input is smaller than 16 bytes
          (set_local $h32 (i32.add (get_local $seed) (get_global $PRIME32_5))))
        (set_local $h32 (i32.add (get_local $h32) (get_local $len)))
        ;; For the remaining words not covered above, either 0, 1, 2 or 3
        (block $exit-remaining-words
               (loop $remaining-words-loop
                     (br_if $exit-remaining-words (i32.gt_u (i32.add (get_local $ptr) (i32.const 4)) (get_local $end)))
                     (set_local $h32 (i32.add (get_local $h32) (i32.mul (i32.load (get_local $ptr)) (get_global $PRIME32_3))))
                     (set_local $h32 (i32.mul (i32.rotl (get_local $h32) (i32.const 17)) (get_global $PRIME32_4)))
                     (set_local $ptr (i32.add (get_local $ptr) (i32.const 4)))
                     (br $remaining-words-loop)))
        ;; For the remaining bytes that didn't make a whole word,
        ;; either 0, 1, 2 or 3 bytes, as 4bytes = 32bits = 1 word.
        (block $exit-remaining-bytes
               (loop $remaining-bytes-loop
                     (br_if $exit-remaining-bytes (i32.ge_u (get_local $ptr) (get_local $end)))
                     (set_local $h32 (i32.add (get_local $h32) (i32.mul (i32.load8_u (get_local $ptr)) (get_global $PRIME32_5))))
                     (set_local $h32 (i32.mul (i32.rotl (get_local $h32) (i32.const 11)) (get_global $PRIME32_1)))
                     (set_local $ptr (i32.add (get_local $ptr) (i32.const 1)))
                     (br $remaining-bytes-loop)))
        ;; Finalise
        (set_local $h32 (i32.xor (get_local $h32) (i32.shr_u (get_local $h32) (i32.const 15))))
        (set_local $h32 (i32.mul (get_local $h32) (get_global $PRIME32_2)))
        (set_local $h32 (i32.xor (get_local $h32) (i32.shr_u (get_local $h32) (i32.const 13))))
        (set_local $h32 (i32.mul (get_local $h32) (get_global $PRIME32_3)))
        (set_local $h32 (i32.xor (get_local $h32) (i32.shr_u (get_local $h32) (i32.const 16))))
        (get_local $h32))

  (func $round32 (param $seed i32) (param $value i32) (result i32)
        (set_local $seed (i32.add  (get_local $seed) (i32.mul (get_local $value) (get_global $PRIME32_2))))
        (set_local $seed (i32.rotl (get_local $seed) (i32.const 13)))
        (set_local $seed (i32.mul (get_local $seed) (get_global $PRIME32_1)))
        (get_local $seed))

  ;; This is the actual WebAssembly implementation.
  ;; It cannot be used directly from JavaScript because of the lack of support
  ;; for i64.
  (func $xxh64 (param $ptr i32) (param $len i32) (param $seed i64) (result i64)
        (local $h64 i64)
        (local $end i32)
        (local $limit i32)
        (local $v1 i64)
        (local $v2 i64)
        (local $v3 i64)
        (local $v4 i64)
        (set_local $end (i32.add (get_local $ptr) (get_local $len)))
        (if
          (i32.ge_u (get_local $len) (i32.const 32))
          (block
            (set_local $limit (i32.sub (get_local $end) (i32.const 32)))
            (set_local $v1 (i64.add (i64.add (get_local $seed) (get_global $PRIME64_1)) (get_global $PRIME64_2)))
            (set_local $v2 (i64.add (get_local $seed) (get_global $PRIME64_2)))
            (set_local $v3 (i64.add (get_local $seed) (i64.const 0)))
            (set_local $v4 (i64.sub (get_local $seed) (get_global $PRIME64_1)))
            ;; For every chunk of 4 words, so 4 * 64bits = 32 bytes
            (loop $4words-loop
                  (set_local $v1 (call $round64 (get_local $v1) (i64.load (get_local $ptr))))
                  (set_local $ptr (i32.add (get_local $ptr) (i32.const 8)))
                  (set_local $v2 (call $round64 (get_local $v2) (i64.load (get_local $ptr))))
                  (set_local $ptr (i32.add (get_local $ptr) (i32.const 8)))
                  (set_local $v3 (call $round64 (get_local $v3) (i64.load (get_local $ptr))))
                  (set_local $ptr (i32.add (get_local $ptr) (i32.const 8)))
                  (set_local $v4 (call $round64 (get_local $v4) (i64.load (get_local $ptr))))
                  (set_local $ptr (i32.add (get_local $ptr) (i32.const 8)))
                  (br_if $4words-loop (i32.le_u (get_local $ptr) (get_local $limit))))
            (set_local $h64 (i64.add
                              (i64.rotl (get_local $v1) (i64.const 1))
                              (i64.add
                                (i64.rotl (get_local $v2) (i64.const 7))
                                (i64.add
                                  (i64.rotl (get_local $v3) (i64.const 12))
                                  (i64.rotl (get_local $v4) (i64.const 18))))))
            (set_local $h64 (call $merge-round64 (get_local $h64) (get_local $v1)))
            (set_local $h64 (call $merge-round64 (get_local $h64) (get_local $v2)))
            (set_local $h64 (call $merge-round64 (get_local $h64) (get_local $v3)))
            (set_local $h64 (call $merge-round64 (get_local $h64) (get_local $v4))))
          ;; else block, when input is smaller than 32 bytes
          (set_local $h64 (i64.add (get_local $seed) (get_global $PRIME64_5))))
        (set_local $h64 (i64.add (get_local $h64) (i64.extend_u/i32 (get_local $len))))
        ;; For the remaining words not covered above, either 0, 1, 2 or 3
        (block $exit-remaining-words
               (loop $remaining-words-loop
                     (br_if $exit-remaining-words (i32.gt_u (i32.add (get_local $ptr) (i32.const 8)) (get_local $end)))
                     (set_local $h64 (i64.xor (get_local $h64) (call $round64 (i64.const 0) (i64.load (get_local $ptr)))))
                     (set_local $h64 (i64.add
                                       (i64.mul
                                         (i64.rotl (get_local $h64) (i64.const 27))
                                         (get_global $PRIME64_1))
                                       (get_global $PRIME64_4)))
                     (set_local $ptr (i32.add (get_local $ptr) (i32.const 8)))
                     (br $remaining-words-loop)))
        ;; For the remaining half word. That is when there are more than 32bits
        ;; remaining which didn't make a whole word.
        (if
          (i32.le_u (i32.add (get_local $ptr) (i32.const 4)) (get_local $end))
          (block
            (set_local $h64 (i64.xor (get_local $h64) (i64.mul (i64.load32_u (get_local $ptr)) (get_global $PRIME64_1))))
            (set_local $h64 (i64.add
                              (i64.mul
                                (i64.rotl (get_local $h64) (i64.const 23))
                                (get_global $PRIME64_2))
                              (get_global $PRIME64_3)))
            (set_local $ptr (i32.add (get_local $ptr) (i32.const 4)))))
        ;; For the remaining bytes that didn't make a half a word (32bits),
        ;; either 0, 1, 2 or 3 bytes, as 4bytes = 32bits = 1/2 word.
        (block $exit-remaining-bytes
               (loop $remaining-bytes-loop
                     (br_if $exit-remaining-bytes (i32.ge_u (get_local $ptr) (get_local $end)))
                     (set_local $h64 (i64.xor (get_local $h64) (i64.mul (i64.load8_u (get_local $ptr)) (get_global $PRIME64_5))))
                     (set_local $h64 (i64.mul (i64.rotl (get_local $h64) (i64.const 11)) (get_global $PRIME64_1)))
                     (set_local $ptr (i32.add (get_local $ptr) (i32.const 1)))
                     (br $remaining-bytes-loop)))
        ;; Finalise
        (set_local $h64 (i64.xor (get_local $h64) (i64.shr_u (get_local $h64) (i64.const 33))))
        (set_local $h64 (i64.mul (get_local $h64) (get_global $PRIME64_2)))
        (set_local $h64 (i64.xor (get_local $h64) (i64.shr_u (get_local $h64) (i64.const 29))))
        (set_local $h64 (i64.mul (get_local $h64) (get_global $PRIME64_3)))
        (set_local $h64 (i64.xor (get_local $h64) (i64.shr_u (get_local $h64) (i64.const 32))))
        (get_local $h64))

  (func $round64 (param $acc i64) (param $value i64) (result i64)
        (set_local $acc (i64.add  (get_local $acc) (i64.mul (get_local $value) (get_global $PRIME64_2))))
        (set_local $acc (i64.rotl (get_local $acc) (i64.const 31)))
        (set_local $acc (i64.mul (get_local $acc) (get_global $PRIME64_1)))
        (get_local $acc))

  (func $merge-round64 (param $acc i64) (param $value i64) (result i64)
        (set_local $value (call $round64 (i64.const 0) (get_local $value)))
        (set_local $acc (i64.xor (get_local $acc) (get_local $value)))
        (set_local $acc (i64.add (i64.mul (get_local $acc) (get_global $PRIME64_1)) (get_global $PRIME64_4)))
        (get_local $acc))

  ;; This function can be called from JavaScript and it expects that the
  ;; first word in the memory is the u64 seed, which is followed by the actual
  ;; data that is being hashed.
  ;; $ptr indicates the beginning of the memory where it's stored (with seed).
  ;; $len is the length of the actual data (without the 8bytes for the seed).
  ;; The function itself doesn't return anything, since the u64 wouldn't work
  ;; in JavaScript, so instead it is stored in place of the seed.
  (func (export "xxh64") (param $ptr i32) (param $len i32)
        (local $seed i64)
        (local $initial-ptr i32)
        (local $h64 i64)
        (set_local $initial-ptr (i32.add (get_local $ptr) (i32.const 0)))
        ;; Assemble the u64 seed from two u32 that were stored from JavaScript.
        ;; I would have thought it would be okay to just load an i64 directly,
        ;; but apparently that is not the case.
        (set_local $seed (i64.or
                           (i64.shl
                             (i64.load32_u (get_local $ptr))
                             (i64.const 32))
                           (i64.load32_u (i32.add (get_local $ptr) (i32.const 4)))))
        (set_local $ptr (i32.add (get_local $ptr) (i32.const 8)))
        (set_local $h64 (call $xxh64 (get_local $ptr) (get_local $len) (get_local $seed)))
        ;; Disassemble the u64 hash result to two u32 that can be read from
        ;; JavaScript. Again, I would have thought just storing the i64 would be
        ;; good enough.
        (i32.store (get_local $initial-ptr) (i32.wrap/i64 (i64.shr_u (get_local $h64) (i64.const 32))))
        (i32.store (i32.add (get_local $initial-ptr) (i32.const 4)) (i32.wrap/i64 (get_local $h64)))))


[Test] simplify .wat code for finalize-exports-issue-8261 test

(module
  (func (export "a") (result i32)
    (i32.const 1)
  )
)


add new leak test from Oleg

add new leak test from Oleg

;; -*- mode: scheme -*-

  ;;;;; Test Core Language

  ;; DEF

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

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

  ;; IF

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

  ;; VAU

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

  ;; EVAL

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

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

  ;; WRAP

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

  ;; UNWRAP

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

  ;; EQ?

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

  ;; CONS

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

  ;; MAKE-ENVIRONMENT

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

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

  ;; MAKE-TYPE

  (provide ()
    (def (type tagger untagger) (make-type))
    (assert (eq? (type-of type) (type-of (type-of #t))))
    (let ((x (list #void)))
      (eq? type (type-of (tagger x)))
      (eq? x (untagger (tagger x)))))

  ;; TYPE-OF

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

  ;; VECTOR, VECTOR-REF

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

  ;; Quotation

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

  ;;;;; Test Crust Language

  ;; NULL?

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

  ;; BEGIN

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

;; Delimited Control

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

(define new-prompt make-prompt)

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

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

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

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

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

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

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

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

;; Delimited Dynamic Binding

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

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

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

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

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

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

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

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

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

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

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

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

;; -*- mode: scheme -*-

  ;;;;; Test Core Language

  ;; DEF

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

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

  ;; IF

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

  ;; VAU

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

  ;; EVAL

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

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

  ;; WRAP

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

  ;; UNWRAP

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

  ;; EQ?

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

  ;; CONS

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

  ;; MAKE-ENVIRONMENT

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

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

  ;; MAKE-TYPE

  (provide ()
    (def (type tagger untagger) (make-type))
    (assert (eq? (type-of type) (type-of (type-of #t))))
    (let ((x (list #void)))
      (eq? type (type-of (tagger x)))
      (eq? x (untagger (tagger x)))))

  ;; TYPE-OF

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

  ;; VECTOR, VECTOR-REF

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

  ;; Quotation

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

  ;;;;; Test Crust Language

  ;; NULL?

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

  ;; BEGIN

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

;; Delimited Control

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

(define new-prompt make-prompt)

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

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

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

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

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

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

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

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

;; Delimited Dynamic Binding

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

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

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

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

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

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

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

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

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

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

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

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


Simplify read-input.

Simplify read-input.

;; -*- mode: scheme -*-

;; WAT ON THE WWW

(provide (read display)

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

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

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

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

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

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

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

(provide (read input-callback)
  (define *env* (current-environment))
  (define *read-k* #f)
  (define (read)
    (take-subcont *top-level* k (set! *env* *read-k* k)))
  (define (input-callback evt)
    (if (num= (from-js (js-prop evt "keyCode")) 13)
        (push-prompt *top-level* (push-subcont *read-k* (read-input)))
        #void)))

(js-set-prop! (getElementById "input") "onkeypress" (js-callback input-callback))

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

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

) ; edivorp

;; -*- mode: scheme -*-

;; WAT ON THE WWW

(provide (read display)

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

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

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

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

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

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

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

(provide (read input-callback)
  (define *env* (current-environment))
  (define *read-k* #f)
  (define (read)
    (take-subcont *top-level* k (set! *env* *read-k* k)))
  (define (input-callback evt)
    (if (num= (from-js (js-prop evt "keyCode")) 13)
        (push-prompt *top-level* (push-subcont *read-k* (read-input)))
        #void)))

(js-set-prop! (getElementById "input") "onkeypress" (js-callback input-callback))

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

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

) ; edivorp


label opvs

label opvs

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

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

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

;; -*- 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 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 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))
	  (eval (list def name (list* vau args (car rhs) (cdr rhs))) env))
	(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))

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

(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)) (label obj))
  (define-method (->string (obj Operative)) "#[Operative]")
  (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)


Update logger2.wat

Update logger2.wat

(module
  (import "console" "log" (func $log (param i32 i32)))
  (import "js" "mem" (memory 1))
  (data (i32.const 0) "Hi")
  (func (export "writeHi")
    i32.const 0  ;; pass offset 0 to log
    i32.const 2  ;; pass length 2 to log
    call $log
  )
)

(module
  (import "console" "log" (func $log (param i32 i32)))
  (import "js" "mem" (memory 1))
  (data (i32.const 0) "Hi")
  (func (export "writeHi")
    i32.const 0  ;; pass offset 0 to log
    i32.const 2  ;; pass length 2 to log
    call $log))


Update shared0.wat

Update shared0.wat

(module
  (import "js" "memory" (memory 1))
  (import "js" "table" (table 1 anyfunc))
  (elem (i32.const 0) $shared0func)
  (func $shared0func (result i32)
    i32.const 0
    i32.load
  )
)

(module
  (import "js" "memory" (memory 1))
  (import "js" "table" (table 1 anyfunc))
  (elem (i32.const 0) $shared0func)
  (func $shared0func (result i32)
    i32.const 0
    i32.load))


Update simple.wat

Update simple.wat

;; simple.wat => simple.wasm
;; simple.wast => simple.wasm
;; 使用 s-expr, 手动组装 WebAssembly Module
(module
  (func $getYear (import "imports" "getYear") (param i32))
  (func (export "printYear")
    ;; 写死 const
    i32.const 2022
    call $getYear
  )
)

;; msimple.wat => msimple.wasm
;; msimple.wast => msimple.wasm
;; 使用 s-expr, 手动组装 WebAssembly Module
(module
  (func $getYear (import "imports" "getYear") (param i32))
  (func (export "printYear")
    ;; 写死 const
    i32.const 2022
    call $getYear
  )
)


Rewrite lambda

Rewrite lambda

;; -*- mode: scheme -*-

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

;; Simple control
(define-macro (&& a b) (list if a b false))

(define-macro (|| a b) (list if a true b))

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

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

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

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

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

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

(define-macro (set! (getter . args) new-val)
  (list* (list setter getter) new-val args))

;; Delimited dynamic binding

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

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

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

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

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

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

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

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

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

;; JavaScript

(define-macro (define-js-unop op)
  (list _define op (list vm-js-unop (symbol-name op))))

(define-macro (define-js-binop op)
  (list _define op (list vm-js-binop (symbol-name op))))

(define-js-unop !)
(define-js-unop typeof)
(define-js-unop ~)

(define-js-binop !=)
(define-js-binop !==)
(define-js-binop %)
(define-js-binop &)
(define-js-binop *)
(define-js-binop +)
(define-js-binop -)
(define-js-binop /)
(define-js-binop <)
(define-js-binop <<)
(define-js-binop <=)
(define-js-binop ==)
(define-js-binop ===)
(define-js-binop >)
(define-js-binop >>)
(define-js-binop >>>)
(define-js-binop ^)
(define-js-binop in)
(define-js-binop instanceof)
(define-js-binop |)

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

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

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

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

(define (cat . objects)
  (#join (list-to-array objects) ""))

(define (log . objects)
  (apply #log (list* $console objects)))

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

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

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

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

;; Final events

(define (user-break err)
  (define (print-frame k)
    (log (#toString (.dbg k)) (.e k))
    (if (.next k)
        (print-frame (.next k))
        null))
  (take-subcont vm-root-prompt k
    (print-frame k)
    (push-prompt vm-root-prompt
      (push-subcont k
        (throw err)))))

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

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

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

;; Export bindings to userland

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

(make-environment
  (slurp-environment
   _define _lambda _vau apply eval make-environment the-environment unwrap wrap
   begin define define-macro lambda let let* quote symbol-name symbol?
   caar cadr car cdar cddr cdr cons cons? list list* map-list nil?
   define-generic define-prototype define-method new the type?
   set! setter
   dlet dnew dref
   catch if label loop throw unless when while error
   push-prompt push-subcont take-subcont
   define-module import module
   Arguments Array Date Function Number Object RegExp String
   array array-to-list js-callback js-getter js-global js-invoker list-to-array object
   ! != !== % &  * + - / < << <= == === > >> >>> ~ ^ in instanceof typeof
   @ && ||
   cat log
   ))

;; -*- mode: scheme -*-

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

(_define lambda
  (_vau (params . body) e
    (_define ->type-checks
      (_lambda (typed-params)
        (if (cons? typed-params)
            (let ((param (car typed-params)))
              (if (cons? param)
                  (let (((name type) param))
                    (cons (list the type name) (->type-checks (cdr typed-params))))
                  (->type-checks (cdr typed-params))))
            ())))
    (_define ->untyped-params
      (_lambda (typed-params)
        (if (cons? typed-params)
            (let ((param (car typed-params)))
              (if (cons? param)
                  (let (((name ignore) param))
                    (cons name (->untyped-params (cdr typed-params))))
                  (cons param (->untyped-params (cdr typed-params)))))
            typed-params)))
    (let ((type-checks (->type-checks params))
          (untyped-params (->untyped-params params)))
      (eval (list* _lambda untyped-params (list* begin type-checks) body) e))))

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

;; Simple control
(define-macro (&& a b) (list if a b false))

(define-macro (|| a b) (list if a true b))

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

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

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

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

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

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

(define-macro (set! (getter . args) new-val)
  (list* (list setter getter) new-val args))

;; Delimited dynamic binding

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

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

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

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

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

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

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

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

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

;; JavaScript

(define-macro (define-js-unop op)
  (list _define op (list vm-js-unop (symbol-name op))))

(define-macro (define-js-binop op)
  (list _define op (list vm-js-binop (symbol-name op))))

(define-js-unop !)
(define-js-unop typeof)
(define-js-unop ~)

(define-js-binop !=)
(define-js-binop !==)
(define-js-binop %)
(define-js-binop &)
(define-js-binop *)
(define-js-binop +)
(define-js-binop -)
(define-js-binop /)
(define-js-binop <)
(define-js-binop <<)
(define-js-binop <=)
(define-js-binop ==)
(define-js-binop ===)
(define-js-binop >)
(define-js-binop >>)
(define-js-binop >>>)
(define-js-binop ^)
(define-js-binop in)
(define-js-binop instanceof)
(define-js-binop |)

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

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

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

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

(define (cat . objects)
  (#join (list-to-array objects) ""))

(define (log . objects)
  (apply #log (list* $console objects)))

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

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

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

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

;; Final events

(define (user-break err)
  (define (print-frame k)
    (log (#toString (.dbg k)) (.e k))
    (if (.next k)
        (print-frame (.next k))
        null))
  (take-subcont vm-root-prompt k
    (print-frame k)
    (push-prompt vm-root-prompt
      (push-subcont k
        (throw err)))))

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

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

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

;; Export bindings to userland

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

(make-environment
  (slurp-environment
   _define _lambda _vau apply eval make-environment the-environment unwrap wrap
   begin define define-macro lambda let let* quote symbol-name symbol?
   caar cadr car cdar cddr cdr cons cons? list list* map-list nil?
   define-generic define-prototype define-method new the type?
   set! setter
   dlet dnew dref
   catch if label loop throw unless when while error
   push-prompt push-subcont take-subcont
   define-module import module
   Arguments Array Date Function Number Object RegExp String
   array array-to-list js-callback js-getter js-global js-invoker list-to-array object
   ! != !== % &  * + - / < << <= == === > >> >>> ~ ^ in instanceof typeof
   @ && ||
   cat log
   ))


Update fail.wat

Update fail.wat

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

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