russell@unturf.com
cdb4fc9715
A throttled forever-counter on the asm tier ran for ~5.7 s and
then trapped 'index out of bounds' — the WAT writes output to a
fixed 64 KB region at 0x10000–0x1FFFF, and a fast (display X)
(newline) loop accumulates faster than the buffer can drain. After
about 6,400 ticks at ~10 chars each, overflowed the
region into the source buffer at 0x20000 and the next i32.store8
fell off linear memory.
Fix is a contract change on emit_chunk: its signature picks up an
i32 return — 1 tells the WAT to recycle (zero output_len AND
flush_start), 0 keeps the original 'just advance flush_start'
semantics so callers that read lumbda_output_ptr/len after eval
still see the full buffer.
The asm loader returns 1 from emit_chunk, accumulating every
flushed slice into refs.accumulated. evalLisp's return value is now
refs.accumulated + the trailing (still-unflushed) buffer slice
rather than just the lumbda_output_ptr/len slice — caller still
gets the complete output, the WAT-side buffer just keeps recycling.
Test stubs already declared emit_chunk() {} which returns
undefined — JS->wasm i32 coercion turns that into 0, preserving
the no-recycle behavior they expected. unit/integration suites
(31 tests total) still pass.
Trailing flush in lumbda_eval also honors the return value: if the
host consumed, zero both offsets so the final lumbda_output_ptr/len
read returns 0 bytes (loader already accumulated the trailing
slice — no need to re-deliver). Earlier draft of this patch
double-emitted the trailing slice because we read it through both
the emit_chunk path and the final-buffer path.
4326 lines
194 KiB
Text
4326 lines
194 KiB
Text
;; wasm/asm/lumbda.wat
|
|
;; Lumbda asm tier for the browser — hand-written WebAssembly Text format.
|
|
;;
|
|
;; This is the parallel implementation to asm/lumbda.s (x86_64). Both
|
|
;; target raw stack-machine assembly with no libc; both manage their
|
|
;; own linear memory. The instruction set differs (WASM is a stack
|
|
;; machine, x86_64 is register), the spirit matches.
|
|
;;
|
|
;; SUBSET: arithmetic, lambda, define, if, quote, cond (via cascaded if),
|
|
;; cons/car/cdr/null?/pair?/eq?, display/newline/print, list/length,
|
|
;; closures with lexical scope, tail-recursive enough for fib & ack.
|
|
;; Symbols intern via linear scan (acceptable for the demo programs;
|
|
;; would be MOAD-0001 at scale, documented in the SPA).
|
|
;;
|
|
;; Value encoding (32-bit i32):
|
|
;; bit 0 = 1 → fixnum, value = (v >> 1) sign-extended (31-bit range)
|
|
;; bit 0 = 0 → heap address or reserved immediate
|
|
;; v = 4 → NIL
|
|
;; v = 8 → TRUE (#t)
|
|
;; v = 12 → FALSE (#f)
|
|
;; v = 16 → VOID
|
|
;; v ≥ 32 → heap object, first i32 is type tag
|
|
;;
|
|
;; Heap object tags:
|
|
;; 1 = pair [tag, car, cdr] 12 bytes
|
|
;; 2 = symbol [tag, len, bytes...] 8 + N bytes
|
|
;; 3 = closure [tag, params, body, env] 16 bytes
|
|
;; 4 = primitive [tag, prim_id] 8 bytes
|
|
;; 5 = string [tag, len, bytes...] 8 + N bytes
|
|
;;
|
|
;; Memory map:
|
|
;; 0x00000..0x0001F reserved (immediates + slot 0)
|
|
;; 0x00020..0x000FF globals (heap_ptr, output_len, source pos, intern list, env)
|
|
;; 0x10000..0x1FFFF output buffer (64 KB)
|
|
;; 0x20000..0x2FFFF source input copy (64 KB)
|
|
;; 0x30000..onward heap (bump allocator)
|
|
;;
|
|
;; Built-in symbols (interned at init) live early on the heap.
|
|
|
|
(module
|
|
;; ─── Imports from host JS ──────────────────────────────────────
|
|
;; bend_call(src_ptr, src_len, resp_ptr) -> resp_len.
|
|
;; JS does a synchronous XHR to the configured gpu-worker URL,
|
|
;; writes the response bytes at resp_ptr, returns the byte length.
|
|
;; Worker context only — sync XHR isn't allowed on the main thread.
|
|
(import "env" "bend_call"
|
|
(func $js_bend_call (param i32 i32 i32) (result i32)))
|
|
|
|
;; emit_chunk(ptr, len) → i32 — flush a slice of the output buffer
|
|
;; to JS for streaming. Called from out_char whenever a newline is
|
|
;; emitted (and from lumbda_eval at the very end for any trailing
|
|
;; content without a newline). Loader's host function forwards the
|
|
;; bytes to the current onChunk callback so the worker can
|
|
;; postMessage the chunk to the playground panel as work happens.
|
|
;;
|
|
;; Returns 1 if the host consumed the chunk and the WAT should
|
|
;; recycle the buffer (zero output_len + flush_start so a long
|
|
;; running loop doesn't overflow the 64 KB output region into the
|
|
;; source buffer at 0x20000). Returns 0 (or undefined → coerced
|
|
;; to 0) if the host stub didn't consume — tests + node harnesses
|
|
;; that read lumbda_output_ptr/len after eval keep their full
|
|
;; buffer behavior, the playground loader recycles aggressively.
|
|
(import "env" "emit_chunk"
|
|
(func $js_emit_chunk (param i32 i32) (result i32)))
|
|
|
|
;; ─── Memory & exports ──────────────────────────────────────────
|
|
(memory (export "memory") 32 4096) ;; 32 pages = 2 MB initial, grow to 256 MB
|
|
|
|
(global $heap_ptr (mut i32) (i32.const 0x30000))
|
|
(global $output_len (mut i32) (i32.const 0))
|
|
;; flush_start tracks the offset in the output buffer (relative to
|
|
;; 0x10000) where the next emit_chunk should begin. Updated each
|
|
;; time we flush; reset to 0 at the top of lumbda_eval alongside
|
|
;; output_len. Lets streaming carry just the most-recent line, not
|
|
;; the entire eval-so-far buffer.
|
|
(global $flush_start (mut i32) (i32.const 0))
|
|
(global $source_ptr (mut i32) (i32.const 0x20000))
|
|
(global $source_end (mut i32) (i32.const 0x20000))
|
|
(global $intern_list (mut i32) (i32.const 4)) ;; NIL initially
|
|
(global $global_env (mut i32) (i32.const 4)) ;; NIL initially
|
|
(global $initialized (mut i32) (i32.const 0))
|
|
|
|
;; Scratch space for to_rat: the WAT one-result calling convention is
|
|
;; awkward for "return two values", so to_rat sets these globals and
|
|
;; rat_*_ops read them. Single-threaded execution makes this safe.
|
|
(global $rat_tmp_n (mut i32) (i32.const 0))
|
|
(global $rat_tmp_d (mut i32) (i32.const 1))
|
|
|
|
;; Garbage collector scratch. $gc_forward_ptr is the next free slot in
|
|
;; to-space; $gc_active flips between 0 and 1 to track which half of
|
|
;; memory currently hosts the live heap.
|
|
(global $gc_forward_ptr (mut i32) (i32.const 0))
|
|
(global $gc_delta (mut i32) (i32.const 0))
|
|
|
|
;; Pre-allocated symbol pointers for special forms — filled at init.
|
|
(global $sym_quote (mut i32) (i32.const 0))
|
|
(global $sym_if (mut i32) (i32.const 0))
|
|
(global $sym_lambda (mut i32) (i32.const 0))
|
|
(global $sym_define (mut i32) (i32.const 0))
|
|
(global $sym_begin (mut i32) (i32.const 0))
|
|
(global $sym_cond (mut i32) (i32.const 0))
|
|
(global $sym_else (mut i32) (i32.const 0))
|
|
(global $sym_let (mut i32) (i32.const 0))
|
|
(global $sym_and (mut i32) (i32.const 0))
|
|
(global $sym_or (mut i32) (i32.const 0))
|
|
(global $sym_set (mut i32) (i32.const 0))
|
|
(global $sym_letstar (mut i32) (i32.const 0))
|
|
(global $sym_letrec (mut i32) (i32.const 0))
|
|
(global $sym_when (mut i32) (i32.const 0))
|
|
(global $sym_unless (mut i32) (i32.const 0))
|
|
(global $sym_case (mut i32) (i32.const 0))
|
|
(global $sym_do (mut i32) (i32.const 0))
|
|
|
|
;; Prelude — Lisp source evaluated after primitive binding to define
|
|
;; higher-order functions on top of the C-level primitives.
|
|
(global $prelude_ptr i32 (i32.const 0x50000))
|
|
(global $prelude_len (mut i32) (i32.const 0))
|
|
|
|
;; Constants (immediate value addresses)
|
|
(global $NIL i32 (i32.const 4))
|
|
(global $TRUE i32 (i32.const 8))
|
|
(global $FALSE i32 (i32.const 12))
|
|
(global $VOID i32 (i32.const 16))
|
|
|
|
;; ─── Garbage collector ─────────────────────────────────────────
|
|
;; Cheney-style copying collector. Runs at end of lumbda_eval (between
|
|
;; top-level forms) when the heap exceeds 60% of available memory.
|
|
;;
|
|
;; Roots: $global_env, $intern_list, plus every special-form symbol
|
|
;; ($sym_*) — those are also reachable via intern_list but forwarding
|
|
;; them explicitly avoids a missed update if intern_list collection
|
|
;; somehow drops one.
|
|
;;
|
|
;; Forwarding marker: an already-copied object has its tag overwritten
|
|
;; with 0xCAFEBABE and the new (to-space) address stored at offset 4.
|
|
|
|
;; Round up a length to the nearest multiple of 4.
|
|
(func $round4 (param $n i32) (result i32)
|
|
(i32.and (i32.add (local.get $n) (i32.const 3)) (i32.const 0xFFFFFFFC)))
|
|
|
|
;; Size of the heap object at $ptr in bytes (including the tag word).
|
|
(func $object_size (param $ptr i32) (result i32)
|
|
(local $tag i32)
|
|
(local $n i32)
|
|
(local.set $tag (i32.load (local.get $ptr)))
|
|
(if (i32.eq (local.get $tag) (i32.const 1)) (then (return (i32.const 12)))) ;; pair
|
|
(if (i32.eq (local.get $tag) (i32.const 2)) (then
|
|
(return (i32.add (i32.const 8) (call $round4 (i32.load offset=4 (local.get $ptr))))))) ;; symbol
|
|
(if (i32.eq (local.get $tag) (i32.const 3)) (then (return (i32.const 16)))) ;; closure
|
|
(if (i32.eq (local.get $tag) (i32.const 4)) (then (return (i32.const 8)))) ;; primitive
|
|
(if (i32.eq (local.get $tag) (i32.const 5)) (then
|
|
(return (i32.add (i32.const 8) (call $round4 (i32.load offset=4 (local.get $ptr))))))) ;; string
|
|
(if (i32.eq (local.get $tag) (i32.const 6)) (then (return (i32.const 8)))) ;; char
|
|
(if (i32.eq (local.get $tag) (i32.const 7)) (then
|
|
(return (i32.add (i32.const 8) (i32.mul (i32.load offset=4 (local.get $ptr)) (i32.const 4)))))) ;; vector
|
|
(if (i32.eq (local.get $tag) (i32.const 8)) (then (return (i32.const 12)))) ;; hashtable
|
|
(if (i32.eq (local.get $tag) (i32.const 9)) (then (return (i32.const 12)))) ;; rational
|
|
(if (i32.eq (local.get $tag) (i32.const 10)) (then
|
|
(return (i32.add (i32.const 12) (i32.mul (i32.load offset=8 (local.get $ptr)) (i32.const 4)))))) ;; bignum
|
|
;; Forwarded sentinel — caller shouldn't ever ask the size of one,
|
|
;; but if it does we return 8 (tag + forward pointer).
|
|
(i32.const 8))
|
|
|
|
;; Copy a heap object into to-space and leave a forwarding pointer at
|
|
;; the old location. Returns the new (to-space) address. Pass-through
|
|
;; for fixnums, immediates, and NIL/TRUE/FALSE/VOID.
|
|
(func $gc_forward (param $v i32) (result i32)
|
|
(local $tag i32)
|
|
(local $size i32)
|
|
(local $new i32)
|
|
(local $i i32)
|
|
(if (call $is_fixnum (local.get $v)) (then (return (local.get $v))))
|
|
(if (i32.lt_u (local.get $v) (i32.const 32)) (then (return (local.get $v))))
|
|
(local.set $tag (i32.load (local.get $v)))
|
|
;; Already forwarded?
|
|
(if (i32.eq (local.get $tag) (i32.const 0xCAFEBABE))
|
|
(then (return (i32.load offset=4 (local.get $v)))))
|
|
(local.set $size (call $object_size (local.get $v)))
|
|
(local.set $new (global.get $gc_forward_ptr))
|
|
(global.set $gc_forward_ptr (i32.add (local.get $new) (local.get $size)))
|
|
(local.set $i (i32.const 0))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.ge_u (local.get $i) (local.get $size)))
|
|
(i32.store (i32.add (local.get $new) (local.get $i))
|
|
(i32.load (i32.add (local.get $v) (local.get $i))))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 4)))
|
|
(br $l)))
|
|
;; Leave forwarding tombstone.
|
|
(i32.store (local.get $v) (i32.const 0xCAFEBABE))
|
|
(i32.store offset=4 (local.get $v) (local.get $new))
|
|
(local.get $new))
|
|
|
|
;; Walk the pointer fields of an object at $ptr, replacing each with
|
|
;; the forwarded version. Returns ptr + object_size for the loop.
|
|
(func $gc_scan_object (param $ptr i32) (result i32)
|
|
(local $tag i32)
|
|
(local $n i32)
|
|
(local $i i32)
|
|
(local.set $tag (i32.load (local.get $ptr)))
|
|
;; pair
|
|
(if (i32.eq (local.get $tag) (i32.const 1))
|
|
(then
|
|
(i32.store offset=4 (local.get $ptr) (call $gc_forward (i32.load offset=4 (local.get $ptr))))
|
|
(i32.store offset=8 (local.get $ptr) (call $gc_forward (i32.load offset=8 (local.get $ptr))))))
|
|
;; closure: params, body, env
|
|
(if (i32.eq (local.get $tag) (i32.const 3))
|
|
(then
|
|
(i32.store offset=4 (local.get $ptr) (call $gc_forward (i32.load offset=4 (local.get $ptr))))
|
|
(i32.store offset=8 (local.get $ptr) (call $gc_forward (i32.load offset=8 (local.get $ptr))))
|
|
(i32.store offset=12 (local.get $ptr) (call $gc_forward (i32.load offset=12 (local.get $ptr))))))
|
|
;; vector
|
|
(if (i32.eq (local.get $tag) (i32.const 7))
|
|
(then
|
|
(local.set $n (i32.load offset=4 (local.get $ptr)))
|
|
(local.set $i (i32.const 0))
|
|
(block $vdone
|
|
(loop $vl
|
|
(br_if $vdone (i32.ge_u (local.get $i) (local.get $n)))
|
|
(i32.store
|
|
(i32.add (i32.add (local.get $ptr) (i32.const 8)) (i32.mul (local.get $i) (i32.const 4)))
|
|
(call $gc_forward
|
|
(i32.load
|
|
(i32.add (i32.add (local.get $ptr) (i32.const 8))
|
|
(i32.mul (local.get $i) (i32.const 4))))))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $vl)))))
|
|
;; hashtable: alist
|
|
(if (i32.eq (local.get $tag) (i32.const 8))
|
|
(then
|
|
(i32.store offset=8 (local.get $ptr) (call $gc_forward (i32.load offset=8 (local.get $ptr))))))
|
|
(i32.add (local.get $ptr) (call $object_size (local.get $ptr))))
|
|
|
|
;; Run a full collection. After this, $heap_ptr reflects the live size
|
|
;; only; everything previously allocated but unreachable is reclaimed.
|
|
(func $gc_collect
|
|
(local $to_space i32)
|
|
(local $heap_start i32)
|
|
(local $size i32)
|
|
(local $scan i32)
|
|
(local $i i32)
|
|
(local $needed i32)
|
|
(local $cur_pages i32)
|
|
(local $new_pages i32)
|
|
(local.set $heap_start (i32.const 0x30000))
|
|
;; Pick to-space at the current heap end so it doesn't overlap.
|
|
(local.set $to_space (global.get $heap_ptr))
|
|
;; Make sure to-space has room. Worst case = current live size,
|
|
;; bound below by 1MB so we always have slack. memory.grow is
|
|
;; idempotent up to 4096 pages so this never overshoots.
|
|
(local.set $needed
|
|
(i32.add (local.get $to_space)
|
|
(i32.sub (global.get $heap_ptr) (local.get $heap_start))))
|
|
(local.set $cur_pages (memory.size))
|
|
(if (i32.gt_u (local.get $needed) (i32.mul (local.get $cur_pages) (i32.const 65536)))
|
|
(then
|
|
(local.set $new_pages
|
|
(i32.div_u (i32.add (local.get $needed) (i32.const 65535)) (i32.const 65536)))
|
|
(drop (memory.grow (i32.sub (local.get $new_pages) (local.get $cur_pages))))))
|
|
(global.set $gc_forward_ptr (local.get $to_space))
|
|
;; Forward roots.
|
|
(global.set $global_env (call $gc_forward (global.get $global_env)))
|
|
(global.set $intern_list (call $gc_forward (global.get $intern_list)))
|
|
(global.set $sym_quote (call $gc_forward (global.get $sym_quote)))
|
|
(global.set $sym_if (call $gc_forward (global.get $sym_if)))
|
|
(global.set $sym_lambda (call $gc_forward (global.get $sym_lambda)))
|
|
(global.set $sym_define (call $gc_forward (global.get $sym_define)))
|
|
(global.set $sym_begin (call $gc_forward (global.get $sym_begin)))
|
|
(global.set $sym_cond (call $gc_forward (global.get $sym_cond)))
|
|
(global.set $sym_else (call $gc_forward (global.get $sym_else)))
|
|
(global.set $sym_let (call $gc_forward (global.get $sym_let)))
|
|
(global.set $sym_and (call $gc_forward (global.get $sym_and)))
|
|
(global.set $sym_or (call $gc_forward (global.get $sym_or)))
|
|
(global.set $sym_set (call $gc_forward (global.get $sym_set)))
|
|
(global.set $sym_letstar (call $gc_forward (global.get $sym_letstar)))
|
|
(global.set $sym_letrec (call $gc_forward (global.get $sym_letrec)))
|
|
(global.set $sym_when (call $gc_forward (global.get $sym_when)))
|
|
(global.set $sym_unless (call $gc_forward (global.get $sym_unless)))
|
|
(global.set $sym_case (call $gc_forward (global.get $sym_case)))
|
|
(global.set $sym_do (call $gc_forward (global.get $sym_do)))
|
|
;; Scan to-space, forwarding inner pointer fields.
|
|
(local.set $scan (local.get $to_space))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.ge_u (local.get $scan) (global.get $gc_forward_ptr)))
|
|
(local.set $scan (call $gc_scan_object (local.get $scan)))
|
|
(br $l)))
|
|
;; Compact: memmove to-space back to 0x30000 and shift every pointer
|
|
;; field by the same delta. The shift is done in a second scan over
|
|
;; the relocated objects.
|
|
(local.set $size (i32.sub (global.get $gc_forward_ptr) (local.get $to_space)))
|
|
(global.set $gc_delta (i32.sub (local.get $to_space) (local.get $heap_start)))
|
|
(local.set $i (i32.const 0))
|
|
(block $cpdone
|
|
(loop $cpl
|
|
(br_if $cpdone (i32.ge_u (local.get $i) (local.get $size)))
|
|
(i32.store (i32.add (local.get $heap_start) (local.get $i))
|
|
(i32.load (i32.add (local.get $to_space) (local.get $i))))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 4)))
|
|
(br $cpl)))
|
|
;; Shift roots.
|
|
(global.set $global_env (call $gc_shift (global.get $global_env)))
|
|
(global.set $intern_list (call $gc_shift (global.get $intern_list)))
|
|
(global.set $sym_quote (call $gc_shift (global.get $sym_quote)))
|
|
(global.set $sym_if (call $gc_shift (global.get $sym_if)))
|
|
(global.set $sym_lambda (call $gc_shift (global.get $sym_lambda)))
|
|
(global.set $sym_define (call $gc_shift (global.get $sym_define)))
|
|
(global.set $sym_begin (call $gc_shift (global.get $sym_begin)))
|
|
(global.set $sym_cond (call $gc_shift (global.get $sym_cond)))
|
|
(global.set $sym_else (call $gc_shift (global.get $sym_else)))
|
|
(global.set $sym_let (call $gc_shift (global.get $sym_let)))
|
|
(global.set $sym_and (call $gc_shift (global.get $sym_and)))
|
|
(global.set $sym_or (call $gc_shift (global.get $sym_or)))
|
|
(global.set $sym_set (call $gc_shift (global.get $sym_set)))
|
|
(global.set $sym_letstar (call $gc_shift (global.get $sym_letstar)))
|
|
(global.set $sym_letrec (call $gc_shift (global.get $sym_letrec)))
|
|
(global.set $sym_when (call $gc_shift (global.get $sym_when)))
|
|
(global.set $sym_unless (call $gc_shift (global.get $sym_unless)))
|
|
(global.set $sym_case (call $gc_shift (global.get $sym_case)))
|
|
(global.set $sym_do (call $gc_shift (global.get $sym_do)))
|
|
;; Shift internal pointers in the compacted region.
|
|
(local.set $scan (local.get $heap_start))
|
|
(block $sdone
|
|
(loop $sl
|
|
(br_if $sdone (i32.ge_u (local.get $scan) (i32.add (local.get $heap_start) (local.get $size))))
|
|
(local.set $scan (call $gc_shift_object (local.get $scan)))
|
|
(br $sl)))
|
|
(global.set $heap_ptr (i32.add (local.get $heap_start) (local.get $size))))
|
|
|
|
;; Shift a single Value by $gc_delta (pass-through for non-pointers).
|
|
(func $gc_shift (param $v i32) (result i32)
|
|
(if (call $is_fixnum (local.get $v)) (then (return (local.get $v))))
|
|
(if (i32.lt_u (local.get $v) (i32.const 32)) (then (return (local.get $v))))
|
|
(i32.sub (local.get $v) (global.get $gc_delta)))
|
|
|
|
;; Like $gc_scan_object but applies the gc_shift correction instead.
|
|
(func $gc_shift_object (param $ptr i32) (result i32)
|
|
(local $tag i32)
|
|
(local $n i32)
|
|
(local $i i32)
|
|
(local.set $tag (i32.load (local.get $ptr)))
|
|
(if (i32.eq (local.get $tag) (i32.const 1))
|
|
(then
|
|
(i32.store offset=4 (local.get $ptr) (call $gc_shift (i32.load offset=4 (local.get $ptr))))
|
|
(i32.store offset=8 (local.get $ptr) (call $gc_shift (i32.load offset=8 (local.get $ptr))))))
|
|
(if (i32.eq (local.get $tag) (i32.const 3))
|
|
(then
|
|
(i32.store offset=4 (local.get $ptr) (call $gc_shift (i32.load offset=4 (local.get $ptr))))
|
|
(i32.store offset=8 (local.get $ptr) (call $gc_shift (i32.load offset=8 (local.get $ptr))))
|
|
(i32.store offset=12 (local.get $ptr) (call $gc_shift (i32.load offset=12 (local.get $ptr))))))
|
|
(if (i32.eq (local.get $tag) (i32.const 7))
|
|
(then
|
|
(local.set $n (i32.load offset=4 (local.get $ptr)))
|
|
(local.set $i (i32.const 0))
|
|
(block $vdone
|
|
(loop $vl
|
|
(br_if $vdone (i32.ge_u (local.get $i) (local.get $n)))
|
|
(i32.store
|
|
(i32.add (i32.add (local.get $ptr) (i32.const 8)) (i32.mul (local.get $i) (i32.const 4)))
|
|
(call $gc_shift
|
|
(i32.load
|
|
(i32.add (i32.add (local.get $ptr) (i32.const 8))
|
|
(i32.mul (local.get $i) (i32.const 4))))))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $vl)))))
|
|
(if (i32.eq (local.get $tag) (i32.const 8))
|
|
(then
|
|
(i32.store offset=8 (local.get $ptr) (call $gc_shift (i32.load offset=8 (local.get $ptr))))))
|
|
(i32.add (local.get $ptr) (call $object_size (local.get $ptr))))
|
|
|
|
;; ─── Allocator ─────────────────────────────────────────────────
|
|
;; Bump-only. Grows linear memory by 16 pages (1 MB) at a time when
|
|
;; heap_ptr nears the limit. No free, no GC — fine for browser demos
|
|
;; where the tab tears down at unload. Matches the asm/lumbda.s
|
|
;; discipline (heap never shrinks) — see CLAUDE.md.
|
|
(func $alloc (param $n i32) (result i32)
|
|
(local $p i32)
|
|
(local $end i32)
|
|
(local $limit i32)
|
|
(local.set $p (global.get $heap_ptr))
|
|
(local.set $end (i32.add (local.get $p) (local.get $n)))
|
|
(local.set $limit (i32.mul (memory.size) (i32.const 65536)))
|
|
(if (i32.ge_u (local.get $end) (local.get $limit))
|
|
(then
|
|
(drop (memory.grow (i32.const 16)))))
|
|
(global.set $heap_ptr
|
|
(i32.and
|
|
(i32.add (local.get $end) (i32.const 3))
|
|
(i32.const 0xFFFFFFFC)))
|
|
(local.get $p))
|
|
|
|
;; ─── Tag predicates ────────────────────────────────────────────
|
|
(func $is_fixnum (param $v i32) (result i32)
|
|
(i32.and (local.get $v) (i32.const 1)))
|
|
|
|
(func $is_immediate (param $v i32) (result i32)
|
|
;; immediate iff 4 ≤ v ≤ 16 and low bit 0
|
|
(i32.and
|
|
(i32.eqz (i32.and (local.get $v) (i32.const 1)))
|
|
(i32.and
|
|
(i32.le_u (i32.const 4) (local.get $v))
|
|
(i32.le_u (local.get $v) (i32.const 16)))))
|
|
|
|
(func $obj_tag (param $v i32) (result i32)
|
|
;; assumes v is a heap address ≥ 32
|
|
(i32.load (local.get $v)))
|
|
|
|
(func $is_pair (param $v i32) (result i32)
|
|
(if (result i32) (call $is_fixnum (local.get $v))
|
|
(then (i32.const 0))
|
|
(else
|
|
(if (result i32) (call $is_immediate (local.get $v))
|
|
(then (i32.const 0))
|
|
(else (i32.eq (call $obj_tag (local.get $v)) (i32.const 1)))))))
|
|
|
|
(func $is_symbol (param $v i32) (result i32)
|
|
(if (result i32) (call $is_fixnum (local.get $v))
|
|
(then (i32.const 0))
|
|
(else
|
|
(if (result i32) (call $is_immediate (local.get $v))
|
|
(then (i32.const 0))
|
|
(else (i32.eq (call $obj_tag (local.get $v)) (i32.const 2)))))))
|
|
|
|
(func $is_closure (param $v i32) (result i32)
|
|
(if (result i32) (call $is_fixnum (local.get $v))
|
|
(then (i32.const 0))
|
|
(else
|
|
(if (result i32) (call $is_immediate (local.get $v))
|
|
(then (i32.const 0))
|
|
(else (i32.eq (call $obj_tag (local.get $v)) (i32.const 3)))))))
|
|
|
|
(func $is_primitive (param $v i32) (result i32)
|
|
(if (result i32) (call $is_fixnum (local.get $v))
|
|
(then (i32.const 0))
|
|
(else
|
|
(if (result i32) (call $is_immediate (local.get $v))
|
|
(then (i32.const 0))
|
|
(else (i32.eq (call $obj_tag (local.get $v)) (i32.const 4)))))))
|
|
|
|
(func $is_string (param $v i32) (result i32)
|
|
(if (result i32) (call $is_fixnum (local.get $v))
|
|
(then (i32.const 0))
|
|
(else
|
|
(if (result i32) (call $is_immediate (local.get $v))
|
|
(then (i32.const 0))
|
|
(else (i32.eq (call $obj_tag (local.get $v)) (i32.const 5)))))))
|
|
|
|
(func $is_char (param $v i32) (result i32)
|
|
(if (result i32) (call $is_fixnum (local.get $v))
|
|
(then (i32.const 0))
|
|
(else
|
|
(if (result i32) (call $is_immediate (local.get $v))
|
|
(then (i32.const 0))
|
|
(else (i32.eq (call $obj_tag (local.get $v)) (i32.const 6)))))))
|
|
|
|
(func $make_char (param $code i32) (result i32)
|
|
(local $p i32)
|
|
(local.set $p (call $alloc (i32.const 8)))
|
|
(i32.store (local.get $p) (i32.const 6))
|
|
(i32.store offset=4 (local.get $p) (local.get $code))
|
|
(local.get $p))
|
|
|
|
;; ─── Rationals (tag=9) ─────────────────────────────────────────
|
|
;; Layout: [tag=9, num: i32, den: i32]. num/den are 31-bit signed.
|
|
;; Real bignums would lift the overflow ceiling — TODO when the WAT
|
|
;; tier grows arbitrary-precision integers.
|
|
(func $is_rational (param $v i32) (result i32)
|
|
(if (result i32) (call $is_fixnum (local.get $v))
|
|
(then (i32.const 0))
|
|
(else
|
|
(if (result i32) (call $is_immediate (local.get $v))
|
|
(then (i32.const 0))
|
|
(else (i32.eq (call $obj_tag (local.get $v)) (i32.const 9)))))))
|
|
|
|
(func $is_number (param $v i32) (result i32)
|
|
(if (result i32) (call $is_fixnum (local.get $v))
|
|
(then (i32.const 1))
|
|
(else
|
|
(if (result i32) (call $is_rational (local.get $v))
|
|
(then (i32.const 1))
|
|
(else (call $is_bignum (local.get $v)))))))
|
|
|
|
(func $is_integer (param $v i32) (result i32)
|
|
(if (result i32) (call $is_fixnum (local.get $v))
|
|
(then (i32.const 1))
|
|
(else (call $is_bignum (local.get $v)))))
|
|
|
|
;; ─── Bignums (tag=10) ──────────────────────────────────────────
|
|
;; Variable-length signed integers. Layout:
|
|
;; [tag=10, sign:i32, n_limbs:i32, limb_0:i32, limb_1:i32, ...]
|
|
;; sign = 0 for positive, 1 for negative; n_limbs is the number of u32
|
|
;; limbs that follow; the array is little-endian (limb_0 = least
|
|
;; significant). A bignum with n_limbs=0 represents 0 (positive).
|
|
;;
|
|
;; The total size is 12 + 4*n_limbs bytes.
|
|
(func $is_bignum (param $v i32) (result i32)
|
|
(if (result i32) (call $is_fixnum (local.get $v))
|
|
(then (i32.const 0))
|
|
(else
|
|
(if (result i32) (call $is_immediate (local.get $v))
|
|
(then (i32.const 0))
|
|
(else (i32.eq (call $obj_tag (local.get $v)) (i32.const 10)))))))
|
|
|
|
(func $bn_sign (param $v i32) (result i32)
|
|
(i32.load offset=4 (local.get $v)))
|
|
|
|
(func $bn_n (param $v i32) (result i32)
|
|
(i32.load offset=8 (local.get $v)))
|
|
|
|
(func $bn_limb (param $v i32) (param $i i32) (result i32)
|
|
(i32.load (i32.add (i32.add (local.get $v) (i32.const 12))
|
|
(i32.mul (local.get $i) (i32.const 4)))))
|
|
|
|
(func $bn_set_limb (param $v i32) (param $i i32) (param $w i32)
|
|
(i32.store (i32.add (i32.add (local.get $v) (i32.const 12))
|
|
(i32.mul (local.get $i) (i32.const 4)))
|
|
(local.get $w)))
|
|
|
|
(func $bn_set_sign (param $v i32) (param $s i32)
|
|
(i32.store offset=4 (local.get $v) (local.get $s)))
|
|
|
|
(func $bn_set_n (param $v i32) (param $n i32)
|
|
(i32.store offset=8 (local.get $v) (local.get $n)))
|
|
|
|
(func $make_bignum_raw (param $n_limbs i32) (result i32)
|
|
(local $p i32)
|
|
(local.set $p (call $alloc
|
|
(i32.add (i32.const 12) (i32.mul (local.get $n_limbs) (i32.const 4)))))
|
|
(i32.store (local.get $p) (i32.const 10))
|
|
(i32.store offset=4 (local.get $p) (i32.const 0))
|
|
(i32.store offset=8 (local.get $p) (local.get $n_limbs))
|
|
(local.get $p))
|
|
|
|
;; Trim trailing zero limbs, fix sign for zero, and collapse to a
|
|
;; fixnum when the value fits in 31 bits (low bit set encoding).
|
|
(func $bn_normalize (param $v i32) (result i32)
|
|
(local $n i32)
|
|
(local $val i32)
|
|
(local.set $n (call $bn_n (local.get $v)))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.eqz (local.get $n)))
|
|
(br_if $done (i32.ne (call $bn_limb (local.get $v) (i32.sub (local.get $n) (i32.const 1)))
|
|
(i32.const 0)))
|
|
(local.set $n (i32.sub (local.get $n) (i32.const 1)))
|
|
(br $l)))
|
|
(call $bn_set_n (local.get $v) (local.get $n))
|
|
(if (i32.eqz (local.get $n))
|
|
(then
|
|
(call $bn_set_sign (local.get $v) (i32.const 0))
|
|
(return (call $make_fixnum (i32.const 0)))))
|
|
;; Single-limb that fits in 30 bits collapses to a fixnum.
|
|
(if (i32.eq (local.get $n) (i32.const 1))
|
|
(then
|
|
(local.set $val (call $bn_limb (local.get $v) (i32.const 0)))
|
|
(if (i32.lt_u (local.get $val) (i32.const 0x40000000))
|
|
(then
|
|
(if (call $bn_sign (local.get $v))
|
|
(then (local.set $val (i32.sub (i32.const 0) (local.get $val)))))
|
|
(return (call $make_fixnum (local.get $val)))))))
|
|
(local.get $v))
|
|
|
|
;; Convert a fixnum to a fresh bignum (no normalize collapse).
|
|
(func $bn_from_fixnum (param $n i32) (result i32)
|
|
(local $bn i32)
|
|
(local $abs i32)
|
|
(if (i32.eqz (local.get $n))
|
|
(then (return (call $make_bignum_raw (i32.const 0)))))
|
|
(local.set $abs (local.get $n))
|
|
(local.set $bn (call $make_bignum_raw (i32.const 1)))
|
|
(if (i32.lt_s (local.get $n) (i32.const 0))
|
|
(then
|
|
(call $bn_set_sign (local.get $bn) (i32.const 1))
|
|
(local.set $abs (i32.sub (i32.const 0) (local.get $n)))))
|
|
(call $bn_set_limb (local.get $bn) (i32.const 0) (local.get $abs))
|
|
(local.get $bn))
|
|
|
|
;; Coerce a Value to a bignum (no normalize). Caller guarantees v is
|
|
;; either a fixnum or a bignum.
|
|
(func $to_bignum (param $v i32) (result i32)
|
|
(if (call $is_bignum (local.get $v))
|
|
(then (return (local.get $v))))
|
|
(call $bn_from_fixnum (call $fixnum_val (local.get $v))))
|
|
|
|
;; Compare magnitudes (signs ignored). Returns -1 / 0 / 1.
|
|
(func $bn_cmp_abs (param $a i32) (param $b i32) (result i32)
|
|
(local $na i32)
|
|
(local $nb i32)
|
|
(local $i i32)
|
|
(local $la i32)
|
|
(local $lb i32)
|
|
(local.set $na (call $bn_n (local.get $a)))
|
|
(local.set $nb (call $bn_n (local.get $b)))
|
|
(if (i32.gt_s (local.get $na) (local.get $nb)) (then (return (i32.const 1))))
|
|
(if (i32.lt_s (local.get $na) (local.get $nb)) (then (return (i32.const -1))))
|
|
(local.set $i (local.get $na))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.eqz (local.get $i)))
|
|
(local.set $i (i32.sub (local.get $i) (i32.const 1)))
|
|
(local.set $la (call $bn_limb (local.get $a) (local.get $i)))
|
|
(local.set $lb (call $bn_limb (local.get $b) (local.get $i)))
|
|
(if (i32.gt_u (local.get $la) (local.get $lb)) (then (return (i32.const 1))))
|
|
(if (i32.lt_u (local.get $la) (local.get $lb)) (then (return (i32.const -1))))
|
|
(br $l)))
|
|
(i32.const 0))
|
|
|
|
;; Unsigned addition: |a| + |b|. Returns a fresh bignum (sign=0).
|
|
(func $bn_add_abs (param $a i32) (param $b i32) (result i32)
|
|
(local $na i32)
|
|
(local $nb i32)
|
|
(local $n i32)
|
|
(local $r i32)
|
|
(local $i i32)
|
|
(local $carry i64)
|
|
(local $sum i64)
|
|
(local $la i32)
|
|
(local $lb i32)
|
|
(local.set $na (call $bn_n (local.get $a)))
|
|
(local.set $nb (call $bn_n (local.get $b)))
|
|
(local.set $n (local.get $na))
|
|
(if (i32.gt_s (local.get $nb) (local.get $n))
|
|
(then (local.set $n (local.get $nb))))
|
|
(local.set $r (call $make_bignum_raw (i32.add (local.get $n) (i32.const 1))))
|
|
(local.set $carry (i64.const 0))
|
|
(local.set $i (i32.const 0))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.ge_s (local.get $i) (local.get $n)))
|
|
(local.set $la (i32.const 0))
|
|
(if (i32.lt_s (local.get $i) (local.get $na))
|
|
(then (local.set $la (call $bn_limb (local.get $a) (local.get $i)))))
|
|
(local.set $lb (i32.const 0))
|
|
(if (i32.lt_s (local.get $i) (local.get $nb))
|
|
(then (local.set $lb (call $bn_limb (local.get $b) (local.get $i)))))
|
|
(local.set $sum
|
|
(i64.add
|
|
(i64.add (i64.extend_i32_u (local.get $la))
|
|
(i64.extend_i32_u (local.get $lb)))
|
|
(local.get $carry)))
|
|
(call $bn_set_limb (local.get $r) (local.get $i)
|
|
(i32.wrap_i64 (local.get $sum)))
|
|
(local.set $carry (i64.shr_u (local.get $sum) (i64.const 32)))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $l)))
|
|
(call $bn_set_limb (local.get $r) (local.get $n) (i32.wrap_i64 (local.get $carry)))
|
|
(local.get $r))
|
|
|
|
;; Unsigned subtraction assuming |a| >= |b|. Returns a fresh bignum
|
|
;; with sign=0.
|
|
(func $bn_sub_abs (param $a i32) (param $b i32) (result i32)
|
|
(local $na i32)
|
|
(local $nb i32)
|
|
(local $r i32)
|
|
(local $i i32)
|
|
(local $borrow i64)
|
|
(local $diff i64)
|
|
(local $la i32)
|
|
(local $lb i32)
|
|
(local.set $na (call $bn_n (local.get $a)))
|
|
(local.set $nb (call $bn_n (local.get $b)))
|
|
(local.set $r (call $make_bignum_raw (local.get $na)))
|
|
(local.set $borrow (i64.const 0))
|
|
(local.set $i (i32.const 0))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.ge_s (local.get $i) (local.get $na)))
|
|
(local.set $la (call $bn_limb (local.get $a) (local.get $i)))
|
|
(local.set $lb (i32.const 0))
|
|
(if (i32.lt_s (local.get $i) (local.get $nb))
|
|
(then (local.set $lb (call $bn_limb (local.get $b) (local.get $i)))))
|
|
(local.set $diff
|
|
(i64.sub
|
|
(i64.sub (i64.extend_i32_u (local.get $la))
|
|
(i64.extend_i32_u (local.get $lb)))
|
|
(local.get $borrow)))
|
|
(call $bn_set_limb (local.get $r) (local.get $i)
|
|
(i32.wrap_i64 (local.get $diff)))
|
|
;; Borrow if the high 32 bits of diff are nonzero (sign-extended -1).
|
|
(if (i64.lt_s (local.get $diff) (i64.const 0))
|
|
(then (local.set $borrow (i64.const 1)))
|
|
(else (local.set $borrow (i64.const 0))))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $l)))
|
|
(local.get $r))
|
|
|
|
;; Signed addition: a + b, returns a normalized Value (fixnum or bignum).
|
|
(func $bn_add (param $a i32) (param $b i32) (result i32)
|
|
(local $r i32)
|
|
(local $cmp i32)
|
|
(if (i32.eq (call $bn_sign (local.get $a)) (call $bn_sign (local.get $b)))
|
|
(then
|
|
(local.set $r (call $bn_add_abs (local.get $a) (local.get $b)))
|
|
(call $bn_set_sign (local.get $r) (call $bn_sign (local.get $a)))
|
|
(return (call $bn_normalize (local.get $r)))))
|
|
;; Signs differ — subtract the smaller magnitude from the larger.
|
|
(local.set $cmp (call $bn_cmp_abs (local.get $a) (local.get $b)))
|
|
(if (i32.eqz (local.get $cmp))
|
|
(then (return (call $make_fixnum (i32.const 0)))))
|
|
(if (i32.gt_s (local.get $cmp) (i32.const 0))
|
|
(then
|
|
(local.set $r (call $bn_sub_abs (local.get $a) (local.get $b)))
|
|
(call $bn_set_sign (local.get $r) (call $bn_sign (local.get $a))))
|
|
(else
|
|
(local.set $r (call $bn_sub_abs (local.get $b) (local.get $a)))
|
|
(call $bn_set_sign (local.get $r) (call $bn_sign (local.get $b)))))
|
|
(call $bn_normalize (local.get $r)))
|
|
|
|
;; a - b = a + (-b)
|
|
(func $bn_sub (param $a i32) (param $b i32) (result i32)
|
|
(local $nb i32)
|
|
(local $r i32)
|
|
(local $i i32)
|
|
(local $n i32)
|
|
;; clone b with flipped sign — cheaper than reallocating: we just
|
|
;; copy the limbs and toggle sign.
|
|
(local.set $n (call $bn_n (local.get $b)))
|
|
(local.set $nb (call $make_bignum_raw (local.get $n)))
|
|
(call $bn_set_sign (local.get $nb) (i32.xor (call $bn_sign (local.get $b)) (i32.const 1)))
|
|
(local.set $i (i32.const 0))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.ge_s (local.get $i) (local.get $n)))
|
|
(call $bn_set_limb (local.get $nb) (local.get $i)
|
|
(call $bn_limb (local.get $b) (local.get $i)))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $l)))
|
|
(call $bn_add (local.get $a) (local.get $nb)))
|
|
|
|
;; Schoolbook multiplication. Result n_limbs = na + nb.
|
|
(func $bn_mul (param $a i32) (param $b i32) (result i32)
|
|
(local $na i32)
|
|
(local $nb i32)
|
|
(local $r i32)
|
|
(local $i i32)
|
|
(local $j i32)
|
|
(local $carry i64)
|
|
(local $prod i64)
|
|
(local $la i32)
|
|
(local $lb i32)
|
|
(local $cur i32)
|
|
(local.set $na (call $bn_n (local.get $a)))
|
|
(local.set $nb (call $bn_n (local.get $b)))
|
|
(if (i32.or (i32.eqz (local.get $na)) (i32.eqz (local.get $nb)))
|
|
(then (return (call $make_fixnum (i32.const 0)))))
|
|
(local.set $r (call $make_bignum_raw (i32.add (local.get $na) (local.get $nb))))
|
|
;; All limbs start at zero (alloc zero-fills).
|
|
(local.set $i (i32.const 0))
|
|
(block $outerdone
|
|
(loop $outer
|
|
(br_if $outerdone (i32.ge_s (local.get $i) (local.get $na)))
|
|
(local.set $la (call $bn_limb (local.get $a) (local.get $i)))
|
|
(local.set $carry (i64.const 0))
|
|
(local.set $j (i32.const 0))
|
|
(block $innerdone
|
|
(loop $inner
|
|
(br_if $innerdone (i32.ge_s (local.get $j) (local.get $nb)))
|
|
(local.set $lb (call $bn_limb (local.get $b) (local.get $j)))
|
|
(local.set $cur (call $bn_limb (local.get $r) (i32.add (local.get $i) (local.get $j))))
|
|
(local.set $prod
|
|
(i64.add
|
|
(i64.add
|
|
(i64.mul (i64.extend_i32_u (local.get $la))
|
|
(i64.extend_i32_u (local.get $lb)))
|
|
(i64.extend_i32_u (local.get $cur)))
|
|
(local.get $carry)))
|
|
(call $bn_set_limb (local.get $r) (i32.add (local.get $i) (local.get $j))
|
|
(i32.wrap_i64 (local.get $prod)))
|
|
(local.set $carry (i64.shr_u (local.get $prod) (i64.const 32)))
|
|
(local.set $j (i32.add (local.get $j) (i32.const 1)))
|
|
(br $inner)))
|
|
;; Propagate the final carry into the next slot.
|
|
(call $bn_set_limb (local.get $r)
|
|
(i32.add (local.get $i) (local.get $nb))
|
|
(i32.wrap_i64 (local.get $carry)))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $outer)))
|
|
(call $bn_set_sign (local.get $r) (i32.xor (call $bn_sign (local.get $a)) (call $bn_sign (local.get $b))))
|
|
(call $bn_normalize (local.get $r)))
|
|
|
|
;; Divide |a| by a small u32 d (non-zero). Quotient is written into the
|
|
;; existing bignum `q` (caller alloc'd big enough). Remainder returned.
|
|
(func $bn_divmod_small (param $a i32) (param $d i32) (param $q i32) (result i32)
|
|
(local $n i32)
|
|
(local $i i32)
|
|
(local $rem i64)
|
|
(local $cur i64)
|
|
(local $quo i64)
|
|
(local.set $n (call $bn_n (local.get $a)))
|
|
(local.set $rem (i64.const 0))
|
|
(local.set $i (local.get $n))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.eqz (local.get $i)))
|
|
(local.set $i (i32.sub (local.get $i) (i32.const 1)))
|
|
(local.set $cur
|
|
(i64.or
|
|
(i64.shl (local.get $rem) (i64.const 32))
|
|
(i64.extend_i32_u (call $bn_limb (local.get $a) (local.get $i)))))
|
|
(local.set $quo (i64.div_u (local.get $cur) (i64.extend_i32_u (local.get $d))))
|
|
(local.set $rem (i64.rem_u (local.get $cur) (i64.extend_i32_u (local.get $d))))
|
|
(call $bn_set_limb (local.get $q) (local.get $i)
|
|
(i32.wrap_i64 (local.get $quo)))
|
|
(br $l)))
|
|
(call $bn_set_n (local.get $q) (local.get $n))
|
|
(i32.wrap_i64 (local.get $rem)))
|
|
|
|
;; Print a bignum in base 10 to the output buffer.
|
|
(func $print_bignum (param $v i32)
|
|
(local $work i32)
|
|
(local $n i32)
|
|
(local $i i32)
|
|
(local $rem i32)
|
|
(local $buf i32)
|
|
(local $bi i32)
|
|
(local $j i32)
|
|
;; Zero case.
|
|
(if (i32.eqz (call $bn_n (local.get $v)))
|
|
(then (call $out_char (i32.const 48)) (return))) ;; "0"
|
|
;; Working copy so we can destroy it.
|
|
(local.set $n (call $bn_n (local.get $v)))
|
|
(local.set $work (call $make_bignum_raw (local.get $n)))
|
|
(local.set $i (i32.const 0))
|
|
(block $cpdone
|
|
(loop $cp
|
|
(br_if $cpdone (i32.ge_s (local.get $i) (local.get $n)))
|
|
(call $bn_set_limb (local.get $work) (local.get $i)
|
|
(call $bn_limb (local.get $v) (local.get $i)))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $cp)))
|
|
(call $bn_set_n (local.get $work) (local.get $n))
|
|
;; Decimal scratch area.
|
|
(local.set $buf (i32.const 0x300))
|
|
(local.set $bi (i32.const 0))
|
|
(block $ddone
|
|
(loop $dl
|
|
(br_if $ddone (i32.eqz (call $bn_n (local.get $work))))
|
|
(local.set $rem (call $bn_divmod_small (local.get $work)
|
|
(i32.const 1000000000)
|
|
(local.get $work)))
|
|
;; Trim leading zero limbs after the divmod.
|
|
(local.set $n (call $bn_n (local.get $work)))
|
|
(block $trimdone
|
|
(loop $trim
|
|
(br_if $trimdone (i32.eqz (local.get $n)))
|
|
(br_if $trimdone (i32.ne (call $bn_limb (local.get $work) (i32.sub (local.get $n) (i32.const 1))) (i32.const 0)))
|
|
(local.set $n (i32.sub (local.get $n) (i32.const 1)))
|
|
(br $trim)))
|
|
(call $bn_set_n (local.get $work) (local.get $n))
|
|
;; Push 9 digits if more limbs remain, else just the natural digits.
|
|
(if (i32.eqz (call $bn_n (local.get $work)))
|
|
(then
|
|
(block $ldone
|
|
(loop $ldl
|
|
(br_if $ldone (i32.eqz (local.get $rem)))
|
|
(i32.store8 (i32.add (local.get $buf) (local.get $bi))
|
|
(i32.add (i32.const 48)
|
|
(i32.rem_u (local.get $rem) (i32.const 10))))
|
|
(local.set $rem (i32.div_u (local.get $rem) (i32.const 10)))
|
|
(local.set $bi (i32.add (local.get $bi) (i32.const 1)))
|
|
(br $ldl))))
|
|
(else
|
|
;; Always pad to 9 digits when more limbs follow.
|
|
(local.set $j (i32.const 0))
|
|
(block $padone
|
|
(loop $padl
|
|
(br_if $padone (i32.ge_s (local.get $j) (i32.const 9)))
|
|
(i32.store8 (i32.add (local.get $buf) (local.get $bi))
|
|
(i32.add (i32.const 48)
|
|
(i32.rem_u (local.get $rem) (i32.const 10))))
|
|
(local.set $rem (i32.div_u (local.get $rem) (i32.const 10)))
|
|
(local.set $bi (i32.add (local.get $bi) (i32.const 1)))
|
|
(local.set $j (i32.add (local.get $j) (i32.const 1)))
|
|
(br $padl)))))
|
|
(br $dl)))
|
|
(if (call $bn_sign (local.get $v))
|
|
(then (call $out_char (i32.const 45)))) ;; "-"
|
|
;; Drain buffer in reverse.
|
|
(block $emdone
|
|
(loop $em
|
|
(br_if $emdone (i32.eqz (local.get $bi)))
|
|
(local.set $bi (i32.sub (local.get $bi) (i32.const 1)))
|
|
(call $out_char (i32.load8_u (i32.add (local.get $buf) (local.get $bi))))
|
|
(br $em))))
|
|
|
|
(func $rat_num (param $v i32) (result i32)
|
|
(i32.load offset=4 (local.get $v)))
|
|
|
|
(func $rat_den (param $v i32) (result i32)
|
|
(i32.load offset=8 (local.get $v)))
|
|
|
|
;; Euclidean gcd on signed i32. Returns a positive result.
|
|
(func $gcd_i32 (param $a i32) (param $b i32) (result i32)
|
|
(local $t i32)
|
|
(if (i32.lt_s (local.get $a) (i32.const 0))
|
|
(then (local.set $a (i32.sub (i32.const 0) (local.get $a)))))
|
|
(if (i32.lt_s (local.get $b) (i32.const 0))
|
|
(then (local.set $b (i32.sub (i32.const 0) (local.get $b)))))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.eqz (local.get $b)))
|
|
(local.set $t (i32.rem_s (local.get $a) (local.get $b)))
|
|
(local.set $a (local.get $b))
|
|
(local.set $b (local.get $t))
|
|
(br $l)))
|
|
(local.get $a))
|
|
|
|
;; Build a rational from i32 num/den. Normalizes via gcd, returns a
|
|
;; fixnum if the denominator reduces to 1.
|
|
(func $make_rational (param $num i32) (param $den i32) (result i32)
|
|
(local $g i32)
|
|
(local $p i32)
|
|
(if (i32.eqz (local.get $den))
|
|
(then
|
|
;; div-by-zero: leave as raw num/0 so caller can handle as error
|
|
(local.set $p (call $alloc (i32.const 12)))
|
|
(i32.store (local.get $p) (i32.const 9))
|
|
(i32.store offset=4 (local.get $p) (local.get $num))
|
|
(i32.store offset=8 (local.get $p) (i32.const 0))
|
|
(return (local.get $p))))
|
|
;; Move sign to numerator: keep den positive.
|
|
(if (i32.lt_s (local.get $den) (i32.const 0))
|
|
(then
|
|
(local.set $num (i32.sub (i32.const 0) (local.get $num)))
|
|
(local.set $den (i32.sub (i32.const 0) (local.get $den)))))
|
|
(local.set $g (call $gcd_i32 (local.get $num) (local.get $den)))
|
|
(if (i32.gt_s (local.get $g) (i32.const 1))
|
|
(then
|
|
(local.set $num (i32.div_s (local.get $num) (local.get $g)))
|
|
(local.set $den (i32.div_s (local.get $den) (local.get $g)))))
|
|
;; den == 1 collapses to a fixnum.
|
|
(if (i32.eq (local.get $den) (i32.const 1))
|
|
(then (return (call $make_fixnum (local.get $num)))))
|
|
(local.set $p (call $alloc (i32.const 12)))
|
|
(i32.store (local.get $p) (i32.const 9))
|
|
(i32.store offset=4 (local.get $p) (local.get $num))
|
|
(i32.store offset=8 (local.get $p) (local.get $den))
|
|
(local.get $p))
|
|
|
|
;; Convert a number Value to (num,den) returned via globals (numerator
|
|
;; in $rat_tmp_n, denominator in $rat_tmp_d). Fixnum → (n, 1).
|
|
(func $to_rat (param $v i32)
|
|
(if (call $is_fixnum (local.get $v))
|
|
(then
|
|
(global.set $rat_tmp_n (call $fixnum_val (local.get $v)))
|
|
(global.set $rat_tmp_d (i32.const 1))
|
|
(return)))
|
|
(if (call $is_rational (local.get $v))
|
|
(then
|
|
(global.set $rat_tmp_n (call $rat_num (local.get $v)))
|
|
(global.set $rat_tmp_d (call $rat_den (local.get $v)))
|
|
(return)))
|
|
;; Anything else falls back to 0/1.
|
|
(global.set $rat_tmp_n (i32.const 0))
|
|
(global.set $rat_tmp_d (i32.const 1)))
|
|
|
|
(func $rat_add (param $a i32) (param $b i32) (result i32)
|
|
(local $an i32) (local $ad i32) (local $bn i32) (local $bd i32)
|
|
(call $to_rat (local.get $a))
|
|
(local.set $an (global.get $rat_tmp_n)) (local.set $ad (global.get $rat_tmp_d))
|
|
(call $to_rat (local.get $b))
|
|
(local.set $bn (global.get $rat_tmp_n)) (local.set $bd (global.get $rat_tmp_d))
|
|
(call $make_rational
|
|
(i32.add (i32.mul (local.get $an) (local.get $bd))
|
|
(i32.mul (local.get $bn) (local.get $ad)))
|
|
(i32.mul (local.get $ad) (local.get $bd))))
|
|
|
|
(func $rat_sub (param $a i32) (param $b i32) (result i32)
|
|
(local $an i32) (local $ad i32) (local $bn i32) (local $bd i32)
|
|
(call $to_rat (local.get $a))
|
|
(local.set $an (global.get $rat_tmp_n)) (local.set $ad (global.get $rat_tmp_d))
|
|
(call $to_rat (local.get $b))
|
|
(local.set $bn (global.get $rat_tmp_n)) (local.set $bd (global.get $rat_tmp_d))
|
|
(call $make_rational
|
|
(i32.sub (i32.mul (local.get $an) (local.get $bd))
|
|
(i32.mul (local.get $bn) (local.get $ad)))
|
|
(i32.mul (local.get $ad) (local.get $bd))))
|
|
|
|
(func $rat_mul (param $a i32) (param $b i32) (result i32)
|
|
(local $an i32) (local $ad i32) (local $bn i32) (local $bd i32)
|
|
(call $to_rat (local.get $a))
|
|
(local.set $an (global.get $rat_tmp_n)) (local.set $ad (global.get $rat_tmp_d))
|
|
(call $to_rat (local.get $b))
|
|
(local.set $bn (global.get $rat_tmp_n)) (local.set $bd (global.get $rat_tmp_d))
|
|
(call $make_rational
|
|
(i32.mul (local.get $an) (local.get $bn))
|
|
(i32.mul (local.get $ad) (local.get $bd))))
|
|
|
|
(func $rat_div (param $a i32) (param $b i32) (result i32)
|
|
(local $an i32) (local $ad i32) (local $bn i32) (local $bd i32)
|
|
(call $to_rat (local.get $a))
|
|
(local.set $an (global.get $rat_tmp_n)) (local.set $ad (global.get $rat_tmp_d))
|
|
(call $to_rat (local.get $b))
|
|
(local.set $bn (global.get $rat_tmp_n)) (local.set $bd (global.get $rat_tmp_d))
|
|
(call $make_rational
|
|
(i32.mul (local.get $an) (local.get $bd))
|
|
(i32.mul (local.get $ad) (local.get $bn))))
|
|
|
|
;; Returns 1 if a == b as rationals, else 0.
|
|
(func $rat_eq (param $a i32) (param $b i32) (result i32)
|
|
(local $an i32) (local $ad i32) (local $bn i32) (local $bd i32)
|
|
(call $to_rat (local.get $a))
|
|
(local.set $an (global.get $rat_tmp_n)) (local.set $ad (global.get $rat_tmp_d))
|
|
(call $to_rat (local.get $b))
|
|
(local.set $bn (global.get $rat_tmp_n)) (local.set $bd (global.get $rat_tmp_d))
|
|
(i32.eq (i32.mul (local.get $an) (local.get $bd))
|
|
(i32.mul (local.get $bn) (local.get $ad))))
|
|
|
|
;; Returns 1 if a < b as rationals, else 0. Denominators always positive.
|
|
(func $rat_lt (param $a i32) (param $b i32) (result i32)
|
|
(local $an i32) (local $ad i32) (local $bn i32) (local $bd i32)
|
|
(call $to_rat (local.get $a))
|
|
(local.set $an (global.get $rat_tmp_n)) (local.set $ad (global.get $rat_tmp_d))
|
|
(call $to_rat (local.get $b))
|
|
(local.set $bn (global.get $rat_tmp_n)) (local.set $bd (global.get $rat_tmp_d))
|
|
(i32.lt_s (i32.mul (local.get $an) (local.get $bd))
|
|
(i32.mul (local.get $bn) (local.get $ad))))
|
|
|
|
;; ─── Vectors (tag=7) ───────────────────────────────────────────
|
|
;; Layout: [tag=7, len, elem_0, elem_1, ...] — 8 + 4*len bytes.
|
|
(func $is_vector (param $v i32) (result i32)
|
|
(if (result i32) (call $is_fixnum (local.get $v))
|
|
(then (i32.const 0))
|
|
(else
|
|
(if (result i32) (call $is_immediate (local.get $v))
|
|
(then (i32.const 0))
|
|
(else (i32.eq (call $obj_tag (local.get $v)) (i32.const 7)))))))
|
|
|
|
(func $make_vector_raw (param $len i32) (result i32)
|
|
(local $p i32)
|
|
(local.set $p (call $alloc (i32.add (i32.const 8) (i32.mul (local.get $len) (i32.const 4)))))
|
|
(i32.store (local.get $p) (i32.const 7))
|
|
(i32.store offset=4 (local.get $p) (local.get $len))
|
|
(local.get $p))
|
|
|
|
(func $vector_len (param $v i32) (result i32)
|
|
(i32.load offset=4 (local.get $v)))
|
|
|
|
(func $vector_get (param $v i32) (param $i i32) (result i32)
|
|
(i32.load (i32.add (i32.add (local.get $v) (i32.const 8)) (i32.mul (local.get $i) (i32.const 4)))))
|
|
|
|
(func $vector_put (param $v i32) (param $i i32) (param $val i32)
|
|
(i32.store (i32.add (i32.add (local.get $v) (i32.const 8)) (i32.mul (local.get $i) (i32.const 4))) (local.get $val)))
|
|
|
|
;; ─── Hash tables (tag=8) ───────────────────────────────────────
|
|
;; Layout: [tag=8, count, alist_ptr]. alist is a list of (key . val) pairs.
|
|
;; Lookup is linear — fine for browser demos; would be MOAD-0001 at scale,
|
|
;; same caveat as my linear symbol intern.
|
|
(func $is_hashtable (param $v i32) (result i32)
|
|
(if (result i32) (call $is_fixnum (local.get $v))
|
|
(then (i32.const 0))
|
|
(else
|
|
(if (result i32) (call $is_immediate (local.get $v))
|
|
(then (i32.const 0))
|
|
(else (i32.eq (call $obj_tag (local.get $v)) (i32.const 8)))))))
|
|
|
|
(func $make_hashtable (result i32)
|
|
(local $p i32)
|
|
(local.set $p (call $alloc (i32.const 12)))
|
|
(i32.store (local.get $p) (i32.const 8))
|
|
(i32.store offset=4 (local.get $p) (i32.const 0))
|
|
(i32.store offset=8 (local.get $p) (global.get $NIL))
|
|
(local.get $p))
|
|
|
|
(func $ht_count (param $h i32) (result i32)
|
|
(i32.load offset=4 (local.get $h)))
|
|
|
|
(func $ht_alist (param $h i32) (result i32)
|
|
(i32.load offset=8 (local.get $h)))
|
|
|
|
(func $ht_set_alist (param $h i32) (param $a i32)
|
|
(i32.store offset=8 (local.get $h) (local.get $a)))
|
|
|
|
(func $ht_set_count (param $h i32) (param $n i32)
|
|
(i32.store offset=4 (local.get $h) (local.get $n)))
|
|
|
|
;; Find binding for key in hashtable, returns the (k.v) pair or FALSE.
|
|
(func $ht_find (param $h i32) (param $key i32) (result i32)
|
|
(local $cur i32)
|
|
(local $pair i32)
|
|
(local.set $cur (call $ht_alist (local.get $h)))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.eqz (call $is_pair (local.get $cur))))
|
|
(local.set $pair (call $car (local.get $cur)))
|
|
(if (i32.eq (call $equal_p (call $car (local.get $pair)) (local.get $key)) (global.get $TRUE))
|
|
(then (return (local.get $pair))))
|
|
(local.set $cur (call $cdr (local.get $cur)))
|
|
(br $l)))
|
|
(global.get $FALSE))
|
|
|
|
(func $ht_set (param $h i32) (param $key i32) (param $val i32)
|
|
(local $found i32)
|
|
(local.set $found (call $ht_find (local.get $h) (local.get $key)))
|
|
(if (i32.eq (local.get $found) (global.get $FALSE))
|
|
(then
|
|
(call $ht_set_alist (local.get $h)
|
|
(call $make_pair
|
|
(call $make_pair (local.get $key) (local.get $val))
|
|
(call $ht_alist (local.get $h))))
|
|
(call $ht_set_count (local.get $h)
|
|
(i32.add (call $ht_count (local.get $h)) (i32.const 1))))
|
|
(else
|
|
(call $set_cdr (local.get $found) (local.get $val)))))
|
|
|
|
;; Remove binding for key, returns 1 if removed, 0 if not present.
|
|
(func $ht_delete (param $h i32) (param $key i32) (result i32)
|
|
(local $cur i32)
|
|
(local $prev i32)
|
|
(local $pair i32)
|
|
(local.set $cur (call $ht_alist (local.get $h)))
|
|
(local.set $prev (global.get $NIL))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.eqz (call $is_pair (local.get $cur))))
|
|
(local.set $pair (call $car (local.get $cur)))
|
|
(if (i32.eq (call $equal_p (call $car (local.get $pair)) (local.get $key)) (global.get $TRUE))
|
|
(then
|
|
(if (i32.eq (local.get $prev) (global.get $NIL))
|
|
(then (call $ht_set_alist (local.get $h) (call $cdr (local.get $cur))))
|
|
(else (call $set_cdr (local.get $prev) (call $cdr (local.get $cur)))))
|
|
(call $ht_set_count (local.get $h)
|
|
(i32.sub (call $ht_count (local.get $h)) (i32.const 1)))
|
|
(return (i32.const 1))))
|
|
(local.set $prev (local.get $cur))
|
|
(local.set $cur (call $cdr (local.get $cur)))
|
|
(br $l)))
|
|
(i32.const 0))
|
|
|
|
(func $char_code (param $v i32) (result i32)
|
|
(i32.load offset=4 (local.get $v)))
|
|
|
|
;; Allocate an empty string object of the given length, return pointer.
|
|
;; Bytes are uninitialized; caller must fill before use.
|
|
(func $make_string_raw (param $len i32) (result i32)
|
|
(local $p i32)
|
|
(local.set $p (call $alloc (i32.add (i32.const 8) (local.get $len))))
|
|
(i32.store (local.get $p) (i32.const 5))
|
|
(i32.store offset=4 (local.get $p) (local.get $len))
|
|
(local.get $p))
|
|
|
|
(func $string_len (param $s i32) (result i32)
|
|
(i32.load offset=4 (local.get $s)))
|
|
|
|
(func $string_byte (param $s i32) (param $i i32) (result i32)
|
|
(i32.load8_u (i32.add (i32.add (local.get $s) (i32.const 8)) (local.get $i))))
|
|
|
|
(func $string_set_byte (param $s i32) (param $i i32) (param $c i32)
|
|
(i32.store8 (i32.add (i32.add (local.get $s) (i32.const 8)) (local.get $i)) (local.get $c)))
|
|
|
|
;; ─── Constructors ──────────────────────────────────────────────
|
|
(func $make_fixnum (export "make_fixnum") (param $n i32) (result i32)
|
|
(i32.or (i32.shl (local.get $n) (i32.const 1)) (i32.const 1)))
|
|
|
|
(func $fixnum_val (param $v i32) (result i32)
|
|
(i32.shr_s (local.get $v) (i32.const 1)))
|
|
|
|
(func $make_pair (param $car i32) (param $cdr i32) (result i32)
|
|
(local $p i32)
|
|
(local.set $p (call $alloc (i32.const 12)))
|
|
(i32.store (local.get $p) (i32.const 1))
|
|
(i32.store offset=4 (local.get $p) (local.get $car))
|
|
(i32.store offset=8 (local.get $p) (local.get $cdr))
|
|
(local.get $p))
|
|
|
|
(func $car (param $p i32) (result i32)
|
|
(i32.load offset=4 (local.get $p)))
|
|
|
|
(func $cdr (param $p i32) (result i32)
|
|
(i32.load offset=8 (local.get $p)))
|
|
|
|
(func $set_car (param $p i32) (param $v i32)
|
|
(i32.store offset=4 (local.get $p) (local.get $v)))
|
|
|
|
(func $set_cdr (param $p i32) (param $v i32)
|
|
(i32.store offset=8 (local.get $p) (local.get $v)))
|
|
|
|
;; Allocate a symbol object with given char bytes.
|
|
;; The bytes are at $src_ptr for $len bytes. Returns symbol pointer.
|
|
(func $alloc_symbol (param $src_ptr i32) (param $len i32) (result i32)
|
|
(local $sym i32)
|
|
(local $i i32)
|
|
(local.set $sym (call $alloc (i32.add (i32.const 8) (local.get $len))))
|
|
(i32.store (local.get $sym) (i32.const 2))
|
|
(i32.store offset=4 (local.get $sym) (local.get $len))
|
|
(local.set $i (i32.const 0))
|
|
(block $done
|
|
(loop $copy
|
|
(br_if $done (i32.ge_u (local.get $i) (local.get $len)))
|
|
(i32.store8
|
|
(i32.add (i32.add (local.get $sym) (i32.const 8)) (local.get $i))
|
|
(i32.load8_u (i32.add (local.get $src_ptr) (local.get $i))))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $copy)))
|
|
(local.get $sym))
|
|
|
|
;; Compare two symbol payloads by bytes.
|
|
(func $sym_bytes_eq (param $sym i32) (param $src_ptr i32) (param $len i32) (result i32)
|
|
(local $slen i32)
|
|
(local $i i32)
|
|
(local.set $slen (i32.load offset=4 (local.get $sym)))
|
|
(if (i32.ne (local.get $slen) (local.get $len))
|
|
(then (return (i32.const 0))))
|
|
(local.set $i (i32.const 0))
|
|
(block $done
|
|
(loop $cmp
|
|
(br_if $done (i32.ge_u (local.get $i) (local.get $len)))
|
|
(if (i32.ne
|
|
(i32.load8_u
|
|
(i32.add (i32.add (local.get $sym) (i32.const 8)) (local.get $i)))
|
|
(i32.load8_u (i32.add (local.get $src_ptr) (local.get $i))))
|
|
(then (return (i32.const 0))))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $cmp)))
|
|
(i32.const 1))
|
|
|
|
;; Intern a symbol by string content (bytes at $src_ptr, length $len).
|
|
;; Returns the symbol's heap pointer; reuses existing entry if found.
|
|
(func $intern (param $src_ptr i32) (param $len i32) (result i32)
|
|
(local $list i32)
|
|
(local $sym i32)
|
|
(local $new i32)
|
|
(local.set $list (global.get $intern_list))
|
|
(block $done
|
|
(loop $scan
|
|
(br_if $done (i32.eq (local.get $list) (global.get $NIL)))
|
|
(local.set $sym (call $car (local.get $list)))
|
|
(if (call $sym_bytes_eq (local.get $sym) (local.get $src_ptr) (local.get $len))
|
|
(then (return (local.get $sym))))
|
|
(local.set $list (call $cdr (local.get $list)))
|
|
(br $scan)))
|
|
(local.set $new (call $alloc_symbol (local.get $src_ptr) (local.get $len)))
|
|
(global.set $intern_list (call $make_pair (local.get $new) (global.get $intern_list)))
|
|
(local.get $new))
|
|
|
|
(func $make_primitive (param $id i32) (result i32)
|
|
(local $p i32)
|
|
(local.set $p (call $alloc (i32.const 8)))
|
|
(i32.store (local.get $p) (i32.const 4))
|
|
(i32.store offset=4 (local.get $p) (local.get $id))
|
|
(local.get $p))
|
|
|
|
(func $make_closure (param $params i32) (param $body i32) (param $env i32) (result i32)
|
|
(local $c i32)
|
|
(local.set $c (call $alloc (i32.const 16)))
|
|
(i32.store (local.get $c) (i32.const 3))
|
|
(i32.store offset=4 (local.get $c) (local.get $params))
|
|
(i32.store offset=8 (local.get $c) (local.get $body))
|
|
(i32.store offset=12 (local.get $c) (local.get $env))
|
|
(local.get $c))
|
|
|
|
;; ─── Environment (assoc list of (sym . value) pairs) ───────────
|
|
(func $env_define (param $env i32) (param $sym i32) (param $val i32) (result i32)
|
|
(call $make_pair
|
|
(call $make_pair (local.get $sym) (local.get $val))
|
|
(local.get $env)))
|
|
|
|
;; Walk captured env chain first (lexical scope), then fall back to the
|
|
;; current global_env (so top-level defines that happen AFTER a closure
|
|
;; is captured are still visible to it — required for forward references
|
|
;; and mutual recursion at the top level).
|
|
(func $env_lookup (param $env i32) (param $sym i32) (result i32)
|
|
(local $bind i32)
|
|
(local $cur i32)
|
|
(local.set $cur (local.get $env))
|
|
(block $done
|
|
(loop $scan
|
|
(br_if $done (i32.eq (local.get $cur) (global.get $NIL)))
|
|
(local.set $bind (call $car (local.get $cur)))
|
|
(if (i32.eq (call $car (local.get $bind)) (local.get $sym))
|
|
(then (return (call $cdr (local.get $bind)))))
|
|
(local.set $cur (call $cdr (local.get $cur)))
|
|
(br $scan)))
|
|
(local.set $cur (global.get $global_env))
|
|
(block $done2
|
|
(loop $scan2
|
|
(br_if $done2 (i32.eq (local.get $cur) (global.get $NIL)))
|
|
(local.set $bind (call $car (local.get $cur)))
|
|
(if (i32.eq (call $car (local.get $bind)) (local.get $sym))
|
|
(then (return (call $cdr (local.get $bind)))))
|
|
(local.set $cur (call $cdr (local.get $cur)))
|
|
(br $scan2)))
|
|
(global.get $VOID))
|
|
|
|
(func $env_set (param $env i32) (param $sym i32) (param $val i32) (result i32)
|
|
(local $bind i32)
|
|
(block $done
|
|
(loop $scan
|
|
(br_if $done (i32.eq (local.get $env) (global.get $NIL)))
|
|
(local.set $bind (call $car (local.get $env)))
|
|
(if (i32.eq (call $car (local.get $bind)) (local.get $sym))
|
|
(then
|
|
(call $set_cdr (local.get $bind) (local.get $val))
|
|
(return (global.get $VOID))))
|
|
(local.set $env (call $cdr (local.get $env)))
|
|
(br $scan)))
|
|
(global.get $VOID))
|
|
|
|
;; ─── Output buffer ─────────────────────────────────────────────
|
|
(func $out_char (param $c i32)
|
|
(local $consumed i32)
|
|
(i32.store8
|
|
(i32.add (i32.const 0x10000) (global.get $output_len))
|
|
(local.get $c))
|
|
(global.set $output_len (i32.add (global.get $output_len) (i32.const 1)))
|
|
;; Newline flushes the slice [flush_start, output_len) to JS so
|
|
;; the playground panel can render line-by-line during eval
|
|
;; instead of waiting for the full evalLisp to return. If the
|
|
;; host consumed the chunk (return value = 1) we recycle the
|
|
;; output region by zeroing both offsets — a tight printing
|
|
;; loop overflowed the 64 KB buffer at 0x20000 otherwise. If
|
|
;; the host returned 0 (e.g. test stubs that don't drain), we
|
|
;; just advance flush_start so a later lumbda_output_ptr/len
|
|
;; read still sees the full accumulated buffer.
|
|
(if (i32.eq (local.get $c) (i32.const 10))
|
|
(then
|
|
(local.set $consumed
|
|
(call $js_emit_chunk
|
|
(i32.add (i32.const 0x10000) (global.get $flush_start))
|
|
(i32.sub (global.get $output_len) (global.get $flush_start))))
|
|
(if (local.get $consumed)
|
|
(then
|
|
(global.set $output_len (i32.const 0))
|
|
(global.set $flush_start (i32.const 0)))
|
|
(else
|
|
(global.set $flush_start (global.get $output_len)))))))
|
|
|
|
(func $out_str (param $ptr i32) (param $len i32)
|
|
(local $i i32)
|
|
(local.set $i (i32.const 0))
|
|
(block $done
|
|
(loop $loop
|
|
(br_if $done (i32.ge_u (local.get $i) (local.get $len)))
|
|
(call $out_char (i32.load8_u (i32.add (local.get $ptr) (local.get $i))))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $loop))))
|
|
|
|
;; Print an integer (signed) to the output buffer.
|
|
(func $out_int (param $n i32)
|
|
(local $buf_off i32)
|
|
(local $neg i32)
|
|
(local $digits_start i32)
|
|
(local $i i32)
|
|
(local $tmp i32)
|
|
(local $j i32)
|
|
(local $swap i32)
|
|
;; Use a small scratch area at 0x100 (256 bytes)
|
|
(local.set $buf_off (i32.const 0x100))
|
|
(local.set $neg (i32.const 0))
|
|
(if (i32.lt_s (local.get $n) (i32.const 0))
|
|
(then
|
|
(local.set $neg (i32.const 1))
|
|
(local.set $n (i32.sub (i32.const 0) (local.get $n)))))
|
|
(local.set $i (i32.const 0))
|
|
(if (i32.eqz (local.get $n))
|
|
(then
|
|
(i32.store8 (i32.add (local.get $buf_off) (local.get $i)) (i32.const 48))
|
|
(local.set $i (i32.const 1)))
|
|
(else
|
|
(block $done
|
|
(loop $loop
|
|
(br_if $done (i32.eqz (local.get $n)))
|
|
(i32.store8
|
|
(i32.add (local.get $buf_off) (local.get $i))
|
|
(i32.add (i32.const 48) (i32.rem_u (local.get $n) (i32.const 10))))
|
|
(local.set $n (i32.div_u (local.get $n) (i32.const 10)))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $loop)))))
|
|
(if (local.get $neg)
|
|
(then (call $out_char (i32.const 45))))
|
|
;; Reverse output: digits are stored low-to-high, emit high-to-low.
|
|
(local.set $j (i32.sub (local.get $i) (i32.const 1)))
|
|
(block $done2
|
|
(loop $loop2
|
|
(br_if $done2 (i32.lt_s (local.get $j) (i32.const 0)))
|
|
(call $out_char (i32.load8_u (i32.add (local.get $buf_off) (local.get $j))))
|
|
(local.set $j (i32.sub (local.get $j) (i32.const 1)))
|
|
(br $loop2))))
|
|
|
|
;; Print a value (display semantics; minimal show).
|
|
(func $print_value (param $v i32)
|
|
(local $bytes i32)
|
|
(local $len i32)
|
|
(if (call $is_fixnum (local.get $v))
|
|
(then (call $out_int (call $fixnum_val (local.get $v))) (return)))
|
|
(if (call $is_bignum (local.get $v))
|
|
(then (call $print_bignum (local.get $v)) (return)))
|
|
(if (call $is_rational (local.get $v))
|
|
(then
|
|
(call $out_int (call $rat_num (local.get $v)))
|
|
(call $out_char (i32.const 47)) ;; /
|
|
(call $out_int (call $rat_den (local.get $v)))
|
|
(return)))
|
|
(if (i32.eq (local.get $v) (global.get $NIL))
|
|
(then (call $out_str (i32.const 0xF000) (i32.const 2)) (return))) ;; "()"
|
|
(if (i32.eq (local.get $v) (global.get $TRUE))
|
|
(then (call $out_str (i32.const 0xF010) (i32.const 2)) (return))) ;; "#t"
|
|
(if (i32.eq (local.get $v) (global.get $FALSE))
|
|
(then (call $out_str (i32.const 0xF020) (i32.const 2)) (return))) ;; "#f"
|
|
(if (i32.eq (local.get $v) (global.get $VOID))
|
|
(then (return)))
|
|
(if (call $is_symbol (local.get $v))
|
|
(then
|
|
(local.set $bytes (i32.add (local.get $v) (i32.const 8)))
|
|
(local.set $len (i32.load offset=4 (local.get $v)))
|
|
(call $out_str (local.get $bytes) (local.get $len))
|
|
(return)))
|
|
(if (call $is_string (local.get $v))
|
|
(then
|
|
(local.set $bytes (i32.add (local.get $v) (i32.const 8)))
|
|
(local.set $len (i32.load offset=4 (local.get $v)))
|
|
(call $out_str (local.get $bytes) (local.get $len))
|
|
(return)))
|
|
(if (call $is_char (local.get $v))
|
|
(then
|
|
(call $out_char (call $char_code (local.get $v)))
|
|
(return)))
|
|
(if (call $is_pair (local.get $v))
|
|
(then
|
|
(call $out_char (i32.const 40)) ;; (
|
|
(call $print_list_items (local.get $v))
|
|
(call $out_char (i32.const 41)) ;; )
|
|
(return)))
|
|
(if (call $is_vector (local.get $v))
|
|
(then
|
|
(call $out_str (i32.const 0xF050) (i32.const 2)) ;; "#("
|
|
(call $print_vector_items (local.get $v))
|
|
(call $out_char (i32.const 41)) ;; )
|
|
(return)))
|
|
(if (call $is_hashtable (local.get $v))
|
|
(then
|
|
(call $out_str (i32.const 0xF060) (i32.const 12)) ;; "#<hashtable>"
|
|
(return)))
|
|
;; closure / primitive
|
|
(call $out_str (i32.const 0xF030) (i32.const 11))) ;; "<procedure>"
|
|
|
|
;; write_value — like print_value but quotes strings and #\-prefixes chars.
|
|
(func $write_value (param $v i32)
|
|
(local $bytes i32)
|
|
(local $len i32)
|
|
(if (call $is_string (local.get $v))
|
|
(then
|
|
(call $out_char (i32.const 34)) ;; "
|
|
(local.set $bytes (i32.add (local.get $v) (i32.const 8)))
|
|
(local.set $len (i32.load offset=4 (local.get $v)))
|
|
(call $out_str (local.get $bytes) (local.get $len))
|
|
(call $out_char (i32.const 34)) ;; "
|
|
(return)))
|
|
(if (call $is_char (local.get $v))
|
|
(then
|
|
(call $out_str (i32.const 0xF080) (i32.const 2)) ;; "#\\"
|
|
(call $out_char (call $char_code (local.get $v)))
|
|
(return)))
|
|
(if (call $is_pair (local.get $v))
|
|
(then
|
|
(call $out_char (i32.const 40))
|
|
(call $write_pair_items (local.get $v))
|
|
(call $out_char (i32.const 41))
|
|
(return)))
|
|
(call $print_value (local.get $v)))
|
|
|
|
(func $write_pair_items (param $p i32)
|
|
(block $done
|
|
(loop $loop
|
|
(br_if $done (i32.eqz (call $is_pair (local.get $p))))
|
|
(call $write_value (call $car (local.get $p)))
|
|
(local.set $p (call $cdr (local.get $p)))
|
|
(if (call $is_pair (local.get $p))
|
|
(then (call $out_char (i32.const 32))))
|
|
(br $loop)))
|
|
(if (i32.ne (local.get $p) (global.get $NIL))
|
|
(then
|
|
(call $out_str (i32.const 0xF040) (i32.const 3))
|
|
(call $write_value (local.get $p)))))
|
|
|
|
(func $print_vector_items (param $v i32)
|
|
(local $len i32)
|
|
(local $i i32)
|
|
(local.set $len (call $vector_len (local.get $v)))
|
|
(local.set $i (i32.const 0))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.ge_u (local.get $i) (local.get $len)))
|
|
(call $print_value (call $vector_get (local.get $v) (local.get $i)))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(if (i32.lt_u (local.get $i) (local.get $len))
|
|
(then (call $out_char (i32.const 32))))
|
|
(br $l))))
|
|
|
|
(func $print_list_items (param $p i32)
|
|
(block $done
|
|
(loop $loop
|
|
(br_if $done (i32.eqz (call $is_pair (local.get $p))))
|
|
(call $print_value (call $car (local.get $p)))
|
|
(local.set $p (call $cdr (local.get $p)))
|
|
(if (call $is_pair (local.get $p))
|
|
(then (call $out_char (i32.const 32)))) ;; space
|
|
(br $loop)))
|
|
(if (i32.ne (local.get $p) (global.get $NIL))
|
|
(then
|
|
(call $out_str (i32.const 0xF040) (i32.const 3)) ;; " . "
|
|
(call $print_value (local.get $p)))))
|
|
|
|
;; ─── Reader ────────────────────────────────────────────────────
|
|
;; Advance $source_ptr past whitespace + ; comments.
|
|
(func $skip_ws
|
|
(local $c i32)
|
|
(block $done
|
|
(loop $loop
|
|
(br_if $done (i32.ge_u (global.get $source_ptr) (global.get $source_end)))
|
|
(local.set $c (i32.load8_u (global.get $source_ptr)))
|
|
(if (i32.eq (local.get $c) (i32.const 32)) ;; space
|
|
(then (global.set $source_ptr (i32.add (global.get $source_ptr) (i32.const 1))) (br $loop)))
|
|
(if (i32.eq (local.get $c) (i32.const 9)) ;; tab
|
|
(then (global.set $source_ptr (i32.add (global.get $source_ptr) (i32.const 1))) (br $loop)))
|
|
(if (i32.eq (local.get $c) (i32.const 10)) ;; LF
|
|
(then (global.set $source_ptr (i32.add (global.get $source_ptr) (i32.const 1))) (br $loop)))
|
|
(if (i32.eq (local.get $c) (i32.const 13)) ;; CR
|
|
(then (global.set $source_ptr (i32.add (global.get $source_ptr) (i32.const 1))) (br $loop)))
|
|
(if (i32.eq (local.get $c) (i32.const 59)) ;; ;
|
|
(then
|
|
(block $cdone
|
|
(loop $cloop
|
|
(br_if $cdone (i32.ge_u (global.get $source_ptr) (global.get $source_end)))
|
|
(br_if $cdone
|
|
(i32.eq (i32.load8_u (global.get $source_ptr)) (i32.const 10)))
|
|
(global.set $source_ptr (i32.add (global.get $source_ptr) (i32.const 1)))
|
|
(br $cloop)))
|
|
(br $loop)))
|
|
(br $done))))
|
|
|
|
(func $is_digit (param $c i32) (result i32)
|
|
(i32.and
|
|
(i32.ge_u (local.get $c) (i32.const 48))
|
|
(i32.le_u (local.get $c) (i32.const 57))))
|
|
|
|
(func $is_atom_char (param $c i32) (result i32)
|
|
;; non-whitespace, non-paren, non-quote, non-string-delim
|
|
(if (result i32) (i32.le_u (local.get $c) (i32.const 32))
|
|
(then (i32.const 0))
|
|
(else
|
|
(if (result i32) (i32.eq (local.get $c) (i32.const 40)) ;; (
|
|
(then (i32.const 0))
|
|
(else
|
|
(if (result i32) (i32.eq (local.get $c) (i32.const 41)) ;; )
|
|
(then (i32.const 0))
|
|
(else
|
|
(if (result i32) (i32.eq (local.get $c) (i32.const 39)) ;; '
|
|
(then (i32.const 0))
|
|
(else
|
|
(if (result i32) (i32.eq (local.get $c) (i32.const 34)) ;; "
|
|
(then (i32.const 0))
|
|
(else (i32.const 1))))))))))))
|
|
|
|
;; Parse one s-expression starting at $source_ptr. Returns the Value.
|
|
(func $read (result i32)
|
|
(local $c i32)
|
|
(local $start i32)
|
|
(local $len i32)
|
|
(local $n i32)
|
|
(local $neg i32)
|
|
(local $i i32)
|
|
(local $byte i32)
|
|
(local $sym i32)
|
|
(local $end_str i32)
|
|
(local $den i32)
|
|
(local $den_start i32)
|
|
(call $skip_ws)
|
|
(if (i32.ge_u (global.get $source_ptr) (global.get $source_end))
|
|
(then (return (global.get $VOID))))
|
|
(local.set $c (i32.load8_u (global.get $source_ptr)))
|
|
|
|
;; ( — read list
|
|
(if (i32.eq (local.get $c) (i32.const 40))
|
|
(then
|
|
(global.set $source_ptr (i32.add (global.get $source_ptr) (i32.const 1)))
|
|
(return (call $read_list))))
|
|
|
|
;; ) — stray close paren. Advance past it so the top-level eval loop
|
|
;; doesn't spin reading the same byte forever. Returns VOID so the
|
|
;; caller skips this token.
|
|
(if (i32.eq (local.get $c) (i32.const 41))
|
|
(then
|
|
(global.set $source_ptr (i32.add (global.get $source_ptr) (i32.const 1)))
|
|
(return (global.get $VOID))))
|
|
|
|
;; ' — quote shorthand
|
|
(if (i32.eq (local.get $c) (i32.const 39))
|
|
(then
|
|
(global.set $source_ptr (i32.add (global.get $source_ptr) (i32.const 1)))
|
|
(return (call $make_pair (global.get $sym_quote)
|
|
(call $make_pair (call $read) (global.get $NIL))))))
|
|
|
|
;; " — string
|
|
(if (i32.eq (local.get $c) (i32.const 34))
|
|
(then
|
|
(global.set $source_ptr (i32.add (global.get $source_ptr) (i32.const 1)))
|
|
(return (call $read_string))))
|
|
|
|
;; #t #f #\char
|
|
(if (i32.eq (local.get $c) (i32.const 35)) ;; #
|
|
(then
|
|
(global.set $source_ptr (i32.add (global.get $source_ptr) (i32.const 1)))
|
|
(if (i32.ge_u (global.get $source_ptr) (global.get $source_end))
|
|
(then (return (global.get $VOID))))
|
|
(local.set $c (i32.load8_u (global.get $source_ptr)))
|
|
;; #\char — backslash then a char or named character (space, newline, tab)
|
|
(if (i32.eq (local.get $c) (i32.const 92)) ;; \
|
|
(then
|
|
(global.set $source_ptr (i32.add (global.get $source_ptr) (i32.const 1)))
|
|
(return (call $read_char_literal))))
|
|
(global.set $source_ptr (i32.add (global.get $source_ptr) (i32.const 1)))
|
|
(if (i32.eq (local.get $c) (i32.const 116)) ;; t
|
|
(then (return (global.get $TRUE))))
|
|
(if (i32.eq (local.get $c) (i32.const 102)) ;; f
|
|
(then (return (global.get $FALSE))))
|
|
(return (global.get $VOID))))
|
|
|
|
;; Atom: digits or symbol chars
|
|
(local.set $start (global.get $source_ptr))
|
|
(block $atom_done
|
|
(loop $atom_loop
|
|
(br_if $atom_done (i32.ge_u (global.get $source_ptr) (global.get $source_end)))
|
|
(br_if $atom_done
|
|
(i32.eqz (call $is_atom_char (i32.load8_u (global.get $source_ptr)))))
|
|
(global.set $source_ptr (i32.add (global.get $source_ptr) (i32.const 1)))
|
|
(br $atom_loop)))
|
|
(local.set $len (i32.sub (global.get $source_ptr) (local.get $start)))
|
|
|
|
;; Number? must start with digit, or -digit / +digit with len > 1
|
|
(local.set $neg (i32.const 0))
|
|
(local.set $i (i32.const 0))
|
|
(local.set $byte (i32.load8_u (local.get $start)))
|
|
(if (i32.and
|
|
(i32.eq (local.get $byte) (i32.const 45)) ;; -
|
|
(i32.gt_s (local.get $len) (i32.const 1)))
|
|
(then
|
|
(local.set $neg (i32.const 1))
|
|
(local.set $i (i32.const 1))
|
|
(local.set $byte (i32.load8_u (i32.add (local.get $start) (i32.const 1))))))
|
|
(if (i32.and
|
|
(i32.eq (local.get $byte) (i32.const 43)) ;; +
|
|
(i32.gt_s (local.get $len) (i32.const 1)))
|
|
(then
|
|
(local.set $i (i32.const 1))
|
|
(local.set $byte (i32.load8_u (i32.add (local.get $start) (i32.const 1))))))
|
|
(if (call $is_digit (local.get $byte))
|
|
(then
|
|
;; Accumulate via num_add/num_mul so literals beyond fixnum range
|
|
;; auto-promote to a bignum mid-parse. This is the same path the
|
|
;; runtime arithmetic uses, so a literal 10^20 reads the same way
|
|
;; (expt 10 20) computes it.
|
|
(local.set $sym (call $make_fixnum (i32.const 0)))
|
|
(block $num_done
|
|
(loop $num_loop
|
|
(br_if $num_done (i32.ge_u (local.get $i) (local.get $len)))
|
|
(local.set $byte (i32.load8_u (i32.add (local.get $start) (local.get $i))))
|
|
(br_if $num_done (i32.eqz (call $is_digit (local.get $byte))))
|
|
(local.set $sym
|
|
(call $num_add
|
|
(call $num_mul (local.get $sym) (call $make_fixnum (i32.const 10)))
|
|
(call $make_fixnum (i32.sub (local.get $byte) (i32.const 48)))))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $num_loop)))
|
|
(if (i32.eq (local.get $i) (local.get $len))
|
|
(then
|
|
(if (local.get $neg)
|
|
(then (local.set $sym
|
|
(call $num_sub (call $make_fixnum (i32.const 0)) (local.get $sym)))))
|
|
(return (local.get $sym))))
|
|
;; Try rational form: numerator '/' denominator (e.g. 67/7).
|
|
;; The numerator may have promoted to a bignum during parsing;
|
|
;; rationals here are 31-bit num/den, so a bignum numerator
|
|
;; (>30 bits) falls through to be returned as the bignum itself.
|
|
(if (i32.and
|
|
(i32.lt_u (local.get $i) (local.get $len))
|
|
(i32.eq (i32.load8_u (i32.add (local.get $start) (local.get $i))) (i32.const 47)))
|
|
(then
|
|
(local.set $den (i32.const 0))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1))) ;; skip /
|
|
(local.set $den_start (local.get $i))
|
|
(block $den_done
|
|
(loop $den_loop
|
|
(br_if $den_done (i32.ge_u (local.get $i) (local.get $len)))
|
|
(local.set $byte (i32.load8_u (i32.add (local.get $start) (local.get $i))))
|
|
(br_if $den_done (i32.eqz (call $is_digit (local.get $byte))))
|
|
(local.set $den (i32.add (i32.mul (local.get $den) (i32.const 10))
|
|
(i32.sub (local.get $byte) (i32.const 48))))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $den_loop)))
|
|
;; Require: consumed all bytes, denominator > 0, numerator fits fixnum.
|
|
(if (i32.and
|
|
(i32.and
|
|
(i32.eq (local.get $i) (local.get $len))
|
|
(i32.gt_s (local.get $i) (local.get $den_start)))
|
|
(call $is_fixnum (local.get $sym)))
|
|
(then
|
|
(local.set $n (call $fixnum_val (local.get $sym)))
|
|
(if (local.get $neg)
|
|
(then (local.set $n (i32.sub (i32.const 0) (local.get $n)))))
|
|
(return (call $make_rational (local.get $n) (local.get $den)))))))))
|
|
|
|
;; Symbol
|
|
(return (call $intern (local.get $start) (local.get $len))))
|
|
|
|
;; Read list contents until ).
|
|
(func $read_list (result i32)
|
|
(local $head i32)
|
|
(local $tail i32)
|
|
(local $new i32)
|
|
(local $item i32)
|
|
(local $c0 i32)
|
|
(local $c1 i32)
|
|
(local.set $head (global.get $NIL))
|
|
(local.set $tail (global.get $NIL))
|
|
(block $done
|
|
(loop $loop
|
|
(call $skip_ws)
|
|
(if (i32.ge_u (global.get $source_ptr) (global.get $source_end))
|
|
(then (br $done)))
|
|
(local.set $c0 (i32.load8_u (global.get $source_ptr)))
|
|
(if (i32.eq (local.get $c0) (i32.const 41)) ;; )
|
|
(then
|
|
(global.set $source_ptr (i32.add (global.get $source_ptr) (i32.const 1)))
|
|
(br $done)))
|
|
;; Dotted-pair notation: a lone "." between elements means the
|
|
;; next expression becomes the cdr of the last pair (not cons'd).
|
|
(if (i32.eq (local.get $c0) (i32.const 46)) ;; .
|
|
(then
|
|
;; Lookahead: confirm the next byte is whitespace or `(`.
|
|
(if (i32.lt_u
|
|
(i32.add (global.get $source_ptr) (i32.const 1))
|
|
(global.get $source_end))
|
|
(then
|
|
(local.set $c1 (i32.load8_u
|
|
(i32.add (global.get $source_ptr) (i32.const 1))))
|
|
(if (i32.or
|
|
(i32.or
|
|
(i32.eq (local.get $c1) (i32.const 32))
|
|
(i32.eq (local.get $c1) (i32.const 9)))
|
|
(i32.or
|
|
(i32.eq (local.get $c1) (i32.const 10))
|
|
(i32.eq (local.get $c1) (i32.const 13))))
|
|
(then
|
|
(global.set $source_ptr (i32.add (global.get $source_ptr) (i32.const 1)))
|
|
(call $skip_ws)
|
|
(local.set $item (call $read))
|
|
(if (i32.ne (local.get $tail) (global.get $NIL))
|
|
(then (call $set_cdr (local.get $tail) (local.get $item))))
|
|
;; Consume the closing )
|
|
(call $skip_ws)
|
|
(if (i32.eq (i32.load8_u (global.get $source_ptr)) (i32.const 41))
|
|
(then (global.set $source_ptr (i32.add (global.get $source_ptr) (i32.const 1)))))
|
|
(br $done)))))))
|
|
(local.set $item (call $read))
|
|
(local.set $new (call $make_pair (local.get $item) (global.get $NIL)))
|
|
(if (i32.eq (local.get $head) (global.get $NIL))
|
|
(then
|
|
(local.set $head (local.get $new))
|
|
(local.set $tail (local.get $new)))
|
|
(else
|
|
(call $set_cdr (local.get $tail) (local.get $new))
|
|
(local.set $tail (local.get $new))))
|
|
(br $loop)))
|
|
(local.get $head))
|
|
|
|
;; Read a char literal: #\X already consumed up through \. The next byte
|
|
;; may be a single char ("a"), or the start of a named char (space, newline, tab).
|
|
;; Named chars are detected by seeing a letter followed by more letters.
|
|
(func $read_char_literal (result i32)
|
|
(local $first i32)
|
|
(local $start i32)
|
|
(local $len i32)
|
|
(if (i32.ge_u (global.get $source_ptr) (global.get $source_end))
|
|
(then (return (call $make_char (i32.const 32)))))
|
|
(local.set $first (i32.load8_u (global.get $source_ptr)))
|
|
(local.set $start (global.get $source_ptr))
|
|
(global.set $source_ptr (i32.add (global.get $source_ptr) (i32.const 1)))
|
|
;; If first is a letter, scan further letters to detect named char.
|
|
(if (i32.and
|
|
(i32.ge_u (local.get $first) (i32.const 97)) ;; a
|
|
(i32.le_u (local.get $first) (i32.const 122))) ;; z
|
|
(then
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.ge_u (global.get $source_ptr) (global.get $source_end)))
|
|
(br_if $done (i32.eqz (i32.and
|
|
(i32.ge_u (i32.load8_u (global.get $source_ptr)) (i32.const 97))
|
|
(i32.le_u (i32.load8_u (global.get $source_ptr)) (i32.const 122)))))
|
|
(global.set $source_ptr (i32.add (global.get $source_ptr) (i32.const 1)))
|
|
(br $l)))
|
|
(local.set $len (i32.sub (global.get $source_ptr) (local.get $start)))
|
|
(if (i32.eq (local.get $len) (i32.const 1))
|
|
(then (return (call $make_char (local.get $first)))))
|
|
;; Named chars: space, newline, tab, return, null
|
|
(if (call $bytes_eq_s (local.get $start) (local.get $len) (i32.const 0xE2D0) (i32.const 5))
|
|
(then (return (call $make_char (i32.const 32))))) ;; space
|
|
(if (call $bytes_eq_s (local.get $start) (local.get $len) (i32.const 0xE2D8) (i32.const 7))
|
|
(then (return (call $make_char (i32.const 10))))) ;; newline
|
|
(if (call $bytes_eq_s (local.get $start) (local.get $len) (i32.const 0xE2E0) (i32.const 3))
|
|
(then (return (call $make_char (i32.const 9))))) ;; tab
|
|
(if (call $bytes_eq_s (local.get $start) (local.get $len) (i32.const 0xE2E4) (i32.const 6))
|
|
(then (return (call $make_char (i32.const 13))))) ;; return
|
|
(if (call $bytes_eq_s (local.get $start) (local.get $len) (i32.const 0xE2EC) (i32.const 4))
|
|
(then (return (call $make_char (i32.const 0))))) ;; null
|
|
;; Unknown name — return first letter
|
|
(return (call $make_char (local.get $first)))))
|
|
;; Single character (non-letter)
|
|
(call $make_char (local.get $first)))
|
|
|
|
;; Compare two byte regions for equality. Returns 1 if equal.
|
|
(func $bytes_eq_s (param $a i32) (param $alen i32) (param $b i32) (param $blen i32) (result i32)
|
|
(local $i i32)
|
|
(if (i32.ne (local.get $alen) (local.get $blen))
|
|
(then (return (i32.const 0))))
|
|
(local.set $i (i32.const 0))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.ge_u (local.get $i) (local.get $alen)))
|
|
(if (i32.ne
|
|
(i32.load8_u (i32.add (local.get $a) (local.get $i)))
|
|
(i32.load8_u (i32.add (local.get $b) (local.get $i))))
|
|
(then (return (i32.const 0))))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $l)))
|
|
(i32.const 1))
|
|
|
|
;; Read a string literal (we've already consumed the opening ").
|
|
;; Read a "..." string literal. Handles escape sequences inside the
|
|
;; literal: \" → " (so a string can contain a literal quote), \\ → \,
|
|
;; \n → newline, \t → tab. Any other \X falls back to literal X
|
|
;; (same fallback the Python/C tiers use). Two-pass: first pass
|
|
;; counts output bytes & locates closing quote, second copies the
|
|
;; payload performing escape conversion.
|
|
(func $read_string (result i32)
|
|
(local $start i32)
|
|
(local $end i32)
|
|
(local $bytes i32)
|
|
(local $s i32)
|
|
(local $src i32)
|
|
(local $dst i32)
|
|
(local $ch i32)
|
|
(local $next i32)
|
|
(local.set $start (global.get $source_ptr))
|
|
(local.set $bytes (i32.const 0))
|
|
;; First pass: scan to closing ", counting decoded output bytes.
|
|
(block $done
|
|
(loop $loop
|
|
(br_if $done (i32.ge_u (global.get $source_ptr) (global.get $source_end)))
|
|
(local.set $ch (i32.load8_u (global.get $source_ptr)))
|
|
(br_if $done (i32.eq (local.get $ch) (i32.const 34))) ;; closing "
|
|
(if (i32.eq (local.get $ch) (i32.const 92)) ;; \
|
|
(then
|
|
(global.set $source_ptr (i32.add (global.get $source_ptr) (i32.const 1)))
|
|
(br_if $done (i32.ge_u (global.get $source_ptr) (global.get $source_end)))))
|
|
(local.set $bytes (i32.add (local.get $bytes) (i32.const 1)))
|
|
(global.set $source_ptr (i32.add (global.get $source_ptr) (i32.const 1)))
|
|
(br $loop)))
|
|
(local.set $end (global.get $source_ptr))
|
|
;; consume closing "
|
|
(if (i32.lt_u (global.get $source_ptr) (global.get $source_end))
|
|
(then (global.set $source_ptr (i32.add (global.get $source_ptr) (i32.const 1)))))
|
|
;; Allocate a string object (same layout as symbol but tag=5).
|
|
(local.set $s (call $alloc (i32.add (i32.const 8) (local.get $bytes))))
|
|
(i32.store (local.get $s) (i32.const 5))
|
|
(i32.store offset=4 (local.get $s) (local.get $bytes))
|
|
;; Second pass: copy with escape conversion.
|
|
(local.set $src (local.get $start))
|
|
(local.set $dst (i32.add (local.get $s) (i32.const 8)))
|
|
(block $cdone
|
|
(loop $cloop
|
|
(br_if $cdone (i32.ge_u (local.get $src) (local.get $end)))
|
|
(local.set $ch (i32.load8_u (local.get $src)))
|
|
(if (i32.eq (local.get $ch) (i32.const 92)) ;; \
|
|
(then
|
|
(local.set $src (i32.add (local.get $src) (i32.const 1)))
|
|
(if (i32.lt_u (local.get $src) (local.get $end))
|
|
(then
|
|
(local.set $next (i32.load8_u (local.get $src)))
|
|
(local.set $ch
|
|
(if (result i32) (i32.eq (local.get $next) (i32.const 110)) (then (i32.const 10)) ;; \n
|
|
(else
|
|
(if (result i32) (i32.eq (local.get $next) (i32.const 116)) (then (i32.const 9)) ;; \t
|
|
(else (local.get $next)))))))))) ;; \" → ", \\ → \, \X → X
|
|
(i32.store8 (local.get $dst) (local.get $ch))
|
|
(local.set $src (i32.add (local.get $src) (i32.const 1)))
|
|
(local.set $dst (i32.add (local.get $dst) (i32.const 1)))
|
|
(br $cloop)))
|
|
(local.get $s))
|
|
|
|
;; ─── Eval ──────────────────────────────────────────────────────
|
|
|
|
(func $eval (param $expr i32) (param $env i32) (result i32)
|
|
(local $op i32)
|
|
(local $head i32)
|
|
(local $rest i32)
|
|
(local $val i32)
|
|
(local $params i32)
|
|
(local $body i32)
|
|
|
|
;; Self-evaluating: fixnum, bignum, rational, immediate, string, char, closure, primitive
|
|
(if (call $is_fixnum (local.get $expr))
|
|
(then (return (local.get $expr))))
|
|
(if (call $is_bignum (local.get $expr))
|
|
(then (return (local.get $expr))))
|
|
(if (call $is_rational (local.get $expr))
|
|
(then (return (local.get $expr))))
|
|
(if (call $is_immediate (local.get $expr))
|
|
(then (return (local.get $expr))))
|
|
(if (call $is_string (local.get $expr))
|
|
(then (return (local.get $expr))))
|
|
(if (call $is_char (local.get $expr))
|
|
(then (return (local.get $expr))))
|
|
(if (call $is_closure (local.get $expr))
|
|
(then (return (local.get $expr))))
|
|
(if (call $is_primitive (local.get $expr))
|
|
(then (return (local.get $expr))))
|
|
|
|
;; Symbol — lookup
|
|
(if (call $is_symbol (local.get $expr))
|
|
(then (return (call $env_lookup (local.get $env) (local.get $expr)))))
|
|
|
|
;; Pair — special form or application
|
|
(if (call $is_pair (local.get $expr))
|
|
(then
|
|
(local.set $head (call $car (local.get $expr)))
|
|
(local.set $rest (call $cdr (local.get $expr)))
|
|
|
|
(if (i32.eq (local.get $head) (global.get $sym_quote))
|
|
(then (return (call $car (local.get $rest)))))
|
|
|
|
(if (i32.eq (local.get $head) (global.get $sym_if))
|
|
(then
|
|
(local.set $val (call $eval (call $car (local.get $rest)) (local.get $env)))
|
|
(if (i32.ne (local.get $val) (global.get $FALSE))
|
|
(then (return_call $eval (call $car (call $cdr (local.get $rest)))
|
|
(local.get $env)))
|
|
(else
|
|
(local.set $rest (call $cdr (call $cdr (local.get $rest))))
|
|
(if (i32.eq (local.get $rest) (global.get $NIL))
|
|
(then (return (global.get $VOID))))
|
|
(return_call $eval (call $car (local.get $rest)) (local.get $env))))))
|
|
|
|
(if (i32.eq (local.get $head) (global.get $sym_lambda))
|
|
(then
|
|
(local.set $params (call $car (local.get $rest)))
|
|
(local.set $body (call $cdr (local.get $rest)))
|
|
(return (call $make_closure (local.get $params) (local.get $body) (local.get $env)))))
|
|
|
|
(if (i32.eq (local.get $head) (global.get $sym_define))
|
|
(then (return (call $eval_define (local.get $rest) (local.get $env)))))
|
|
|
|
(if (i32.eq (local.get $head) (global.get $sym_set))
|
|
(then
|
|
(local.set $val (call $eval (call $car (call $cdr (local.get $rest))) (local.get $env)))
|
|
(call $env_set (local.get $env) (call $car (local.get $rest)) (local.get $val))
|
|
(return (global.get $VOID))))
|
|
|
|
(if (i32.eq (local.get $head) (global.get $sym_begin))
|
|
(then (return_call $eval_begin (local.get $rest) (local.get $env))))
|
|
|
|
(if (i32.eq (local.get $head) (global.get $sym_cond))
|
|
(then (return_call $eval_cond (local.get $rest) (local.get $env))))
|
|
|
|
(if (i32.eq (local.get $head) (global.get $sym_let))
|
|
(then (return_call $eval_let (local.get $rest) (local.get $env))))
|
|
|
|
(if (i32.eq (local.get $head) (global.get $sym_and))
|
|
(then (return_call $eval_and (local.get $rest) (local.get $env))))
|
|
|
|
(if (i32.eq (local.get $head) (global.get $sym_or))
|
|
(then (return_call $eval_or (local.get $rest) (local.get $env))))
|
|
|
|
(if (i32.eq (local.get $head) (global.get $sym_letstar))
|
|
(then (return_call $eval_letstar (local.get $rest) (local.get $env))))
|
|
|
|
(if (i32.eq (local.get $head) (global.get $sym_letrec))
|
|
(then (return_call $eval_letrec (local.get $rest) (local.get $env))))
|
|
|
|
(if (i32.eq (local.get $head) (global.get $sym_when))
|
|
(then (return_call $eval_when (local.get $rest) (local.get $env))))
|
|
|
|
(if (i32.eq (local.get $head) (global.get $sym_unless))
|
|
(then (return_call $eval_unless (local.get $rest) (local.get $env))))
|
|
|
|
(if (i32.eq (local.get $head) (global.get $sym_case))
|
|
(then (return_call $eval_case (local.get $rest) (local.get $env))))
|
|
|
|
;; Function application — apply is the tail call.
|
|
(return_call $apply
|
|
(call $eval (local.get $head) (local.get $env))
|
|
(call $eval_args (local.get $rest) (local.get $env)))))
|
|
|
|
(global.get $VOID))
|
|
|
|
;; (define x v) or (define (f a b) ...)
|
|
(func $eval_define (param $rest i32) (param $env i32) (result i32)
|
|
(local $head i32)
|
|
(local $val i32)
|
|
(local $name i32)
|
|
(local $params i32)
|
|
(local $body i32)
|
|
(local $closure i32)
|
|
(local $bind i32)
|
|
(local $g i32)
|
|
(local.set $head (call $car (local.get $rest)))
|
|
(if (call $is_pair (local.get $head))
|
|
(then
|
|
;; (define (f args...) body)
|
|
(local.set $name (call $car (local.get $head)))
|
|
(local.set $params (call $cdr (local.get $head)))
|
|
(local.set $body (call $cdr (local.get $rest)))
|
|
(local.set $closure (call $make_closure (local.get $params) (local.get $body) (local.get $env))))
|
|
(else
|
|
(local.set $name (local.get $head))
|
|
(local.set $closure (call $eval (call $car (call $cdr (local.get $rest))) (local.get $env)))))
|
|
;; Define in the global env (top frame) so mutual recursion works.
|
|
;; We mutate global_env to prepend a new binding.
|
|
(local.set $bind (call $make_pair (local.get $name) (local.get $closure)))
|
|
(global.set $global_env (call $make_pair (local.get $bind) (global.get $global_env)))
|
|
(global.get $VOID))
|
|
|
|
(func $eval_begin (param $rest i32) (param $env i32) (result i32)
|
|
(local $val i32)
|
|
(local.set $val (global.get $VOID))
|
|
(block $done
|
|
(loop $loop
|
|
(br_if $done (i32.eq (local.get $rest) (global.get $NIL)))
|
|
;; Last expression in a begin is the tail position — TCO it.
|
|
(if (i32.eq (call $cdr (local.get $rest)) (global.get $NIL))
|
|
(then (return_call $eval (call $car (local.get $rest)) (local.get $env))))
|
|
(local.set $val (call $eval (call $car (local.get $rest)) (local.get $env)))
|
|
(local.set $rest (call $cdr (local.get $rest)))
|
|
(br $loop)))
|
|
(local.get $val))
|
|
|
|
(func $eval_cond (param $rest i32) (param $env i32) (result i32)
|
|
(local $clause i32)
|
|
(local $test i32)
|
|
(local $body i32)
|
|
(block $done
|
|
(loop $loop
|
|
(br_if $done (i32.eq (local.get $rest) (global.get $NIL)))
|
|
(local.set $clause (call $car (local.get $rest)))
|
|
(local.set $test (call $car (local.get $clause)))
|
|
(local.set $body (call $cdr (local.get $clause)))
|
|
(if (i32.eq (local.get $test) (global.get $sym_else))
|
|
(then (return_call $eval_begin (local.get $body) (local.get $env))))
|
|
(if (i32.ne (call $eval (local.get $test) (local.get $env)) (global.get $FALSE))
|
|
(then (return_call $eval_begin (local.get $body) (local.get $env))))
|
|
(local.set $rest (call $cdr (local.get $rest)))
|
|
(br $loop)))
|
|
(global.get $VOID))
|
|
|
|
;; (let ((x e) ...) body) — non-recursive form (also supports named let)
|
|
;; Named let: (let name ((x e) ...) body) -> a self-referential procedure.
|
|
(func $eval_let (param $rest i32) (param $env i32) (result i32)
|
|
(local $first i32)
|
|
(local $bindings i32)
|
|
(local $body i32)
|
|
(local $new_env i32)
|
|
(local $b i32)
|
|
(local $sym i32)
|
|
(local $val i32)
|
|
(local $name i32)
|
|
(local $params i32)
|
|
(local $args i32)
|
|
(local $closure i32)
|
|
(local.set $first (call $car (local.get $rest)))
|
|
;; Named let if first arg is a symbol.
|
|
(if (call $is_symbol (local.get $first))
|
|
(then
|
|
(local.set $name (local.get $first))
|
|
(local.set $bindings (call $car (call $cdr (local.get $rest))))
|
|
(local.set $body (call $cdr (call $cdr (local.get $rest))))
|
|
;; Build params list (the binding names) and args list (their inits).
|
|
(local.set $params (call $extract_let_params (local.get $bindings)))
|
|
(local.set $args (call $extract_let_inits (local.get $bindings) (local.get $env)))
|
|
;; Create closure capturing CURRENT env (so the body can refer to name).
|
|
(local.set $closure (call $make_closure (local.get $params) (local.get $body) (local.get $env)))
|
|
;; Bind the closure to name in a fresh local env and patch its env to include itself.
|
|
(local.set $new_env (call $env_define (local.get $env) (local.get $name) (local.get $closure)))
|
|
;; Patch closure.env to the new env so name resolves to it.
|
|
(i32.store offset=12 (local.get $closure) (local.get $new_env))
|
|
(return_call $apply (local.get $closure) (local.get $args))))
|
|
(local.set $bindings (local.get $first))
|
|
(local.set $body (call $cdr (local.get $rest)))
|
|
(local.set $new_env (local.get $env))
|
|
(block $done
|
|
(loop $loop
|
|
(br_if $done (i32.eq (local.get $bindings) (global.get $NIL)))
|
|
(local.set $b (call $car (local.get $bindings)))
|
|
(local.set $sym (call $car (local.get $b)))
|
|
(local.set $val (call $eval (call $car (call $cdr (local.get $b))) (local.get $env)))
|
|
(local.set $new_env (call $env_define (local.get $new_env) (local.get $sym) (local.get $val)))
|
|
(local.set $bindings (call $cdr (local.get $bindings)))
|
|
(br $loop)))
|
|
(return_call $eval_begin (local.get $body) (local.get $new_env)))
|
|
|
|
;; Helper: build params list from let bindings (a list of (sym init)).
|
|
(func $extract_let_params (param $bindings i32) (result i32)
|
|
(local $head i32)
|
|
(local $tail i32)
|
|
(local $new i32)
|
|
(local.set $head (global.get $NIL))
|
|
(local.set $tail (global.get $NIL))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.eq (local.get $bindings) (global.get $NIL)))
|
|
(local.set $new
|
|
(call $make_pair
|
|
(call $car (call $car (local.get $bindings)))
|
|
(global.get $NIL)))
|
|
(if (i32.eq (local.get $head) (global.get $NIL))
|
|
(then (local.set $head (local.get $new))
|
|
(local.set $tail (local.get $new)))
|
|
(else (call $set_cdr (local.get $tail) (local.get $new))
|
|
(local.set $tail (local.get $new))))
|
|
(local.set $bindings (call $cdr (local.get $bindings)))
|
|
(br $l)))
|
|
(local.get $head))
|
|
|
|
;; Helper: evaluate each init expression and return the resulting list.
|
|
(func $extract_let_inits (param $bindings i32) (param $env i32) (result i32)
|
|
(local $head i32)
|
|
(local $tail i32)
|
|
(local $new i32)
|
|
(local.set $head (global.get $NIL))
|
|
(local.set $tail (global.get $NIL))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.eq (local.get $bindings) (global.get $NIL)))
|
|
(local.set $new
|
|
(call $make_pair
|
|
(call $eval (call $car (call $cdr (call $car (local.get $bindings)))) (local.get $env))
|
|
(global.get $NIL)))
|
|
(if (i32.eq (local.get $head) (global.get $NIL))
|
|
(then (local.set $head (local.get $new))
|
|
(local.set $tail (local.get $new)))
|
|
(else (call $set_cdr (local.get $tail) (local.get $new))
|
|
(local.set $tail (local.get $new))))
|
|
(local.set $bindings (call $cdr (local.get $bindings)))
|
|
(br $l)))
|
|
(local.get $head))
|
|
|
|
;; (let* ((x e1) (y e2)) body) — each binding sees previous bindings.
|
|
(func $eval_letstar (param $rest i32) (param $env i32) (result i32)
|
|
(local $bindings i32)
|
|
(local $body i32)
|
|
(local $new_env i32)
|
|
(local $b i32)
|
|
(local $sym i32)
|
|
(local $val i32)
|
|
(local.set $bindings (call $car (local.get $rest)))
|
|
(local.set $body (call $cdr (local.get $rest)))
|
|
(local.set $new_env (local.get $env))
|
|
(block $done
|
|
(loop $loop
|
|
(br_if $done (i32.eq (local.get $bindings) (global.get $NIL)))
|
|
(local.set $b (call $car (local.get $bindings)))
|
|
(local.set $sym (call $car (local.get $b)))
|
|
(local.set $val (call $eval (call $car (call $cdr (local.get $b))) (local.get $new_env)))
|
|
(local.set $new_env (call $env_define (local.get $new_env) (local.get $sym) (local.get $val)))
|
|
(local.set $bindings (call $cdr (local.get $bindings)))
|
|
(br $loop)))
|
|
(return_call $eval_begin (local.get $body) (local.get $new_env)))
|
|
|
|
;; (letrec ((f (lambda ...))) body) — each binding visible to all others.
|
|
;; First create the env with placeholder bindings, then evaluate inits in
|
|
;; the new env (so lambdas capture it), then patch values.
|
|
(func $eval_letrec (param $rest i32) (param $env i32) (result i32)
|
|
(local $bindings i32)
|
|
(local $body i32)
|
|
(local $new_env i32)
|
|
(local $b i32)
|
|
(local $sym i32)
|
|
(local $val i32)
|
|
(local $cur i32)
|
|
(local $bind i32)
|
|
(local.set $bindings (call $car (local.get $rest)))
|
|
(local.set $body (call $cdr (local.get $rest)))
|
|
(local.set $new_env (local.get $env))
|
|
(local.set $cur (local.get $bindings))
|
|
;; Pass 1: bind every name to VOID in the new env.
|
|
(block $done1
|
|
(loop $l1
|
|
(br_if $done1 (i32.eq (local.get $cur) (global.get $NIL)))
|
|
(local.set $b (call $car (local.get $cur)))
|
|
(local.set $sym (call $car (local.get $b)))
|
|
(local.set $new_env (call $env_define (local.get $new_env) (local.get $sym) (global.get $VOID)))
|
|
(local.set $cur (call $cdr (local.get $cur)))
|
|
(br $l1)))
|
|
;; Pass 2: evaluate each init in new_env (so lambdas see each other),
|
|
;; mutate the binding pair's cdr to the real value.
|
|
(local.set $cur (local.get $bindings))
|
|
(block $done2
|
|
(loop $l2
|
|
(br_if $done2 (i32.eq (local.get $cur) (global.get $NIL)))
|
|
(local.set $b (call $car (local.get $cur)))
|
|
(local.set $sym (call $car (local.get $b)))
|
|
(local.set $val (call $eval (call $car (call $cdr (local.get $b))) (local.get $new_env)))
|
|
(call $env_set (local.get $new_env) (local.get $sym) (local.get $val))
|
|
(local.set $cur (call $cdr (local.get $cur)))
|
|
(br $l2)))
|
|
(return_call $eval_begin (local.get $body) (local.get $new_env)))
|
|
|
|
;; (when test body...) -> if test true, eval body, else void
|
|
(func $eval_when (param $rest i32) (param $env i32) (result i32)
|
|
(if (i32.ne (call $eval (call $car (local.get $rest)) (local.get $env)) (global.get $FALSE))
|
|
(then (return_call $eval_begin (call $cdr (local.get $rest)) (local.get $env))))
|
|
(global.get $VOID))
|
|
|
|
;; (unless test body...) -> if test false, eval body, else void
|
|
(func $eval_unless (param $rest i32) (param $env i32) (result i32)
|
|
(if (i32.eq (call $eval (call $car (local.get $rest)) (local.get $env)) (global.get $FALSE))
|
|
(then (return_call $eval_begin (call $cdr (local.get $rest)) (local.get $env))))
|
|
(global.get $VOID))
|
|
|
|
;; (case key ((1 2) "small") ((3 4) "med") (else "big"))
|
|
;; Each clause: (datum-list body) where datum-list is either a list of
|
|
;; literals to match via eqv?, or the symbol `else`.
|
|
(func $eval_case (param $rest i32) (param $env i32) (result i32)
|
|
(local $key i32)
|
|
(local $clauses i32)
|
|
(local $clause i32)
|
|
(local $data i32)
|
|
(local $body i32)
|
|
(local.set $key (call $eval (call $car (local.get $rest)) (local.get $env)))
|
|
(local.set $clauses (call $cdr (local.get $rest)))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.eq (local.get $clauses) (global.get $NIL)))
|
|
(local.set $clause (call $car (local.get $clauses)))
|
|
(local.set $data (call $car (local.get $clause)))
|
|
(local.set $body (call $cdr (local.get $clause)))
|
|
(if (i32.eq (local.get $data) (global.get $sym_else))
|
|
(then (return_call $eval_begin (local.get $body) (local.get $env))))
|
|
;; data is a list of literal values; match via eqv?
|
|
(block $clausedone
|
|
(loop $datal
|
|
(br_if $clausedone (i32.eq (local.get $data) (global.get $NIL)))
|
|
(if (i32.eq (call $car (local.get $data)) (local.get $key))
|
|
(then (return_call $eval_begin (local.get $body) (local.get $env))))
|
|
(local.set $data (call $cdr (local.get $data)))
|
|
(br $datal)))
|
|
(local.set $clauses (call $cdr (local.get $clauses)))
|
|
(br $l)))
|
|
(global.get $VOID))
|
|
|
|
(func $eval_and (param $rest i32) (param $env i32) (result i32)
|
|
(local $val i32)
|
|
(local.set $val (global.get $TRUE))
|
|
(block $done
|
|
(loop $loop
|
|
(br_if $done (i32.eq (local.get $rest) (global.get $NIL)))
|
|
;; Last clause is the tail position — TCO.
|
|
(if (i32.eq (call $cdr (local.get $rest)) (global.get $NIL))
|
|
(then (return_call $eval (call $car (local.get $rest)) (local.get $env))))
|
|
(local.set $val (call $eval (call $car (local.get $rest)) (local.get $env)))
|
|
(if (i32.eq (local.get $val) (global.get $FALSE))
|
|
(then (return (global.get $FALSE))))
|
|
(local.set $rest (call $cdr (local.get $rest)))
|
|
(br $loop)))
|
|
(local.get $val))
|
|
|
|
(func $eval_or (param $rest i32) (param $env i32) (result i32)
|
|
(local $val i32)
|
|
(block $done
|
|
(loop $loop
|
|
(br_if $done (i32.eq (local.get $rest) (global.get $NIL)))
|
|
;; Last clause is the tail position — TCO.
|
|
(if (i32.eq (call $cdr (local.get $rest)) (global.get $NIL))
|
|
(then (return_call $eval (call $car (local.get $rest)) (local.get $env))))
|
|
(local.set $val (call $eval (call $car (local.get $rest)) (local.get $env)))
|
|
(if (i32.ne (local.get $val) (global.get $FALSE))
|
|
(then (return (local.get $val))))
|
|
(local.set $rest (call $cdr (local.get $rest)))
|
|
(br $loop)))
|
|
(global.get $FALSE))
|
|
|
|
;; Evaluate each item in a list, returning a fresh list of values.
|
|
;; Guards against non-pair tails so dotted argument lists (e.g. when a
|
|
;; user mistakenly passes (a . body) as a call) don't dereference into
|
|
;; garbage memory.
|
|
(func $eval_args (param $args i32) (param $env i32) (result i32)
|
|
(local $head i32)
|
|
(local $tail i32)
|
|
(local $new i32)
|
|
(local.set $head (global.get $NIL))
|
|
(local.set $tail (global.get $NIL))
|
|
(block $done
|
|
(loop $loop
|
|
(br_if $done (i32.eqz (call $is_pair (local.get $args))))
|
|
(local.set $new
|
|
(call $make_pair
|
|
(call $eval (call $car (local.get $args)) (local.get $env))
|
|
(global.get $NIL)))
|
|
(if (i32.eq (local.get $head) (global.get $NIL))
|
|
(then
|
|
(local.set $head (local.get $new))
|
|
(local.set $tail (local.get $new)))
|
|
(else
|
|
(call $set_cdr (local.get $tail) (local.get $new))
|
|
(local.set $tail (local.get $new))))
|
|
(local.set $args (call $cdr (local.get $args)))
|
|
(br $loop)))
|
|
(local.get $head))
|
|
|
|
;; Apply a callable to an arg list.
|
|
(func $apply (param $fn i32) (param $args i32) (result i32)
|
|
(local $params i32)
|
|
(local $body i32)
|
|
(local $env i32)
|
|
(local $new_env i32)
|
|
(if (call $is_primitive (local.get $fn))
|
|
(then (return (call $apply_primitive
|
|
(i32.load offset=4 (local.get $fn))
|
|
(local.get $args)))))
|
|
(if (call $is_closure (local.get $fn))
|
|
(then
|
|
(local.set $params (i32.load offset=4 (local.get $fn)))
|
|
(local.set $body (i32.load offset=8 (local.get $fn)))
|
|
(local.set $env (i32.load offset=12 (local.get $fn)))
|
|
(local.set $new_env (call $bind_params (local.get $params) (local.get $args) (local.get $env)))
|
|
;; R7RS internal definitions: leading (define ...) forms in a
|
|
;; lambda body bind locally (letrec*-style) instead of polluting
|
|
;; the global env. hoist_internal_defines returns the env extended
|
|
;; with placeholder VOID bindings and advances $body past them;
|
|
;; then we evaluate each define's value-expression in the new env
|
|
;; (so mutual references work) and env_set the real value.
|
|
(local.set $new_env (call $hoist_internal_defines (local.get $body) (local.get $new_env)))
|
|
(local.set $body (call $strip_leading_defines (local.get $body)))
|
|
(call $fill_internal_defines (i32.load offset=8 (local.get $fn)) (local.get $new_env))
|
|
(return_call $eval_begin (local.get $body) (local.get $new_env))))
|
|
(global.get $VOID))
|
|
|
|
;; Walk leading (define ...) forms in $body; for each, add a placeholder
|
|
;; VOID binding to $env. Returns the extended env. Body is unchanged
|
|
;; (we strip and fill separately to keep iteration simple).
|
|
(func $hoist_internal_defines (param $body i32) (param $env i32) (result i32)
|
|
(local $form i32)
|
|
(local $head i32)
|
|
(local $rest i32)
|
|
(local $name i32)
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.eqz (call $is_pair (local.get $body))))
|
|
(local.set $form (call $car (local.get $body)))
|
|
(br_if $done (i32.eqz (call $is_pair (local.get $form))))
|
|
(br_if $done (i32.ne (call $car (local.get $form)) (global.get $sym_define)))
|
|
(local.set $rest (call $cdr (local.get $form)))
|
|
(local.set $head (call $car (local.get $rest)))
|
|
;; (define name expr) — head is a symbol
|
|
;; (define (f . args) body) — head is a pair, name = car
|
|
(if (call $is_pair (local.get $head))
|
|
(then (local.set $name (call $car (local.get $head))))
|
|
(else (local.set $name (local.get $head))))
|
|
(local.set $env (call $env_define (local.get $env) (local.get $name) (global.get $VOID)))
|
|
(local.set $body (call $cdr (local.get $body)))
|
|
(br $l)))
|
|
(local.get $env))
|
|
|
|
(func $strip_leading_defines (param $body i32) (result i32)
|
|
(local $form i32)
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.eqz (call $is_pair (local.get $body))))
|
|
(local.set $form (call $car (local.get $body)))
|
|
(br_if $done (i32.eqz (call $is_pair (local.get $form))))
|
|
(br_if $done (i32.ne (call $car (local.get $form)) (global.get $sym_define)))
|
|
(local.set $body (call $cdr (local.get $body)))
|
|
(br $l)))
|
|
(local.get $body))
|
|
|
|
;; Second pass of letrec* expansion — evaluate each internal-define's
|
|
;; value-expression in the new env, env_set the real value. Operates
|
|
;; on the ORIGINAL body (with defines still in it) so we know what to
|
|
;; bind. Forms after the leading defines are skipped.
|
|
(func $fill_internal_defines (param $body i32) (param $env i32)
|
|
(local $form i32)
|
|
(local $rest i32)
|
|
(local $head i32)
|
|
(local $name i32)
|
|
(local $value_expr i32)
|
|
(local $params i32)
|
|
(local $closure_body i32)
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.eqz (call $is_pair (local.get $body))))
|
|
(local.set $form (call $car (local.get $body)))
|
|
(br_if $done (i32.eqz (call $is_pair (local.get $form))))
|
|
(br_if $done (i32.ne (call $car (local.get $form)) (global.get $sym_define)))
|
|
(local.set $rest (call $cdr (local.get $form)))
|
|
(local.set $head (call $car (local.get $rest)))
|
|
(if (call $is_pair (local.get $head))
|
|
(then
|
|
;; (define (f . params) body...) → desugar to closure
|
|
(local.set $name (call $car (local.get $head)))
|
|
(local.set $params (call $cdr (local.get $head)))
|
|
(local.set $closure_body (call $cdr (local.get $rest)))
|
|
(drop (call $env_set (local.get $env) (local.get $name)
|
|
(call $make_closure (local.get $params) (local.get $closure_body) (local.get $env)))))
|
|
(else
|
|
(local.set $name (local.get $head))
|
|
(local.set $value_expr (call $car (call $cdr (local.get $rest))))
|
|
(drop (call $env_set (local.get $env) (local.get $name)
|
|
(call $eval (local.get $value_expr) (local.get $env))))))
|
|
(local.set $body (call $cdr (local.get $body)))
|
|
(br $l))))
|
|
|
|
;; Pairwise bind params (a list of symbols, or symbol for rest) to args.
|
|
(func $bind_params (param $params i32) (param $args i32) (param $env i32) (result i32)
|
|
(local $new i32)
|
|
(local.set $new (local.get $env))
|
|
(block $done
|
|
(loop $loop
|
|
(if (call $is_symbol (local.get $params))
|
|
(then
|
|
;; rest binding
|
|
(local.set $new (call $env_define (local.get $new) (local.get $params) (local.get $args)))
|
|
(br $done)))
|
|
(br_if $done (i32.eq (local.get $params) (global.get $NIL)))
|
|
(br_if $done (i32.eq (local.get $args) (global.get $NIL)))
|
|
(local.set $new
|
|
(call $env_define (local.get $new)
|
|
(call $car (local.get $params))
|
|
(call $car (local.get $args))))
|
|
(local.set $params (call $cdr (local.get $params)))
|
|
(local.set $args (call $cdr (local.get $args)))
|
|
(br $loop)))
|
|
(local.get $new))
|
|
|
|
;; ─── Equality helpers ──────────────────────────────────────────
|
|
;; Deep structural equality. Returns TRUE/FALSE immediate.
|
|
(func $equal_p (param $a i32) (param $b i32) (result i32)
|
|
(local $alen i32)
|
|
(local $blen i32)
|
|
(local $i i32)
|
|
(if (i32.eq (local.get $a) (local.get $b))
|
|
(then (return (global.get $TRUE))))
|
|
;; Numeric values compare by value (1/2 == 1/2, fixnum 3 == 6/2).
|
|
(if (i32.and (call $is_number (local.get $a)) (call $is_number (local.get $b)))
|
|
(then
|
|
(if (call $rat_eq (local.get $a) (local.get $b))
|
|
(then (return (global.get $TRUE))))
|
|
(return (global.get $FALSE))))
|
|
(if (call $is_pair (local.get $a))
|
|
(then
|
|
(if (i32.eqz (call $is_pair (local.get $b)))
|
|
(then (return (global.get $FALSE))))
|
|
(if (i32.eq (call $equal_p (call $car (local.get $a)) (call $car (local.get $b))) (global.get $FALSE))
|
|
(then (return (global.get $FALSE))))
|
|
(return (call $equal_p (call $cdr (local.get $a)) (call $cdr (local.get $b))))))
|
|
(if (call $is_string (local.get $a))
|
|
(then
|
|
(if (i32.eqz (call $is_string (local.get $b)))
|
|
(then (return (global.get $FALSE))))
|
|
(local.set $alen (i32.load offset=4 (local.get $a)))
|
|
(local.set $blen (i32.load offset=4 (local.get $b)))
|
|
(if (i32.ne (local.get $alen) (local.get $blen))
|
|
(then (return (global.get $FALSE))))
|
|
(local.set $i (i32.const 0))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.ge_u (local.get $i) (local.get $alen)))
|
|
(if (i32.ne
|
|
(i32.load8_u (i32.add (i32.add (local.get $a) (i32.const 8)) (local.get $i)))
|
|
(i32.load8_u (i32.add (i32.add (local.get $b) (i32.const 8)) (local.get $i))))
|
|
(then (return (global.get $FALSE))))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $l)))
|
|
(return (global.get $TRUE))))
|
|
(if (call $is_char (local.get $a))
|
|
(then
|
|
(if (i32.eqz (call $is_char (local.get $b)))
|
|
(then (return (global.get $FALSE))))
|
|
(if (i32.eq (call $char_code (local.get $a)) (call $char_code (local.get $b)))
|
|
(then (return (global.get $TRUE))))
|
|
(return (global.get $FALSE))))
|
|
;; Fall through: not equal (different types / not pair)
|
|
(global.get $FALSE))
|
|
|
|
;; (append a b) returns a new list with b appended after a.
|
|
(func $append2 (param $a i32) (param $b i32) (result i32)
|
|
(local $head i32)
|
|
(local $tail i32)
|
|
(local $new i32)
|
|
(local $cur i32)
|
|
(local.set $head (global.get $NIL))
|
|
(local.set $tail (global.get $NIL))
|
|
(local.set $cur (local.get $a))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.eqz (call $is_pair (local.get $cur))))
|
|
(local.set $new (call $make_pair (call $car (local.get $cur)) (global.get $NIL)))
|
|
(if (i32.eq (local.get $head) (global.get $NIL))
|
|
(then (local.set $head (local.get $new))
|
|
(local.set $tail (local.get $new)))
|
|
(else (call $set_cdr (local.get $tail) (local.get $new))
|
|
(local.set $tail (local.get $new))))
|
|
(local.set $cur (call $cdr (local.get $cur)))
|
|
(br $l)))
|
|
(if (i32.eq (local.get $head) (global.get $NIL))
|
|
(then (return (local.get $b))))
|
|
(call $set_cdr (local.get $tail) (local.get $b))
|
|
(local.get $head))
|
|
|
|
;; (member key list) — use_equal=1 → equal?; else eq?
|
|
(func $member_eq (param $key i32) (param $list i32) (param $use_equal i32) (result i32)
|
|
(local $cur i32)
|
|
(local $match i32)
|
|
(local.set $cur (local.get $list))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.eqz (call $is_pair (local.get $cur))))
|
|
(if (local.get $use_equal)
|
|
(then
|
|
(local.set $match
|
|
(i32.eq (call $equal_p (local.get $key) (call $car (local.get $cur))) (global.get $TRUE))))
|
|
(else
|
|
(local.set $match
|
|
(i32.eq (local.get $key) (call $car (local.get $cur))))))
|
|
(if (local.get $match)
|
|
(then (return (local.get $cur))))
|
|
(local.set $cur (call $cdr (local.get $cur)))
|
|
(br $l)))
|
|
(global.get $FALSE))
|
|
|
|
;; (assoc key alist) — use_equal=1 → equal? on car; else eq?
|
|
(func $assoc_eq (param $key i32) (param $alist i32) (param $use_equal i32) (result i32)
|
|
(local $cur i32)
|
|
(local $pair i32)
|
|
(local $match i32)
|
|
(local.set $cur (local.get $alist))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.eqz (call $is_pair (local.get $cur))))
|
|
(local.set $pair (call $car (local.get $cur)))
|
|
(if (call $is_pair (local.get $pair))
|
|
(then
|
|
(if (local.get $use_equal)
|
|
(then
|
|
(local.set $match
|
|
(i32.eq (call $equal_p (local.get $key) (call $car (local.get $pair))) (global.get $TRUE))))
|
|
(else
|
|
(local.set $match
|
|
(i32.eq (local.get $key) (call $car (local.get $pair))))))
|
|
(if (local.get $match)
|
|
(then (return (local.get $pair))))))
|
|
(local.set $cur (call $cdr (local.get $cur)))
|
|
(br $l)))
|
|
(global.get $FALSE))
|
|
|
|
;; ─── String / char helpers ─────────────────────────────────────
|
|
|
|
(func $substring_op (param $s i32) (param $start i32) (param $end i32) (result i32)
|
|
(local $out i32)
|
|
(local $len i32)
|
|
(local $i i32)
|
|
(local.set $len (i32.sub (local.get $end) (local.get $start)))
|
|
(local.set $out (call $make_string_raw (local.get $len)))
|
|
(local.set $i (i32.const 0))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.ge_u (local.get $i) (local.get $len)))
|
|
(call $string_set_byte (local.get $out) (local.get $i)
|
|
(call $string_byte (local.get $s) (i32.add (local.get $start) (local.get $i))))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $l)))
|
|
(local.get $out))
|
|
|
|
;; Append all string args together. Args = list of strings.
|
|
(func $string_append_op (param $args i32) (result i32)
|
|
(local $total i32)
|
|
(local $cur i32)
|
|
(local $s i32)
|
|
(local $slen i32)
|
|
(local $out i32)
|
|
(local $i i32)
|
|
(local $pos i32)
|
|
;; Pass 1: total length
|
|
(local.set $total (i32.const 0))
|
|
(local.set $cur (local.get $args))
|
|
(block $d1
|
|
(loop $l1
|
|
(br_if $d1 (i32.eq (local.get $cur) (global.get $NIL)))
|
|
(local.set $s (call $car (local.get $cur)))
|
|
(if (call $is_string (local.get $s))
|
|
(then (local.set $total (i32.add (local.get $total) (call $string_len (local.get $s))))))
|
|
(local.set $cur (call $cdr (local.get $cur)))
|
|
(br $l1)))
|
|
(local.set $out (call $make_string_raw (local.get $total)))
|
|
;; Pass 2: copy bytes
|
|
(local.set $pos (i32.const 0))
|
|
(local.set $cur (local.get $args))
|
|
(block $d2
|
|
(loop $l2
|
|
(br_if $d2 (i32.eq (local.get $cur) (global.get $NIL)))
|
|
(local.set $s (call $car (local.get $cur)))
|
|
(if (call $is_string (local.get $s))
|
|
(then
|
|
(local.set $slen (call $string_len (local.get $s)))
|
|
(local.set $i (i32.const 0))
|
|
(block $d3
|
|
(loop $l3
|
|
(br_if $d3 (i32.ge_u (local.get $i) (local.get $slen)))
|
|
(call $string_set_byte (local.get $out) (i32.add (local.get $pos) (local.get $i))
|
|
(call $string_byte (local.get $s) (local.get $i)))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $l3)))
|
|
(local.set $pos (i32.add (local.get $pos) (local.get $slen)))))
|
|
(local.set $cur (call $cdr (local.get $cur)))
|
|
(br $l2)))
|
|
(local.get $out))
|
|
|
|
(func $string_lt (param $a i32) (param $b i32) (result i32)
|
|
(local $alen i32)
|
|
(local $blen i32)
|
|
(local $i i32)
|
|
(local $minlen i32)
|
|
(local $ca i32)
|
|
(local $cb i32)
|
|
(local.set $alen (call $string_len (local.get $a)))
|
|
(local.set $blen (call $string_len (local.get $b)))
|
|
(local.set $minlen (local.get $alen))
|
|
(if (i32.lt_u (local.get $blen) (local.get $minlen))
|
|
(then (local.set $minlen (local.get $blen))))
|
|
(local.set $i (i32.const 0))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.ge_u (local.get $i) (local.get $minlen)))
|
|
(local.set $ca (call $string_byte (local.get $a) (local.get $i)))
|
|
(local.set $cb (call $string_byte (local.get $b) (local.get $i)))
|
|
(if (i32.lt_u (local.get $ca) (local.get $cb))
|
|
(then (return (global.get $TRUE))))
|
|
(if (i32.gt_u (local.get $ca) (local.get $cb))
|
|
(then (return (global.get $FALSE))))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $l)))
|
|
(if (i32.lt_u (local.get $alen) (local.get $blen))
|
|
(then (return (global.get $TRUE))))
|
|
(global.get $FALSE))
|
|
|
|
;; upper=1 → upcase, upper=0 → downcase
|
|
(func $string_case_op (param $s i32) (param $upper i32) (result i32)
|
|
(local $len i32)
|
|
(local $out i32)
|
|
(local $i i32)
|
|
(local $c i32)
|
|
(local.set $len (call $string_len (local.get $s)))
|
|
(local.set $out (call $make_string_raw (local.get $len)))
|
|
(local.set $i (i32.const 0))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.ge_u (local.get $i) (local.get $len)))
|
|
(local.set $c (call $string_byte (local.get $s) (local.get $i)))
|
|
(if (local.get $upper)
|
|
(then
|
|
(if (i32.and (i32.ge_u (local.get $c) (i32.const 97)) (i32.le_u (local.get $c) (i32.const 122)))
|
|
(then (local.set $c (i32.sub (local.get $c) (i32.const 32))))))
|
|
(else
|
|
(if (i32.and (i32.ge_u (local.get $c) (i32.const 65)) (i32.le_u (local.get $c) (i32.const 90)))
|
|
(then (local.set $c (i32.add (local.get $c) (i32.const 32)))))))
|
|
(call $string_set_byte (local.get $out) (local.get $i) (local.get $c))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $l)))
|
|
(local.get $out))
|
|
|
|
(func $string_to_list (param $s i32) (result i32)
|
|
(local $len i32)
|
|
(local $i i32)
|
|
(local $head i32)
|
|
(local $tail i32)
|
|
(local $new i32)
|
|
(local.set $len (call $string_len (local.get $s)))
|
|
(local.set $head (global.get $NIL))
|
|
(local.set $tail (global.get $NIL))
|
|
(local.set $i (i32.const 0))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.ge_u (local.get $i) (local.get $len)))
|
|
(local.set $new
|
|
(call $make_pair
|
|
(call $make_char (call $string_byte (local.get $s) (local.get $i)))
|
|
(global.get $NIL)))
|
|
(if (i32.eq (local.get $head) (global.get $NIL))
|
|
(then (local.set $head (local.get $new))
|
|
(local.set $tail (local.get $new)))
|
|
(else (call $set_cdr (local.get $tail) (local.get $new))
|
|
(local.set $tail (local.get $new))))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $l)))
|
|
(local.get $head))
|
|
|
|
(func $list_to_string (param $list i32) (result i32)
|
|
(local $len i32)
|
|
(local $cur i32)
|
|
(local $out i32)
|
|
(local $i i32)
|
|
(local $ch i32)
|
|
;; count length
|
|
(local.set $len (i32.const 0))
|
|
(local.set $cur (local.get $list))
|
|
(block $d1
|
|
(loop $l1
|
|
(br_if $d1 (i32.eqz (call $is_pair (local.get $cur))))
|
|
(local.set $len (i32.add (local.get $len) (i32.const 1)))
|
|
(local.set $cur (call $cdr (local.get $cur)))
|
|
(br $l1)))
|
|
(local.set $out (call $make_string_raw (local.get $len)))
|
|
(local.set $cur (local.get $list))
|
|
(local.set $i (i32.const 0))
|
|
(block $d2
|
|
(loop $l2
|
|
(br_if $d2 (i32.eqz (call $is_pair (local.get $cur))))
|
|
(local.set $ch (call $car (local.get $cur)))
|
|
(if (call $is_char (local.get $ch))
|
|
(then (call $string_set_byte (local.get $out) (local.get $i) (call $char_code (local.get $ch))))
|
|
(else (call $string_set_byte (local.get $out) (local.get $i) (call $fixnum_val (local.get $ch)))))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(local.set $cur (call $cdr (local.get $cur)))
|
|
(br $l2)))
|
|
(local.get $out))
|
|
|
|
(func $symbol_to_string (param $sym i32) (result i32)
|
|
(local $len i32)
|
|
(local $out i32)
|
|
(local $i i32)
|
|
(local.set $len (i32.load offset=4 (local.get $sym)))
|
|
(local.set $out (call $make_string_raw (local.get $len)))
|
|
(local.set $i (i32.const 0))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.ge_u (local.get $i) (local.get $len)))
|
|
(call $string_set_byte (local.get $out) (local.get $i)
|
|
(i32.load8_u (i32.add (i32.add (local.get $sym) (i32.const 8)) (local.get $i))))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $l)))
|
|
(local.get $out))
|
|
|
|
(func $make_string_filled (param $n i32) (param $code i32) (result i32)
|
|
(local $out i32)
|
|
(local $i i32)
|
|
(local.set $out (call $make_string_raw (local.get $n)))
|
|
(local.set $i (i32.const 0))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.ge_u (local.get $i) (local.get $n)))
|
|
(call $string_set_byte (local.get $out) (local.get $i) (local.get $code))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $l)))
|
|
(local.get $out))
|
|
|
|
;; Convert a signed i32 to a freshly-allocated string.
|
|
(func $number_to_string (param $n i32) (result i32)
|
|
(local $buf i32)
|
|
(local $neg i32)
|
|
(local $i i32)
|
|
(local $out i32)
|
|
(local $j i32)
|
|
(local.set $buf (i32.const 0x200)) ;; 32-byte scratch
|
|
(local.set $neg (i32.const 0))
|
|
(if (i32.lt_s (local.get $n) (i32.const 0))
|
|
(then
|
|
(local.set $neg (i32.const 1))
|
|
(local.set $n (i32.sub (i32.const 0) (local.get $n)))))
|
|
(local.set $i (i32.const 0))
|
|
(if (i32.eqz (local.get $n))
|
|
(then
|
|
(i32.store8 (i32.add (local.get $buf) (local.get $i)) (i32.const 48))
|
|
(local.set $i (i32.const 1)))
|
|
(else
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.eqz (local.get $n)))
|
|
(i32.store8 (i32.add (local.get $buf) (local.get $i))
|
|
(i32.add (i32.const 48) (i32.rem_u (local.get $n) (i32.const 10))))
|
|
(local.set $n (i32.div_u (local.get $n) (i32.const 10)))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $l)))))
|
|
(local.set $out (call $make_string_raw
|
|
(i32.add (local.get $i)
|
|
(if (result i32) (local.get $neg) (then (i32.const 1)) (else (i32.const 0))))))
|
|
(local.set $j (i32.const 0))
|
|
(if (local.get $neg)
|
|
(then
|
|
(call $string_set_byte (local.get $out) (i32.const 0) (i32.const 45))
|
|
(local.set $j (i32.const 1))))
|
|
(block $done2
|
|
(loop $l2
|
|
(br_if $done2 (i32.eqz (local.get $i)))
|
|
(local.set $i (i32.sub (local.get $i) (i32.const 1)))
|
|
(call $string_set_byte (local.get $out) (local.get $j)
|
|
(i32.load8_u (i32.add (local.get $buf) (local.get $i))))
|
|
(local.set $j (i32.add (local.get $j) (i32.const 1)))
|
|
(br $l2)))
|
|
(local.get $out))
|
|
|
|
;; Parse a string as integer. Returns FALSE on parse failure.
|
|
(func $string_to_number (param $s i32) (result i32)
|
|
(local $len i32)
|
|
(local $i i32)
|
|
(local $start i32)
|
|
(local $neg i32)
|
|
(local $n i32)
|
|
(local $c i32)
|
|
(local.set $len (call $string_len (local.get $s)))
|
|
(if (i32.eqz (local.get $len)) (then (return (global.get $FALSE))))
|
|
(local.set $start (i32.const 0))
|
|
(local.set $neg (i32.const 0))
|
|
(local.set $c (call $string_byte (local.get $s) (i32.const 0)))
|
|
(if (i32.eq (local.get $c) (i32.const 45))
|
|
(then
|
|
(local.set $neg (i32.const 1))
|
|
(local.set $start (i32.const 1))))
|
|
(if (i32.eq (local.get $c) (i32.const 43))
|
|
(then (local.set $start (i32.const 1))))
|
|
(if (i32.ge_u (local.get $start) (local.get $len)) (then (return (global.get $FALSE))))
|
|
(local.set $n (i32.const 0))
|
|
(local.set $i (local.get $start))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.ge_u (local.get $i) (local.get $len)))
|
|
(local.set $c (call $string_byte (local.get $s) (local.get $i)))
|
|
(if (i32.eqz (call $is_digit (local.get $c)))
|
|
(then (return (global.get $FALSE))))
|
|
(local.set $n (i32.add (i32.mul (local.get $n) (i32.const 10))
|
|
(i32.sub (local.get $c) (i32.const 48))))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $l)))
|
|
(if (local.get $neg)
|
|
(then (local.set $n (i32.sub (i32.const 0) (local.get $n)))))
|
|
(call $make_fixnum (local.get $n)))
|
|
|
|
;; Returns TRUE if needle is a substring of haystack, else FALSE.
|
|
(func $string_contains_p (param $hay i32) (param $needle i32) (result i32)
|
|
(local $hlen i32)
|
|
(local $nlen i32)
|
|
(local $i i32)
|
|
(local $j i32)
|
|
(local $matched i32)
|
|
(local.set $hlen (call $string_len (local.get $hay)))
|
|
(local.set $nlen (call $string_len (local.get $needle)))
|
|
(if (i32.eqz (local.get $nlen)) (then (return (global.get $TRUE))))
|
|
(if (i32.gt_u (local.get $nlen) (local.get $hlen)) (then (return (global.get $FALSE))))
|
|
(local.set $i (i32.const 0))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.gt_u (i32.add (local.get $i) (local.get $nlen)) (local.get $hlen)))
|
|
(local.set $j (i32.const 0))
|
|
(local.set $matched (i32.const 1))
|
|
(block $inner
|
|
(loop $il
|
|
(br_if $inner (i32.ge_u (local.get $j) (local.get $nlen)))
|
|
(if (i32.ne
|
|
(call $string_byte (local.get $hay) (i32.add (local.get $i) (local.get $j)))
|
|
(call $string_byte (local.get $needle) (local.get $j)))
|
|
(then (local.set $matched (i32.const 0)) (br $inner)))
|
|
(local.set $j (i32.add (local.get $j) (i32.const 1)))
|
|
(br $il)))
|
|
(if (local.get $matched) (then (return (global.get $TRUE))))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $l)))
|
|
(global.get $FALSE))
|
|
|
|
;; (string-join '("a" "b" "c") "-") → "a-b-c"
|
|
(func $string_join_op (param $list i32) (param $sep i32) (result i32)
|
|
(local $cur i32)
|
|
(local $total i32)
|
|
(local $s i32)
|
|
(local $slen i32)
|
|
(local $seplen i32)
|
|
(local $out i32)
|
|
(local $pos i32)
|
|
(local $i i32)
|
|
(local $first i32)
|
|
(local.set $seplen (call $string_len (local.get $sep)))
|
|
(local.set $total (i32.const 0))
|
|
(local.set $cur (local.get $list))
|
|
(local.set $first (i32.const 1))
|
|
(block $d1
|
|
(loop $l1
|
|
(br_if $d1 (i32.eqz (call $is_pair (local.get $cur))))
|
|
(local.set $s (call $car (local.get $cur)))
|
|
(if (call $is_string (local.get $s))
|
|
(then
|
|
(if (i32.eqz (local.get $first))
|
|
(then (local.set $total (i32.add (local.get $total) (local.get $seplen)))))
|
|
(local.set $total (i32.add (local.get $total) (call $string_len (local.get $s))))
|
|
(local.set $first (i32.const 0))))
|
|
(local.set $cur (call $cdr (local.get $cur)))
|
|
(br $l1)))
|
|
(local.set $out (call $make_string_raw (local.get $total)))
|
|
(local.set $pos (i32.const 0))
|
|
(local.set $first (i32.const 1))
|
|
(local.set $cur (local.get $list))
|
|
(block $d2
|
|
(loop $l2
|
|
(br_if $d2 (i32.eqz (call $is_pair (local.get $cur))))
|
|
(local.set $s (call $car (local.get $cur)))
|
|
(if (call $is_string (local.get $s))
|
|
(then
|
|
(if (i32.eqz (local.get $first))
|
|
(then
|
|
;; copy sep
|
|
(local.set $i (i32.const 0))
|
|
(block $d3
|
|
(loop $l3
|
|
(br_if $d3 (i32.ge_u (local.get $i) (local.get $seplen)))
|
|
(call $string_set_byte (local.get $out) (i32.add (local.get $pos) (local.get $i))
|
|
(call $string_byte (local.get $sep) (local.get $i)))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $l3)))
|
|
(local.set $pos (i32.add (local.get $pos) (local.get $seplen)))))
|
|
;; copy s
|
|
(local.set $slen (call $string_len (local.get $s)))
|
|
(local.set $i (i32.const 0))
|
|
(block $d4
|
|
(loop $l4
|
|
(br_if $d4 (i32.ge_u (local.get $i) (local.get $slen)))
|
|
(call $string_set_byte (local.get $out) (i32.add (local.get $pos) (local.get $i))
|
|
(call $string_byte (local.get $s) (local.get $i)))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $l4)))
|
|
(local.set $pos (i32.add (local.get $pos) (local.get $slen)))
|
|
(local.set $first (i32.const 0))))
|
|
(local.set $cur (call $cdr (local.get $cur)))
|
|
(br $l2)))
|
|
(local.get $out))
|
|
|
|
;; ─── Vector / hashtable helpers ────────────────────────────────
|
|
|
|
(func $list_to_vector_op (param $list i32) (result i32)
|
|
(local $len i32)
|
|
(local $cur i32)
|
|
(local $v i32)
|
|
(local $i i32)
|
|
(local.set $len (i32.const 0))
|
|
(local.set $cur (local.get $list))
|
|
(block $d1
|
|
(loop $l1
|
|
(br_if $d1 (i32.eqz (call $is_pair (local.get $cur))))
|
|
(local.set $len (i32.add (local.get $len) (i32.const 1)))
|
|
(local.set $cur (call $cdr (local.get $cur)))
|
|
(br $l1)))
|
|
(local.set $v (call $make_vector_raw (local.get $len)))
|
|
(local.set $cur (local.get $list))
|
|
(local.set $i (i32.const 0))
|
|
(block $d2
|
|
(loop $l2
|
|
(br_if $d2 (i32.eqz (call $is_pair (local.get $cur))))
|
|
(call $vector_put (local.get $v) (local.get $i) (call $car (local.get $cur)))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(local.set $cur (call $cdr (local.get $cur)))
|
|
(br $l2)))
|
|
(local.get $v))
|
|
|
|
(func $vector_to_list_op (param $v i32) (result i32)
|
|
(local $len i32)
|
|
(local $i i32)
|
|
(local $head i32)
|
|
(local $tail i32)
|
|
(local $new i32)
|
|
(local.set $len (call $vector_len (local.get $v)))
|
|
(local.set $head (global.get $NIL))
|
|
(local.set $tail (global.get $NIL))
|
|
(local.set $i (i32.const 0))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.ge_u (local.get $i) (local.get $len)))
|
|
(local.set $new (call $make_pair (call $vector_get (local.get $v) (local.get $i)) (global.get $NIL)))
|
|
(if (i32.eq (local.get $head) (global.get $NIL))
|
|
(then (local.set $head (local.get $new))
|
|
(local.set $tail (local.get $new)))
|
|
(else (call $set_cdr (local.get $tail) (local.get $new))
|
|
(local.set $tail (local.get $new))))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $l)))
|
|
(local.get $head))
|
|
|
|
(func $make_vector_filled (param $n i32) (param $init i32) (result i32)
|
|
(local $v i32)
|
|
(local $i i32)
|
|
(local.set $v (call $make_vector_raw (local.get $n)))
|
|
(local.set $i (i32.const 0))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.ge_u (local.get $i) (local.get $n)))
|
|
(call $vector_put (local.get $v) (local.get $i) (local.get $init))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $l)))
|
|
(local.get $v))
|
|
|
|
(func $ht_keys_op (param $h i32) (result i32)
|
|
(local $cur i32)
|
|
(local $head i32)
|
|
(local $tail i32)
|
|
(local $new i32)
|
|
(local.set $cur (call $ht_alist (local.get $h)))
|
|
(local.set $head (global.get $NIL))
|
|
(local.set $tail (global.get $NIL))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.eqz (call $is_pair (local.get $cur))))
|
|
(local.set $new (call $make_pair (call $car (call $car (local.get $cur))) (global.get $NIL)))
|
|
(if (i32.eq (local.get $head) (global.get $NIL))
|
|
(then (local.set $head (local.get $new))
|
|
(local.set $tail (local.get $new)))
|
|
(else (call $set_cdr (local.get $tail) (local.get $new))
|
|
(local.set $tail (local.get $new))))
|
|
(local.set $cur (call $cdr (local.get $cur)))
|
|
(br $l)))
|
|
(local.get $head))
|
|
|
|
(func $ht_values_op (param $h i32) (result i32)
|
|
(local $cur i32)
|
|
(local $head i32)
|
|
(local $tail i32)
|
|
(local $new i32)
|
|
(local.set $cur (call $ht_alist (local.get $h)))
|
|
(local.set $head (global.get $NIL))
|
|
(local.set $tail (global.get $NIL))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.eqz (call $is_pair (local.get $cur))))
|
|
(local.set $new (call $make_pair (call $cdr (call $car (local.get $cur))) (global.get $NIL)))
|
|
(if (i32.eq (local.get $head) (global.get $NIL))
|
|
(then (local.set $head (local.get $new))
|
|
(local.set $tail (local.get $new)))
|
|
(else (call $set_cdr (local.get $tail) (local.get $new))
|
|
(local.set $tail (local.get $new))))
|
|
(local.set $cur (call $cdr (local.get $cur)))
|
|
(br $l)))
|
|
(local.get $head))
|
|
|
|
;; ─── Bend dispatch ─────────────────────────────────────────────
|
|
;; Send a payload string to the configured gpu-worker via host XHR.
|
|
;; Response is written into the scratch area at 0x40000 (64 KB), then
|
|
;; copied into a freshly-allocated lumbda string.
|
|
(func $bend_call_op (param $payload i32) (result i32)
|
|
(local $resp_buf i32)
|
|
(local $resp_len i32)
|
|
(local $payload_ptr i32)
|
|
(local $payload_len i32)
|
|
(local $out i32)
|
|
(local $i i32)
|
|
(if (i32.eqz (call $is_string (local.get $payload)))
|
|
(then (return (global.get $FALSE))))
|
|
(local.set $resp_buf (i32.const 0x40000))
|
|
(local.set $payload_ptr (i32.add (local.get $payload) (i32.const 8)))
|
|
(local.set $payload_len (call $string_len (local.get $payload)))
|
|
(local.set $resp_len
|
|
(call $js_bend_call (local.get $payload_ptr) (local.get $payload_len) (local.get $resp_buf)))
|
|
(local.set $out (call $make_string_raw (local.get $resp_len)))
|
|
(local.set $i (i32.const 0))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.ge_u (local.get $i) (local.get $resp_len)))
|
|
(call $string_set_byte (local.get $out) (local.get $i)
|
|
(i32.load8_u (i32.add (local.get $resp_buf) (local.get $i))))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $l)))
|
|
(local.get $out))
|
|
|
|
;; ─── Numeric promotion helpers ────────────────────────────────
|
|
;; These take any two Values (fixnum / bignum / rational) and return
|
|
;; the result as the narrowest representation that holds it.
|
|
|
|
(func $num_add (param $a i32) (param $b i32) (result i32)
|
|
(local $av i64)
|
|
(local $bv i64)
|
|
(local $sum i64)
|
|
(if (i32.or (call $is_rational (local.get $a)) (call $is_rational (local.get $b)))
|
|
(then (return (call $rat_add (local.get $a) (local.get $b)))))
|
|
(if (i32.or (call $is_bignum (local.get $a)) (call $is_bignum (local.get $b)))
|
|
(then (return (call $bn_add (call $to_bignum (local.get $a))
|
|
(call $to_bignum (local.get $b))))))
|
|
(local.set $av (i64.extend_i32_s (call $fixnum_val (local.get $a))))
|
|
(local.set $bv (i64.extend_i32_s (call $fixnum_val (local.get $b))))
|
|
(local.set $sum (i64.add (local.get $av) (local.get $bv)))
|
|
;; Fixnum range is [-2^30, 2^30 - 1].
|
|
(if (i32.and
|
|
(i64.ge_s (local.get $sum) (i64.const -1073741824))
|
|
(i64.lt_s (local.get $sum) (i64.const 1073741824)))
|
|
(then (return (call $make_fixnum (i32.wrap_i64 (local.get $sum))))))
|
|
(call $bn_add (call $to_bignum (local.get $a)) (call $to_bignum (local.get $b))))
|
|
|
|
(func $num_sub (param $a i32) (param $b i32) (result i32)
|
|
(local $av i64)
|
|
(local $bv i64)
|
|
(local $diff i64)
|
|
(if (i32.or (call $is_rational (local.get $a)) (call $is_rational (local.get $b)))
|
|
(then (return (call $rat_sub (local.get $a) (local.get $b)))))
|
|
(if (i32.or (call $is_bignum (local.get $a)) (call $is_bignum (local.get $b)))
|
|
(then (return (call $bn_sub (call $to_bignum (local.get $a))
|
|
(call $to_bignum (local.get $b))))))
|
|
(local.set $av (i64.extend_i32_s (call $fixnum_val (local.get $a))))
|
|
(local.set $bv (i64.extend_i32_s (call $fixnum_val (local.get $b))))
|
|
(local.set $diff (i64.sub (local.get $av) (local.get $bv)))
|
|
(if (i32.and
|
|
(i64.ge_s (local.get $diff) (i64.const -1073741824))
|
|
(i64.lt_s (local.get $diff) (i64.const 1073741824)))
|
|
(then (return (call $make_fixnum (i32.wrap_i64 (local.get $diff))))))
|
|
(call $bn_sub (call $to_bignum (local.get $a)) (call $to_bignum (local.get $b))))
|
|
|
|
(func $num_mul (param $a i32) (param $b i32) (result i32)
|
|
(local $av i64)
|
|
(local $bv i64)
|
|
(local $prod i64)
|
|
(if (i32.or (call $is_rational (local.get $a)) (call $is_rational (local.get $b)))
|
|
(then (return (call $rat_mul (local.get $a) (local.get $b)))))
|
|
(if (i32.or (call $is_bignum (local.get $a)) (call $is_bignum (local.get $b)))
|
|
(then (return (call $bn_mul (call $to_bignum (local.get $a))
|
|
(call $to_bignum (local.get $b))))))
|
|
(local.set $av (i64.extend_i32_s (call $fixnum_val (local.get $a))))
|
|
(local.set $bv (i64.extend_i32_s (call $fixnum_val (local.get $b))))
|
|
(local.set $prod (i64.mul (local.get $av) (local.get $bv)))
|
|
(if (i32.and
|
|
(i64.ge_s (local.get $prod) (i64.const -1073741824))
|
|
(i64.lt_s (local.get $prod) (i64.const 1073741824)))
|
|
(then (return (call $make_fixnum (i32.wrap_i64 (local.get $prod))))))
|
|
(call $bn_mul (call $to_bignum (local.get $a)) (call $to_bignum (local.get $b))))
|
|
|
|
;; Compare two number Values. Returns -1, 0, or +1.
|
|
(func $num_cmp (param $a i32) (param $b i32) (result i32)
|
|
(local $av i32)
|
|
(local $bv i32)
|
|
(local $abn i32)
|
|
(local $bbn i32)
|
|
(local $diff i32)
|
|
(if (i32.or (call $is_rational (local.get $a)) (call $is_rational (local.get $b)))
|
|
(then
|
|
(if (call $rat_eq (local.get $a) (local.get $b))
|
|
(then (return (i32.const 0))))
|
|
(if (call $rat_lt (local.get $a) (local.get $b))
|
|
(then (return (i32.const -1))))
|
|
(return (i32.const 1))))
|
|
(if (i32.or (call $is_bignum (local.get $a)) (call $is_bignum (local.get $b)))
|
|
(then
|
|
(local.set $abn (call $to_bignum (local.get $a)))
|
|
(local.set $bbn (call $to_bignum (local.get $b)))
|
|
(if (i32.ne (call $bn_sign (local.get $abn)) (call $bn_sign (local.get $bbn)))
|
|
(then
|
|
(if (call $bn_sign (local.get $abn)) (then (return (i32.const -1))))
|
|
(return (i32.const 1))))
|
|
(local.set $diff (call $bn_cmp_abs (local.get $abn) (local.get $bbn)))
|
|
(if (call $bn_sign (local.get $abn))
|
|
(then (return (i32.sub (i32.const 0) (local.get $diff)))))
|
|
(return (local.get $diff))))
|
|
(local.set $av (call $fixnum_val (local.get $a)))
|
|
(local.set $bv (call $fixnum_val (local.get $b)))
|
|
(if (i32.eq (local.get $av) (local.get $bv)) (then (return (i32.const 0))))
|
|
(if (i32.lt_s (local.get $av) (local.get $bv)) (then (return (i32.const -1))))
|
|
(i32.const 1))
|
|
|
|
;; ─── Primitives ────────────────────────────────────────────────
|
|
(func $apply_primitive (param $id i32) (param $args i32) (result i32)
|
|
(local $a i32)
|
|
(local $b i32)
|
|
(local $sum i32)
|
|
(local $cur i32)
|
|
(local $vmin i32)
|
|
(local $vmax i32)
|
|
(local $base i32)
|
|
(local $exp_n i32)
|
|
(local $result i32)
|
|
(local $rev i32)
|
|
(local $idx i32)
|
|
(local $idxt i32)
|
|
(local $any_rat i32)
|
|
(local $any_rat2 i32)
|
|
(local $any_rat3 i32)
|
|
|
|
;; Fetch first 2 args (most prims use 1 or 2). Defaults to fixnum 0.
|
|
(local.set $a (call $make_fixnum (i32.const 0)))
|
|
(local.set $b (call $make_fixnum (i32.const 0)))
|
|
(if (i32.ne (local.get $args) (global.get $NIL))
|
|
(then
|
|
(local.set $a (call $car (local.get $args)))
|
|
(if (i32.ne (call $cdr (local.get $args)) (global.get $NIL))
|
|
(then (local.set $b (call $car (call $cdr (local.get $args))))))))
|
|
|
|
;; + — variadic; num_add picks the right representation per step.
|
|
(if (i32.eq (local.get $id) (i32.const 1))
|
|
(then
|
|
(local.set $a (call $make_fixnum (i32.const 0)))
|
|
(local.set $cur (local.get $args))
|
|
(block $done
|
|
(loop $loop
|
|
(br_if $done (i32.eq (local.get $cur) (global.get $NIL)))
|
|
(local.set $a (call $num_add (local.get $a) (call $car (local.get $cur))))
|
|
(local.set $cur (call $cdr (local.get $cur)))
|
|
(br $loop)))
|
|
(return (local.get $a))))
|
|
|
|
;; - — variadic; num_sub handles fixnum/bignum/rational promotion.
|
|
(if (i32.eq (local.get $id) (i32.const 2))
|
|
(then
|
|
;; Unary negate: 0 - a.
|
|
(if (i32.eq (call $cdr (local.get $args)) (global.get $NIL))
|
|
(then
|
|
(return (call $num_sub (call $make_fixnum (i32.const 0)) (local.get $a)))))
|
|
(local.set $cur (call $cdr (local.get $args)))
|
|
(block $done
|
|
(loop $loop
|
|
(br_if $done (i32.eq (local.get $cur) (global.get $NIL)))
|
|
(local.set $a (call $num_sub (local.get $a) (call $car (local.get $cur))))
|
|
(local.set $cur (call $cdr (local.get $cur)))
|
|
(br $loop)))
|
|
(return (local.get $a))))
|
|
|
|
;; * — variadic; num_mul promotes to bignum on overflow.
|
|
(if (i32.eq (local.get $id) (i32.const 3))
|
|
(then
|
|
(local.set $a (call $make_fixnum (i32.const 1)))
|
|
(local.set $cur (local.get $args))
|
|
(block $done
|
|
(loop $loop
|
|
(br_if $done (i32.eq (local.get $cur) (global.get $NIL)))
|
|
(local.set $a (call $num_mul (local.get $a) (call $car (local.get $cur))))
|
|
(local.set $cur (call $cdr (local.get $cur)))
|
|
(br $loop)))
|
|
(return (local.get $a))))
|
|
|
|
;; / — promotes int/int to rational when the result isn't integral
|
|
;; (matches python lumbda and the C tier's recent fix).
|
|
(if (i32.eq (local.get $id) (i32.const 4))
|
|
(then
|
|
(if (i32.or (call $is_rational (local.get $a)) (call $is_rational (local.get $b)))
|
|
(then (return (call $rat_div (local.get $a) (local.get $b)))))
|
|
(return (call $make_rational (call $fixnum_val (local.get $a))
|
|
(call $fixnum_val (local.get $b))))))
|
|
|
|
;; = / < / > / <= / >= — num_cmp gives -1/0/+1 across all number kinds.
|
|
(if (i32.eq (local.get $id) (i32.const 5))
|
|
(then
|
|
(if (i32.eqz (call $num_cmp (local.get $a) (local.get $b)))
|
|
(then (return (global.get $TRUE)))
|
|
(else (return (global.get $FALSE))))))
|
|
(if (i32.eq (local.get $id) (i32.const 6))
|
|
(then
|
|
(if (i32.lt_s (call $num_cmp (local.get $a) (local.get $b)) (i32.const 0))
|
|
(then (return (global.get $TRUE)))
|
|
(else (return (global.get $FALSE))))))
|
|
(if (i32.eq (local.get $id) (i32.const 7))
|
|
(then
|
|
(if (i32.gt_s (call $num_cmp (local.get $a) (local.get $b)) (i32.const 0))
|
|
(then (return (global.get $TRUE)))
|
|
(else (return (global.get $FALSE))))))
|
|
(if (i32.eq (local.get $id) (i32.const 8))
|
|
(then
|
|
(if (i32.le_s (call $num_cmp (local.get $a) (local.get $b)) (i32.const 0))
|
|
(then (return (global.get $TRUE)))
|
|
(else (return (global.get $FALSE))))))
|
|
(if (i32.eq (local.get $id) (i32.const 9))
|
|
(then
|
|
(if (i32.ge_s (call $num_cmp (local.get $a) (local.get $b)) (i32.const 0))
|
|
(then (return (global.get $TRUE)))
|
|
(else (return (global.get $FALSE))))))
|
|
|
|
;; cons
|
|
(if (i32.eq (local.get $id) (i32.const 10))
|
|
(then (return (call $make_pair (local.get $a) (local.get $b)))))
|
|
|
|
;; car
|
|
(if (i32.eq (local.get $id) (i32.const 11))
|
|
(then (return (call $car (local.get $a)))))
|
|
|
|
;; cdr
|
|
(if (i32.eq (local.get $id) (i32.const 12))
|
|
(then (return (call $cdr (local.get $a)))))
|
|
|
|
;; null?
|
|
(if (i32.eq (local.get $id) (i32.const 13))
|
|
(then
|
|
(if (i32.eq (local.get $a) (global.get $NIL))
|
|
(then (return (global.get $TRUE)))
|
|
(else (return (global.get $FALSE))))))
|
|
|
|
;; pair?
|
|
(if (i32.eq (local.get $id) (i32.const 14))
|
|
(then
|
|
(if (call $is_pair (local.get $a))
|
|
(then (return (global.get $TRUE)))
|
|
(else (return (global.get $FALSE))))))
|
|
|
|
;; eq?
|
|
(if (i32.eq (local.get $id) (i32.const 15))
|
|
(then
|
|
(if (i32.eq (local.get $a) (local.get $b))
|
|
(then (return (global.get $TRUE)))
|
|
(else (return (global.get $FALSE))))))
|
|
|
|
;; not
|
|
(if (i32.eq (local.get $id) (i32.const 16))
|
|
(then
|
|
(if (i32.eq (local.get $a) (global.get $FALSE))
|
|
(then (return (global.get $TRUE)))
|
|
(else (return (global.get $FALSE))))))
|
|
|
|
;; display
|
|
(if (i32.eq (local.get $id) (i32.const 17))
|
|
(then (call $print_value (local.get $a)) (return (global.get $VOID))))
|
|
|
|
;; newline
|
|
(if (i32.eq (local.get $id) (i32.const 18))
|
|
(then (call $out_char (i32.const 10)) (return (global.get $VOID))))
|
|
|
|
;; print
|
|
(if (i32.eq (local.get $id) (i32.const 19))
|
|
(then
|
|
(call $print_value (local.get $a))
|
|
(call $out_char (i32.const 10))
|
|
(return (global.get $VOID))))
|
|
|
|
;; list
|
|
(if (i32.eq (local.get $id) (i32.const 20))
|
|
(then (return (local.get $args))))
|
|
|
|
;; length
|
|
(if (i32.eq (local.get $id) (i32.const 21))
|
|
(then
|
|
(local.set $sum (i32.const 0))
|
|
(local.set $cur (local.get $a))
|
|
(block $done
|
|
(loop $loop
|
|
(br_if $done (i32.eqz (call $is_pair (local.get $cur))))
|
|
(local.set $sum (i32.add (local.get $sum) (i32.const 1)))
|
|
(local.set $cur (call $cdr (local.get $cur)))
|
|
(br $loop)))
|
|
(return (call $make_fixnum (local.get $sum)))))
|
|
|
|
;; abs
|
|
(if (i32.eq (local.get $id) (i32.const 22))
|
|
(then
|
|
(local.set $sum (call $fixnum_val (local.get $a)))
|
|
(if (i32.lt_s (local.get $sum) (i32.const 0))
|
|
(then (local.set $sum (i32.sub (i32.const 0) (local.get $sum)))))
|
|
(return (call $make_fixnum (local.get $sum)))))
|
|
|
|
;; modulo — R7RS: result has the sign of the divisor.
|
|
;; i32.rem_s by itself gives remainder semantics (sign of dividend);
|
|
;; we add the divisor if the rem and divisor disagree on sign.
|
|
(if (i32.eq (local.get $id) (i32.const 23))
|
|
(then
|
|
(local.set $sum (i32.rem_s (call $fixnum_val (local.get $a))
|
|
(call $fixnum_val (local.get $b))))
|
|
(if (i32.and
|
|
(i32.ne (local.get $sum) (i32.const 0))
|
|
(i32.lt_s (i32.mul (local.get $sum) (call $fixnum_val (local.get $b)))
|
|
(i32.const 0)))
|
|
(then (local.set $sum (i32.add (local.get $sum) (call $fixnum_val (local.get $b))))))
|
|
(return (call $make_fixnum (local.get $sum)))))
|
|
|
|
;; zero?
|
|
(if (i32.eq (local.get $id) (i32.const 24))
|
|
(then
|
|
(if (i32.eqz (call $fixnum_val (local.get $a)))
|
|
(then (return (global.get $TRUE)))
|
|
(else (return (global.get $FALSE))))))
|
|
|
|
;; quotient (25): integer truncating division
|
|
(if (i32.eq (local.get $id) (i32.const 25))
|
|
(then
|
|
(return (call $make_fixnum (i32.div_s (call $fixnum_val (local.get $a))
|
|
(call $fixnum_val (local.get $b)))))))
|
|
|
|
;; remainder (26): integer remainder (sign of dividend)
|
|
(if (i32.eq (local.get $id) (i32.const 26))
|
|
(then
|
|
(return (call $make_fixnum (i32.rem_s (call $fixnum_val (local.get $a))
|
|
(call $fixnum_val (local.get $b)))))))
|
|
|
|
;; min (27): variadic
|
|
(if (i32.eq (local.get $id) (i32.const 27))
|
|
(then
|
|
(local.set $sum (call $fixnum_val (local.get $a)))
|
|
(local.set $cur (call $cdr (local.get $args)))
|
|
(block $done
|
|
(loop $loop
|
|
(br_if $done (i32.eq (local.get $cur) (global.get $NIL)))
|
|
(local.set $vmin (call $fixnum_val (call $car (local.get $cur))))
|
|
(if (i32.lt_s (local.get $vmin) (local.get $sum))
|
|
(then (local.set $sum (local.get $vmin))))
|
|
(local.set $cur (call $cdr (local.get $cur)))
|
|
(br $loop)))
|
|
(return (call $make_fixnum (local.get $sum)))))
|
|
|
|
;; max (28): variadic
|
|
(if (i32.eq (local.get $id) (i32.const 28))
|
|
(then
|
|
(local.set $sum (call $fixnum_val (local.get $a)))
|
|
(local.set $cur (call $cdr (local.get $args)))
|
|
(block $done
|
|
(loop $loop
|
|
(br_if $done (i32.eq (local.get $cur) (global.get $NIL)))
|
|
(local.set $vmax (call $fixnum_val (call $car (local.get $cur))))
|
|
(if (i32.gt_s (local.get $vmax) (local.get $sum))
|
|
(then (local.set $sum (local.get $vmax))))
|
|
(local.set $cur (call $cdr (local.get $cur)))
|
|
(br $loop)))
|
|
(return (call $make_fixnum (local.get $sum)))))
|
|
|
|
;; expt (29): exponentiation by squaring. Result accumulates via
|
|
;; num_mul so an intermediate that exceeds the 30-bit fixnum range
|
|
;; auto-promotes to a bignum — (expt 2 1024) returns the exact value
|
|
;; here, matching python lumbda and whitepaper §2.1.
|
|
(if (i32.eq (local.get $id) (i32.const 29))
|
|
(then
|
|
(local.set $exp_n (call $fixnum_val (local.get $b)))
|
|
(local.set $result (call $make_fixnum (i32.const 1)))
|
|
(local.set $sum (local.get $a)) ;; running power of base
|
|
(block $done
|
|
(loop $loop
|
|
(br_if $done (i32.le_s (local.get $exp_n) (i32.const 0)))
|
|
(if (i32.and (local.get $exp_n) (i32.const 1))
|
|
(then (local.set $result (call $num_mul (local.get $result) (local.get $sum)))))
|
|
(local.set $exp_n (i32.shr_s (local.get $exp_n) (i32.const 1)))
|
|
(if (local.get $exp_n)
|
|
(then (local.set $sum (call $num_mul (local.get $sum) (local.get $sum)))))
|
|
(br $loop)))
|
|
(return (local.get $result))))
|
|
|
|
;; even? (30)
|
|
(if (i32.eq (local.get $id) (i32.const 30))
|
|
(then
|
|
(if (i32.eqz (i32.and (call $fixnum_val (local.get $a)) (i32.const 1)))
|
|
(then (return (global.get $TRUE)))
|
|
(else (return (global.get $FALSE))))))
|
|
|
|
;; odd? (31)
|
|
(if (i32.eq (local.get $id) (i32.const 31))
|
|
(then
|
|
(if (i32.and (call $fixnum_val (local.get $a)) (i32.const 1))
|
|
(then (return (global.get $TRUE)))
|
|
(else (return (global.get $FALSE))))))
|
|
|
|
;; positive? (32)
|
|
(if (i32.eq (local.get $id) (i32.const 32))
|
|
(then
|
|
(if (i32.gt_s (call $fixnum_val (local.get $a)) (i32.const 0))
|
|
(then (return (global.get $TRUE)))
|
|
(else (return (global.get $FALSE))))))
|
|
|
|
;; negative? (33)
|
|
(if (i32.eq (local.get $id) (i32.const 33))
|
|
(then
|
|
(if (i32.lt_s (call $fixnum_val (local.get $a)) (i32.const 0))
|
|
(then (return (global.get $TRUE)))
|
|
(else (return (global.get $FALSE))))))
|
|
|
|
;; set-car! (34)
|
|
(if (i32.eq (local.get $id) (i32.const 34))
|
|
(then
|
|
(call $set_car (local.get $a) (local.get $b))
|
|
(return (global.get $VOID))))
|
|
|
|
;; set-cdr! (35)
|
|
(if (i32.eq (local.get $id) (i32.const 35))
|
|
(then
|
|
(call $set_cdr (local.get $a) (local.get $b))
|
|
(return (global.get $VOID))))
|
|
|
|
;; equal? (36): deep structural equality
|
|
(if (i32.eq (local.get $id) (i32.const 36))
|
|
(then (return (call $equal_p (local.get $a) (local.get $b)))))
|
|
|
|
;; eqv? (37): identity for our value types
|
|
(if (i32.eq (local.get $id) (i32.const 37))
|
|
(then
|
|
(if (i32.eq (local.get $a) (local.get $b))
|
|
(then (return (global.get $TRUE)))
|
|
(else (return (global.get $FALSE))))))
|
|
|
|
;; number? (38) — fixnum or rational
|
|
(if (i32.eq (local.get $id) (i32.const 38))
|
|
(then
|
|
(if (call $is_number (local.get $a))
|
|
(then (return (global.get $TRUE)))
|
|
(else (return (global.get $FALSE))))))
|
|
|
|
;; integer? (39) — fixnum or bignum (a rational with den=1 collapses
|
|
;; to one of those during normalization, so 14/2 → 7 is integer).
|
|
(if (i32.eq (local.get $id) (i32.const 39))
|
|
(then
|
|
(if (call $is_integer (local.get $a))
|
|
(then (return (global.get $TRUE)))
|
|
(else (return (global.get $FALSE))))))
|
|
|
|
;; symbol? (40)
|
|
(if (i32.eq (local.get $id) (i32.const 40))
|
|
(then
|
|
(if (call $is_symbol (local.get $a))
|
|
(then (return (global.get $TRUE)))
|
|
(else (return (global.get $FALSE))))))
|
|
|
|
;; string? (41)
|
|
(if (i32.eq (local.get $id) (i32.const 41))
|
|
(then
|
|
(if (call $is_string (local.get $a))
|
|
(then (return (global.get $TRUE)))
|
|
(else (return (global.get $FALSE))))))
|
|
|
|
;; procedure? (42) — closure or primitive
|
|
(if (i32.eq (local.get $id) (i32.const 42))
|
|
(then
|
|
(if (i32.or (call $is_closure (local.get $a)) (call $is_primitive (local.get $a)))
|
|
(then (return (global.get $TRUE)))
|
|
(else (return (global.get $FALSE))))))
|
|
|
|
;; boolean? (43)
|
|
(if (i32.eq (local.get $id) (i32.const 43))
|
|
(then
|
|
(if (i32.or (i32.eq (local.get $a) (global.get $TRUE))
|
|
(i32.eq (local.get $a) (global.get $FALSE)))
|
|
(then (return (global.get $TRUE)))
|
|
(else (return (global.get $FALSE))))))
|
|
|
|
;; caar (44)
|
|
(if (i32.eq (local.get $id) (i32.const 44))
|
|
(then (return (call $car (call $car (local.get $a))))))
|
|
|
|
;; cadr (45)
|
|
(if (i32.eq (local.get $id) (i32.const 45))
|
|
(then (return (call $car (call $cdr (local.get $a))))))
|
|
|
|
;; cdar (46)
|
|
(if (i32.eq (local.get $id) (i32.const 46))
|
|
(then (return (call $cdr (call $car (local.get $a))))))
|
|
|
|
;; cddr (47)
|
|
(if (i32.eq (local.get $id) (i32.const 47))
|
|
(then (return (call $cdr (call $cdr (local.get $a))))))
|
|
|
|
;; caddr (48)
|
|
(if (i32.eq (local.get $id) (i32.const 48))
|
|
(then (return (call $car (call $cdr (call $cdr (local.get $a)))))))
|
|
|
|
;; cadddr (49)
|
|
(if (i32.eq (local.get $id) (i32.const 49))
|
|
(then (return (call $car (call $cdr (call $cdr (call $cdr (local.get $a))))))))
|
|
|
|
;; reverse (50)
|
|
(if (i32.eq (local.get $id) (i32.const 50))
|
|
(then
|
|
(local.set $rev (global.get $NIL))
|
|
(local.set $cur (local.get $a))
|
|
(block $done
|
|
(loop $loop
|
|
(br_if $done (i32.eqz (call $is_pair (local.get $cur))))
|
|
(local.set $rev (call $make_pair (call $car (local.get $cur)) (local.get $rev)))
|
|
(local.set $cur (call $cdr (local.get $cur)))
|
|
(br $loop)))
|
|
(return (local.get $rev))))
|
|
|
|
;; append (51) — 2-arg
|
|
(if (i32.eq (local.get $id) (i32.const 51))
|
|
(then (return (call $append2 (local.get $a) (local.get $b)))))
|
|
|
|
;; apply (52) — (apply f args)
|
|
(if (i32.eq (local.get $id) (i32.const 52))
|
|
(then (return (call $apply (local.get $a) (local.get $b)))))
|
|
|
|
;; error (53) — emit message + raise (we just write to output for now)
|
|
(if (i32.eq (local.get $id) (i32.const 53))
|
|
(then
|
|
(call $out_str (i32.const 0xF030) (i32.const 6)) ;; "<error" — reuse procedure msg
|
|
(call $print_value (local.get $a))
|
|
(call $out_char (i32.const 10))
|
|
(return (global.get $VOID))))
|
|
|
|
;; member (54) — equal?-based
|
|
(if (i32.eq (local.get $id) (i32.const 54))
|
|
(then (return (call $member_eq (local.get $a) (local.get $b) (i32.const 1)))))
|
|
|
|
;; memq (55) — eq?-based
|
|
(if (i32.eq (local.get $id) (i32.const 55))
|
|
(then (return (call $member_eq (local.get $a) (local.get $b) (i32.const 0)))))
|
|
|
|
;; assoc (56) — equal? on car
|
|
(if (i32.eq (local.get $id) (i32.const 56))
|
|
(then (return (call $assoc_eq (local.get $a) (local.get $b) (i32.const 1)))))
|
|
|
|
;; assq (57) — eq? on car
|
|
(if (i32.eq (local.get $id) (i32.const 57))
|
|
(then (return (call $assoc_eq (local.get $a) (local.get $b) (i32.const 0)))))
|
|
|
|
;; list-ref (58)
|
|
(if (i32.eq (local.get $id) (i32.const 58))
|
|
(then
|
|
(local.set $idx (call $fixnum_val (local.get $b)))
|
|
(local.set $cur (local.get $a))
|
|
(block $done
|
|
(loop $loop
|
|
(br_if $done (i32.le_s (local.get $idx) (i32.const 0)))
|
|
(local.set $cur (call $cdr (local.get $cur)))
|
|
(local.set $idx (i32.sub (local.get $idx) (i32.const 1)))
|
|
(br $loop)))
|
|
(return (call $car (local.get $cur)))))
|
|
|
|
;; list-tail (59)
|
|
(if (i32.eq (local.get $id) (i32.const 59))
|
|
(then
|
|
(local.set $idxt (call $fixnum_val (local.get $b)))
|
|
(local.set $cur (local.get $a))
|
|
(block $done
|
|
(loop $loop
|
|
(br_if $done (i32.le_s (local.get $idxt) (i32.const 0)))
|
|
(local.set $cur (call $cdr (local.get $cur)))
|
|
(local.set $idxt (i32.sub (local.get $idxt) (i32.const 1)))
|
|
(br $loop)))
|
|
(return (local.get $cur))))
|
|
|
|
;; void (60)
|
|
(if (i32.eq (local.get $id) (i32.const 60))
|
|
(then (return (global.get $VOID))))
|
|
|
|
;; string-length (61)
|
|
(if (i32.eq (local.get $id) (i32.const 61))
|
|
(then (return (call $make_fixnum (call $string_len (local.get $a))))))
|
|
|
|
;; string-ref (62) — returns char
|
|
(if (i32.eq (local.get $id) (i32.const 62))
|
|
(then (return (call $make_char
|
|
(call $string_byte (local.get $a) (call $fixnum_val (local.get $b)))))))
|
|
|
|
;; substring (63) — (substring s start end)
|
|
(if (i32.eq (local.get $id) (i32.const 63))
|
|
(then (return (call $substring_op (local.get $a)
|
|
(call $fixnum_val (local.get $b))
|
|
(call $fixnum_val (call $car (call $cdr (call $cdr (local.get $args)))))))))
|
|
|
|
;; string-append (64) — variadic
|
|
(if (i32.eq (local.get $id) (i32.const 64))
|
|
(then (return (call $string_append_op (local.get $args)))))
|
|
|
|
;; string=? (65)
|
|
(if (i32.eq (local.get $id) (i32.const 65))
|
|
(then (return (call $equal_p (local.get $a) (local.get $b)))))
|
|
|
|
;; string<? (66)
|
|
(if (i32.eq (local.get $id) (i32.const 66))
|
|
(then (return (call $string_lt (local.get $a) (local.get $b)))))
|
|
|
|
;; string-upcase (67)
|
|
(if (i32.eq (local.get $id) (i32.const 67))
|
|
(then (return (call $string_case_op (local.get $a) (i32.const 1)))))
|
|
|
|
;; string-downcase (68)
|
|
(if (i32.eq (local.get $id) (i32.const 68))
|
|
(then (return (call $string_case_op (local.get $a) (i32.const 0)))))
|
|
|
|
;; string->list (69)
|
|
(if (i32.eq (local.get $id) (i32.const 69))
|
|
(then (return (call $string_to_list (local.get $a)))))
|
|
|
|
;; list->string (70)
|
|
(if (i32.eq (local.get $id) (i32.const 70))
|
|
(then (return (call $list_to_string (local.get $a)))))
|
|
|
|
;; string->symbol (71)
|
|
(if (i32.eq (local.get $id) (i32.const 71))
|
|
(then
|
|
(return (call $intern
|
|
(i32.add (local.get $a) (i32.const 8))
|
|
(call $string_len (local.get $a))))))
|
|
|
|
;; symbol->string (72) — copy symbol bytes into a fresh string
|
|
(if (i32.eq (local.get $id) (i32.const 72))
|
|
(then (return (call $symbol_to_string (local.get $a)))))
|
|
|
|
;; make-string (73) — (make-string n) or (make-string n char)
|
|
(if (i32.eq (local.get $id) (i32.const 73))
|
|
(then (return (call $make_string_filled
|
|
(call $fixnum_val (local.get $a))
|
|
(if (result i32) (call $is_char (local.get $b))
|
|
(then (call $char_code (local.get $b)))
|
|
(else (i32.const 32)))))))
|
|
|
|
;; char? (74)
|
|
(if (i32.eq (local.get $id) (i32.const 74))
|
|
(then
|
|
(if (call $is_char (local.get $a))
|
|
(then (return (global.get $TRUE)))
|
|
(else (return (global.get $FALSE))))))
|
|
|
|
;; char->integer (75)
|
|
(if (i32.eq (local.get $id) (i32.const 75))
|
|
(then (return (call $make_fixnum (call $char_code (local.get $a))))))
|
|
|
|
;; integer->char (76)
|
|
(if (i32.eq (local.get $id) (i32.const 76))
|
|
(then (return (call $make_char (call $fixnum_val (local.get $a))))))
|
|
|
|
;; char-alphabetic? (77)
|
|
(if (i32.eq (local.get $id) (i32.const 77))
|
|
(then
|
|
(local.set $sum (call $char_code (local.get $a)))
|
|
(if (i32.or
|
|
(i32.and (i32.ge_u (local.get $sum) (i32.const 65)) (i32.le_u (local.get $sum) (i32.const 90)))
|
|
(i32.and (i32.ge_u (local.get $sum) (i32.const 97)) (i32.le_u (local.get $sum) (i32.const 122))))
|
|
(then (return (global.get $TRUE)))
|
|
(else (return (global.get $FALSE))))))
|
|
|
|
;; char-numeric? (78)
|
|
(if (i32.eq (local.get $id) (i32.const 78))
|
|
(then
|
|
(local.set $sum (call $char_code (local.get $a)))
|
|
(if (i32.and (i32.ge_u (local.get $sum) (i32.const 48)) (i32.le_u (local.get $sum) (i32.const 57)))
|
|
(then (return (global.get $TRUE)))
|
|
(else (return (global.get $FALSE))))))
|
|
|
|
;; char-whitespace? (79)
|
|
(if (i32.eq (local.get $id) (i32.const 79))
|
|
(then
|
|
(local.set $sum (call $char_code (local.get $a)))
|
|
(if (i32.or
|
|
(i32.or
|
|
(i32.eq (local.get $sum) (i32.const 32))
|
|
(i32.eq (local.get $sum) (i32.const 9)))
|
|
(i32.or
|
|
(i32.eq (local.get $sum) (i32.const 10))
|
|
(i32.eq (local.get $sum) (i32.const 13))))
|
|
(then (return (global.get $TRUE)))
|
|
(else (return (global.get $FALSE))))))
|
|
|
|
;; char-upcase (80)
|
|
(if (i32.eq (local.get $id) (i32.const 80))
|
|
(then
|
|
(local.set $sum (call $char_code (local.get $a)))
|
|
(if (i32.and (i32.ge_u (local.get $sum) (i32.const 97)) (i32.le_u (local.get $sum) (i32.const 122)))
|
|
(then (local.set $sum (i32.sub (local.get $sum) (i32.const 32)))))
|
|
(return (call $make_char (local.get $sum)))))
|
|
|
|
;; char-downcase (81)
|
|
(if (i32.eq (local.get $id) (i32.const 81))
|
|
(then
|
|
(local.set $sum (call $char_code (local.get $a)))
|
|
(if (i32.and (i32.ge_u (local.get $sum) (i32.const 65)) (i32.le_u (local.get $sum) (i32.const 90)))
|
|
(then (local.set $sum (i32.add (local.get $sum) (i32.const 32)))))
|
|
(return (call $make_char (local.get $sum)))))
|
|
|
|
;; char=? (82)
|
|
(if (i32.eq (local.get $id) (i32.const 82))
|
|
(then
|
|
(if (i32.eq (call $char_code (local.get $a)) (call $char_code (local.get $b)))
|
|
(then (return (global.get $TRUE)))
|
|
(else (return (global.get $FALSE))))))
|
|
|
|
;; char<? (83)
|
|
(if (i32.eq (local.get $id) (i32.const 83))
|
|
(then
|
|
(if (i32.lt_u (call $char_code (local.get $a)) (call $char_code (local.get $b)))
|
|
(then (return (global.get $TRUE)))
|
|
(else (return (global.get $FALSE))))))
|
|
|
|
;; number->string (84)
|
|
(if (i32.eq (local.get $id) (i32.const 84))
|
|
(then (return (call $number_to_string (call $fixnum_val (local.get $a))))))
|
|
|
|
;; string->number (85)
|
|
(if (i32.eq (local.get $id) (i32.const 85))
|
|
(then (return (call $string_to_number (local.get $a)))))
|
|
|
|
;; string-contains (86) — returns #t if substring present, else #f
|
|
(if (i32.eq (local.get $id) (i32.const 86))
|
|
(then (return (call $string_contains_p (local.get $a) (local.get $b)))))
|
|
|
|
;; string-join (87) — (string-join list-of-strings sep-string)
|
|
(if (i32.eq (local.get $id) (i32.const 87))
|
|
(then (return (call $string_join_op (local.get $a) (local.get $b)))))
|
|
|
|
;; vector (88) — (vector a b c ...) returns a vector with the args
|
|
(if (i32.eq (local.get $id) (i32.const 88))
|
|
(then (return (call $list_to_vector_op (local.get $args)))))
|
|
|
|
;; vector? (89)
|
|
(if (i32.eq (local.get $id) (i32.const 89))
|
|
(then
|
|
(if (call $is_vector (local.get $a))
|
|
(then (return (global.get $TRUE)))
|
|
(else (return (global.get $FALSE))))))
|
|
|
|
;; make-vector (90) — (make-vector n [init])
|
|
(if (i32.eq (local.get $id) (i32.const 90))
|
|
(then (return (call $make_vector_filled
|
|
(call $fixnum_val (local.get $a))
|
|
(local.get $b)))))
|
|
|
|
;; vector-length (91)
|
|
(if (i32.eq (local.get $id) (i32.const 91))
|
|
(then (return (call $make_fixnum (call $vector_len (local.get $a))))))
|
|
|
|
;; vector-ref (92)
|
|
(if (i32.eq (local.get $id) (i32.const 92))
|
|
(then (return (call $vector_get (local.get $a) (call $fixnum_val (local.get $b))))))
|
|
|
|
;; vector-set! (93) — (vector-set! v i val)
|
|
(if (i32.eq (local.get $id) (i32.const 93))
|
|
(then
|
|
(call $vector_put (local.get $a)
|
|
(call $fixnum_val (local.get $b))
|
|
(call $car (call $cdr (call $cdr (local.get $args)))))
|
|
(return (global.get $VOID))))
|
|
|
|
;; vector->list (94)
|
|
(if (i32.eq (local.get $id) (i32.const 94))
|
|
(then (return (call $vector_to_list_op (local.get $a)))))
|
|
|
|
;; list->vector (95)
|
|
(if (i32.eq (local.get $id) (i32.const 95))
|
|
(then (return (call $list_to_vector_op (local.get $a)))))
|
|
|
|
;; make-hash-table (96)
|
|
(if (i32.eq (local.get $id) (i32.const 96))
|
|
(then (return (call $make_hashtable))))
|
|
|
|
;; hash-table? (97)
|
|
(if (i32.eq (local.get $id) (i32.const 97))
|
|
(then
|
|
(if (call $is_hashtable (local.get $a))
|
|
(then (return (global.get $TRUE)))
|
|
(else (return (global.get $FALSE))))))
|
|
|
|
;; hash-table-set! (98) — (hash-table-set! h k v)
|
|
(if (i32.eq (local.get $id) (i32.const 98))
|
|
(then
|
|
(call $ht_set (local.get $a) (local.get $b)
|
|
(call $car (call $cdr (call $cdr (local.get $args)))))
|
|
(return (global.get $VOID))))
|
|
|
|
;; hash-table-ref (99) — (hash-table-ref h k) — returns value or FALSE
|
|
(if (i32.eq (local.get $id) (i32.const 99))
|
|
(then
|
|
(local.set $sum (call $ht_find (local.get $a) (local.get $b)))
|
|
(if (i32.eq (local.get $sum) (global.get $FALSE))
|
|
(then (return (global.get $FALSE))))
|
|
(return (call $cdr (local.get $sum)))))
|
|
|
|
;; hash-table-ref/default (100) — (hash-table-ref/default h k def)
|
|
(if (i32.eq (local.get $id) (i32.const 100))
|
|
(then
|
|
(local.set $sum (call $ht_find (local.get $a) (local.get $b)))
|
|
(if (i32.eq (local.get $sum) (global.get $FALSE))
|
|
(then (return (call $car (call $cdr (call $cdr (local.get $args)))))))
|
|
(return (call $cdr (local.get $sum)))))
|
|
|
|
;; hash-table-delete! (101)
|
|
(if (i32.eq (local.get $id) (i32.const 101))
|
|
(then
|
|
(drop (call $ht_delete (local.get $a) (local.get $b)))
|
|
(return (global.get $VOID))))
|
|
|
|
;; hash-table-exists? (102)
|
|
(if (i32.eq (local.get $id) (i32.const 102))
|
|
(then
|
|
(local.set $sum (call $ht_find (local.get $a) (local.get $b)))
|
|
(if (i32.eq (local.get $sum) (global.get $FALSE))
|
|
(then (return (global.get $FALSE))))
|
|
(return (global.get $TRUE))))
|
|
|
|
;; hash-table-size (103)
|
|
(if (i32.eq (local.get $id) (i32.const 103))
|
|
(then (return (call $make_fixnum (call $ht_count (local.get $a))))))
|
|
|
|
;; hash-table-keys (104) — fresh list of keys
|
|
(if (i32.eq (local.get $id) (i32.const 104))
|
|
(then (return (call $ht_keys_op (local.get $a)))))
|
|
|
|
;; hash-table-values (105) — fresh list of values
|
|
(if (i32.eq (local.get $id) (i32.const 105))
|
|
(then (return (call $ht_values_op (local.get $a)))))
|
|
|
|
;; hash-table->alist (106)
|
|
(if (i32.eq (local.get $id) (i32.const 106))
|
|
(then (return (call $ht_alist (local.get $a)))))
|
|
|
|
;; write (107) — like display but quotes strings and #\-chars
|
|
(if (i32.eq (local.get $id) (i32.const 107))
|
|
(then (call $write_value (local.get $a)) (return (global.get $VOID))))
|
|
|
|
;; write-string (108) — write a string without quoting
|
|
(if (i32.eq (local.get $id) (i32.const 108))
|
|
(then
|
|
(if (call $is_string (local.get $a))
|
|
(then
|
|
(call $out_str
|
|
(i32.add (local.get $a) (i32.const 8))
|
|
(call $string_len (local.get $a)))))
|
|
(return (global.get $VOID))))
|
|
|
|
;; bend!-call (109) — dispatch a payload string to the configured
|
|
;; gpu-worker URL via host JS sync XHR. Returns the response as a string.
|
|
(if (i32.eq (local.get $id) (i32.const 109))
|
|
(then (return (call $bend_call_op (local.get $a)))))
|
|
|
|
(global.get $VOID))
|
|
|
|
;; ─── Init ──────────────────────────────────────────────────────
|
|
;; Set up immediates' bytes (for "()" "#t" "#f" "<procedure>" " . ").
|
|
;; We park them at 0xF000 onward.
|
|
(data (i32.const 0xF000) "()")
|
|
(data (i32.const 0xF010) "#t")
|
|
(data (i32.const 0xF020) "#f")
|
|
(data (i32.const 0xF030) "<procedure>")
|
|
(data (i32.const 0xF040) " . ")
|
|
(data (i32.const 0xF050) "#(")
|
|
(data (i32.const 0xF060) "#<hashtable>")
|
|
(data (i32.const 0xF080) "#\\")
|
|
|
|
;; Helper to intern from a fixed-string region. We embed literal symbols
|
|
;; in dataregions 0xE000+ and intern them at init.
|
|
;; Layout per slot: 16 bytes; we just record start+len ad hoc inline.
|
|
|
|
(data (i32.const 0xE000) "quote")
|
|
(data (i32.const 0xE010) "if")
|
|
(data (i32.const 0xE020) "lambda")
|
|
(data (i32.const 0xE030) "define")
|
|
(data (i32.const 0xE040) "begin")
|
|
(data (i32.const 0xE050) "cond")
|
|
(data (i32.const 0xE060) "else")
|
|
(data (i32.const 0xE070) "let")
|
|
(data (i32.const 0xE080) "and")
|
|
(data (i32.const 0xE090) "or")
|
|
(data (i32.const 0xE0A0) "set!")
|
|
(data (i32.const 0xE0B0) "let*")
|
|
(data (i32.const 0xE0B8) "letrec")
|
|
(data (i32.const 0xE0C0) "when")
|
|
(data (i32.const 0xE0C8) "unless")
|
|
(data (i32.const 0xE0D0) "case")
|
|
(data (i32.const 0xE0D8) "do")
|
|
|
|
;; Primitive name strings (interned + bound at init).
|
|
(data (i32.const 0xE100) "+")
|
|
(data (i32.const 0xE104) "-")
|
|
(data (i32.const 0xE108) "*")
|
|
(data (i32.const 0xE10C) "/")
|
|
(data (i32.const 0xE110) "=")
|
|
(data (i32.const 0xE114) "<")
|
|
(data (i32.const 0xE118) ">")
|
|
(data (i32.const 0xE11C) "<=")
|
|
(data (i32.const 0xE120) ">=")
|
|
(data (i32.const 0xE124) "cons")
|
|
(data (i32.const 0xE12C) "car")
|
|
(data (i32.const 0xE130) "cdr")
|
|
(data (i32.const 0xE134) "null?")
|
|
(data (i32.const 0xE13C) "pair?")
|
|
(data (i32.const 0xE144) "eq?")
|
|
(data (i32.const 0xE148) "not")
|
|
(data (i32.const 0xE14C) "display")
|
|
(data (i32.const 0xE154) "newline")
|
|
(data (i32.const 0xE15C) "print")
|
|
(data (i32.const 0xE164) "list")
|
|
(data (i32.const 0xE16C) "length")
|
|
(data (i32.const 0xE174) "abs")
|
|
(data (i32.const 0xE178) "modulo")
|
|
(data (i32.const 0xE180) "zero?")
|
|
(data (i32.const 0xE188) "quotient")
|
|
(data (i32.const 0xE194) "remainder")
|
|
(data (i32.const 0xE1A0) "min")
|
|
(data (i32.const 0xE1A4) "max")
|
|
(data (i32.const 0xE1A8) "expt")
|
|
(data (i32.const 0xE1B0) "even?")
|
|
(data (i32.const 0xE1B8) "odd?")
|
|
(data (i32.const 0xE1C0) "positive?")
|
|
(data (i32.const 0xE1CC) "negative?")
|
|
(data (i32.const 0xE1D8) "set-car!")
|
|
(data (i32.const 0xE1E4) "set-cdr!")
|
|
(data (i32.const 0xE1F0) "equal?")
|
|
(data (i32.const 0xE1F8) "eqv?")
|
|
(data (i32.const 0xE200) "number?")
|
|
(data (i32.const 0xE208) "integer?")
|
|
(data (i32.const 0xE214) "symbol?")
|
|
(data (i32.const 0xE220) "string?")
|
|
(data (i32.const 0xE228) "procedure?")
|
|
(data (i32.const 0xE234) "boolean?")
|
|
(data (i32.const 0xE240) "caar")
|
|
(data (i32.const 0xE248) "cadr")
|
|
(data (i32.const 0xE250) "cdar")
|
|
(data (i32.const 0xE258) "cddr")
|
|
(data (i32.const 0xE260) "caddr")
|
|
(data (i32.const 0xE268) "cadddr")
|
|
(data (i32.const 0xE270) "reverse")
|
|
(data (i32.const 0xE278) "append")
|
|
(data (i32.const 0xE280) "apply")
|
|
(data (i32.const 0xE288) "error")
|
|
(data (i32.const 0xE290) "member")
|
|
(data (i32.const 0xE298) "memq")
|
|
(data (i32.const 0xE2A0) "assoc")
|
|
(data (i32.const 0xE2A8) "assq")
|
|
(data (i32.const 0xE2B0) "list-ref")
|
|
(data (i32.const 0xE2BC) "list-tail")
|
|
(data (i32.const 0xE2C8) "void")
|
|
;; Named character spellings.
|
|
(data (i32.const 0xE2D0) "space")
|
|
(data (i32.const 0xE2D8) "newline")
|
|
(data (i32.const 0xE2E0) "tab")
|
|
(data (i32.const 0xE2E4) "return")
|
|
(data (i32.const 0xE2EC) "null")
|
|
;; String + char primitive names.
|
|
(data (i32.const 0xE300) "string-length")
|
|
(data (i32.const 0xE310) "string-ref")
|
|
(data (i32.const 0xE31C) "substring")
|
|
(data (i32.const 0xE328) "string-append")
|
|
(data (i32.const 0xE338) "string=?")
|
|
(data (i32.const 0xE344) "string<?")
|
|
(data (i32.const 0xE350) "string-upcase")
|
|
(data (i32.const 0xE360) "string-downcase")
|
|
(data (i32.const 0xE374) "string->list")
|
|
(data (i32.const 0xE384) "list->string")
|
|
(data (i32.const 0xE394) "string->symbol")
|
|
(data (i32.const 0xE3A4) "symbol->string")
|
|
(data (i32.const 0xE3B4) "make-string")
|
|
(data (i32.const 0xE3C0) "char?")
|
|
(data (i32.const 0xE3C8) "char->integer")
|
|
(data (i32.const 0xE3D8) "integer->char")
|
|
(data (i32.const 0xE3E8) "char-alphabetic?")
|
|
(data (i32.const 0xE3FC) "char-numeric?")
|
|
(data (i32.const 0xE40C) "char-whitespace?")
|
|
(data (i32.const 0xE420) "char-upcase")
|
|
(data (i32.const 0xE42C) "char-downcase")
|
|
(data (i32.const 0xE43C) "char=?")
|
|
(data (i32.const 0xE444) "char<?")
|
|
(data (i32.const 0xE44C) "number->string")
|
|
(data (i32.const 0xE45C) "string->number")
|
|
(data (i32.const 0xE46C) "string-contains")
|
|
(data (i32.const 0xE47C) "string-join")
|
|
;; Vectors & hash tables.
|
|
(data (i32.const 0xE490) "vector")
|
|
(data (i32.const 0xE498) "vector?")
|
|
(data (i32.const 0xE4A0) "make-vector")
|
|
(data (i32.const 0xE4AC) "vector-length")
|
|
(data (i32.const 0xE4BC) "vector-ref")
|
|
(data (i32.const 0xE4C8) "vector-set!")
|
|
(data (i32.const 0xE4D4) "vector->list")
|
|
(data (i32.const 0xE4E4) "list->vector")
|
|
(data (i32.const 0xE4F4) "make-hash-table")
|
|
(data (i32.const 0xE504) "hash-table?")
|
|
(data (i32.const 0xE510) "hash-table-set!")
|
|
(data (i32.const 0xE520) "hash-table-ref")
|
|
(data (i32.const 0xE530) "hash-table-ref/default")
|
|
(data (i32.const 0xE548) "hash-table-delete!")
|
|
(data (i32.const 0xE55C) "hash-table-exists?")
|
|
(data (i32.const 0xE570) "hash-table-size")
|
|
(data (i32.const 0xE580) "hash-table-keys")
|
|
(data (i32.const 0xE590) "hash-table-values")
|
|
(data (i32.const 0xE5A4) "hash-table->alist")
|
|
(data (i32.const 0xE5B8) "write")
|
|
(data (i32.const 0xE5C0) "write-string")
|
|
(data (i32.const 0xE5D0) "bend!-call")
|
|
|
|
;; ── Embedded Lisp prelude. Evaluated at end of init. ─────────────
|
|
(data (i32.const 0x50000)
|
|
"(define (map f xs) (if (null? xs) (quote ()) (cons (f (car xs)) (map f (cdr xs)))))\n"
|
|
"(define (filter p xs) (cond ((null? xs) (quote ())) ((p (car xs)) (cons (car xs) (filter p (cdr xs)))) (else (filter p (cdr xs)))))\n"
|
|
"(define (fold-left f z xs) (if (null? xs) z (fold-left f (f z (car xs)) (cdr xs))))\n"
|
|
"(define (fold-right f z xs) (if (null? xs) z (f (car xs) (fold-right f z (cdr xs)))))\n"
|
|
"(define (for-each f xs) (cond ((null? xs) (void)) (else (f (car xs)) (for-each f (cdr xs)))))\n"
|
|
"(define (any p xs) (cond ((null? xs) #f) ((p (car xs)) #t) (else (any p (cdr xs)))))\n"
|
|
"(define (every p xs) (cond ((null? xs) #t) ((p (car xs)) (every p (cdr xs))) (else #f)))\n"
|
|
"(define (count p xs) (fold-left (lambda (acc x) (if (p x) (+ acc 1) acc)) 0 xs))\n"
|
|
"(define (find p xs) (cond ((null? xs) #f) ((p (car xs)) (car xs)) (else (find p (cdr xs)))))\n"
|
|
"(define (string-split s sep) (let loop ((i 0) (start 0) (acc (quote ()))) (cond ((>= i (string-length s)) (reverse (cons (substring s start i) acc))) ((char=? (string-ref s i) sep) (loop (+ i 1) (+ i 1) (cons (substring s start i) acc))) (else (loop (+ i 1) start acc)))))\n"
|
|
"(define (string-trim s) (let* ((len (string-length s)) (start (let loop ((i 0)) (cond ((>= i len) i) ((char-whitespace? (string-ref s i)) (loop (+ i 1))) (else i)))) (end (let loop ((i (- len 1))) (cond ((< i start) start) ((char-whitespace? (string-ref s i)) (loop (- i 1))) (else (+ i 1)))))) (substring s start end)))\n"
|
|
"(define (string->list s) (let loop ((i 0) (acc (quote ()))) (if (>= i (string-length s)) (reverse acc) (loop (+ i 1) (cons (string-ref s i) acc)))))\n"
|
|
"(define (random-state) (cons 12345 67890))\n"
|
|
"(define (vector-map f v) (let* ((n (vector-length v)) (r (make-vector n 0))) (let loop ((i 0)) (cond ((>= i n) r) (else (vector-set! r i (f (vector-ref v i))) (loop (+ i 1)))))))\n"
|
|
"(define (vector-for-each f v) (let ((n (vector-length v))) (let loop ((i 0)) (cond ((>= i n) (void)) (else (f (vector-ref v i)) (loop (+ i 1)))))))\n"
|
|
"(define (vector-fill! v x) (let ((n (vector-length v))) (let loop ((i 0)) (cond ((>= i n) (void)) (else (vector-set! v i x) (loop (+ i 1)))))))\n"
|
|
"(define (sort xs less?) (cond ((null? xs) (quote ())) ((null? (cdr xs)) xs) (else (let ((p (car xs)) (rest (cdr xs))) (append (sort (filter (lambda (x) (less? x p)) rest) less?) (cons p (sort (filter (lambda (x) (not (less? x p))) rest) less?)))))))\n"
|
|
"(define (assert-equal expected actual) (cond ((equal? expected actual) #t) (else (display \"FAIL expected=\") (display expected) (display \" actual=\") (display actual) (newline) #f)))\n"
|
|
"(define (assert-true v) (cond (v #t) (else (display \"FAIL expected truthy got=\") (display v) (newline) #f)))\n"
|
|
"(define (assert-false v) (cond ((not v) #t) (else (display \"FAIL expected #f got=\") (display v) (newline) #f)))\n"
|
|
)
|
|
|
|
(func $bind_prim (param $name_ptr i32) (param $name_len i32) (param $id i32)
|
|
(local $sym i32)
|
|
(local.set $sym (call $intern (local.get $name_ptr) (local.get $name_len)))
|
|
(global.set $global_env
|
|
(call $env_define (global.get $global_env)
|
|
(local.get $sym)
|
|
(call $make_primitive (local.get $id)))))
|
|
|
|
;; Length of a NUL-terminated byte sequence (used for prelude embed).
|
|
(func $strlen_nul (param $p i32) (result i32)
|
|
(local $i i32)
|
|
(local.set $i (i32.const 0))
|
|
(block $done
|
|
(loop $l
|
|
(br_if $done (i32.eqz (i32.load8_u (i32.add (local.get $p) (local.get $i)))))
|
|
(local.set $i (i32.add (local.get $i) (i32.const 1)))
|
|
(br $l)))
|
|
(local.get $i))
|
|
|
|
;; Evaluate the embedded prelude. Source bounds restored by next lumbda_eval.
|
|
(func $eval_prelude
|
|
(local $val i32)
|
|
(global.set $prelude_len (call $strlen_nul (global.get $prelude_ptr)))
|
|
(global.set $source_ptr (global.get $prelude_ptr))
|
|
(global.set $source_end (i32.add (global.get $prelude_ptr) (global.get $prelude_len)))
|
|
(block $done
|
|
(loop $loop
|
|
(call $skip_ws)
|
|
(br_if $done (i32.ge_u (global.get $source_ptr) (global.get $source_end)))
|
|
(local.set $val (call $eval (call $read) (global.get $NIL)))
|
|
(br $loop))))
|
|
|
|
(func $lumbda_init (export "lumbda_init")
|
|
(if (global.get $initialized) (then (return)))
|
|
(global.set $initialized (i32.const 1))
|
|
|
|
;; Intern special-form symbols (these are matched by identity in eval).
|
|
(global.set $sym_quote (call $intern (i32.const 0xE000) (i32.const 5)))
|
|
(global.set $sym_if (call $intern (i32.const 0xE010) (i32.const 2)))
|
|
(global.set $sym_lambda (call $intern (i32.const 0xE020) (i32.const 6)))
|
|
(global.set $sym_define (call $intern (i32.const 0xE030) (i32.const 6)))
|
|
(global.set $sym_begin (call $intern (i32.const 0xE040) (i32.const 5)))
|
|
(global.set $sym_cond (call $intern (i32.const 0xE050) (i32.const 4)))
|
|
(global.set $sym_else (call $intern (i32.const 0xE060) (i32.const 4)))
|
|
(global.set $sym_let (call $intern (i32.const 0xE070) (i32.const 3)))
|
|
(global.set $sym_and (call $intern (i32.const 0xE080) (i32.const 3)))
|
|
(global.set $sym_or (call $intern (i32.const 0xE090) (i32.const 2)))
|
|
(global.set $sym_set (call $intern (i32.const 0xE0A0) (i32.const 4)))
|
|
(global.set $sym_letstar (call $intern (i32.const 0xE0B0) (i32.const 4)))
|
|
(global.set $sym_letrec (call $intern (i32.const 0xE0B8) (i32.const 6)))
|
|
(global.set $sym_when (call $intern (i32.const 0xE0C0) (i32.const 4)))
|
|
(global.set $sym_unless (call $intern (i32.const 0xE0C8) (i32.const 6)))
|
|
(global.set $sym_case (call $intern (i32.const 0xE0D0) (i32.const 4)))
|
|
(global.set $sym_do (call $intern (i32.const 0xE0D8) (i32.const 2)))
|
|
|
|
(call $bind_prim (i32.const 0xE100) (i32.const 1) (i32.const 1)) ;; +
|
|
(call $bind_prim (i32.const 0xE104) (i32.const 1) (i32.const 2)) ;; -
|
|
(call $bind_prim (i32.const 0xE108) (i32.const 1) (i32.const 3)) ;; *
|
|
(call $bind_prim (i32.const 0xE10C) (i32.const 1) (i32.const 4)) ;; /
|
|
(call $bind_prim (i32.const 0xE110) (i32.const 1) (i32.const 5)) ;; =
|
|
(call $bind_prim (i32.const 0xE114) (i32.const 1) (i32.const 6)) ;; <
|
|
(call $bind_prim (i32.const 0xE118) (i32.const 1) (i32.const 7)) ;; >
|
|
(call $bind_prim (i32.const 0xE11C) (i32.const 2) (i32.const 8)) ;; <=
|
|
(call $bind_prim (i32.const 0xE120) (i32.const 2) (i32.const 9)) ;; >=
|
|
(call $bind_prim (i32.const 0xE124) (i32.const 4) (i32.const 10)) ;; cons
|
|
(call $bind_prim (i32.const 0xE12C) (i32.const 3) (i32.const 11)) ;; car
|
|
(call $bind_prim (i32.const 0xE130) (i32.const 3) (i32.const 12)) ;; cdr
|
|
(call $bind_prim (i32.const 0xE134) (i32.const 5) (i32.const 13)) ;; null?
|
|
(call $bind_prim (i32.const 0xE13C) (i32.const 5) (i32.const 14)) ;; pair?
|
|
(call $bind_prim (i32.const 0xE144) (i32.const 3) (i32.const 15)) ;; eq?
|
|
(call $bind_prim (i32.const 0xE148) (i32.const 3) (i32.const 16)) ;; not
|
|
(call $bind_prim (i32.const 0xE14C) (i32.const 7) (i32.const 17)) ;; display
|
|
(call $bind_prim (i32.const 0xE154) (i32.const 7) (i32.const 18)) ;; newline
|
|
(call $bind_prim (i32.const 0xE15C) (i32.const 5) (i32.const 19)) ;; print
|
|
(call $bind_prim (i32.const 0xE164) (i32.const 4) (i32.const 20)) ;; list
|
|
(call $bind_prim (i32.const 0xE16C) (i32.const 6) (i32.const 21)) ;; length
|
|
(call $bind_prim (i32.const 0xE174) (i32.const 3) (i32.const 22)) ;; abs
|
|
(call $bind_prim (i32.const 0xE178) (i32.const 6) (i32.const 23)) ;; modulo
|
|
(call $bind_prim (i32.const 0xE180) (i32.const 5) (i32.const 24)) ;; zero?
|
|
(call $bind_prim (i32.const 0xE188) (i32.const 8) (i32.const 25)) ;; quotient
|
|
(call $bind_prim (i32.const 0xE194) (i32.const 9) (i32.const 26)) ;; remainder
|
|
(call $bind_prim (i32.const 0xE1A0) (i32.const 3) (i32.const 27)) ;; min
|
|
(call $bind_prim (i32.const 0xE1A4) (i32.const 3) (i32.const 28)) ;; max
|
|
(call $bind_prim (i32.const 0xE1A8) (i32.const 4) (i32.const 29)) ;; expt
|
|
(call $bind_prim (i32.const 0xE1B0) (i32.const 5) (i32.const 30)) ;; even?
|
|
(call $bind_prim (i32.const 0xE1B8) (i32.const 4) (i32.const 31)) ;; odd?
|
|
(call $bind_prim (i32.const 0xE1C0) (i32.const 9) (i32.const 32)) ;; positive?
|
|
(call $bind_prim (i32.const 0xE1CC) (i32.const 9) (i32.const 33)) ;; negative?
|
|
(call $bind_prim (i32.const 0xE1D8) (i32.const 8) (i32.const 34)) ;; set-car!
|
|
(call $bind_prim (i32.const 0xE1E4) (i32.const 8) (i32.const 35)) ;; set-cdr!
|
|
(call $bind_prim (i32.const 0xE1F0) (i32.const 6) (i32.const 36)) ;; equal?
|
|
(call $bind_prim (i32.const 0xE1F8) (i32.const 4) (i32.const 37)) ;; eqv?
|
|
(call $bind_prim (i32.const 0xE200) (i32.const 7) (i32.const 38)) ;; number?
|
|
(call $bind_prim (i32.const 0xE208) (i32.const 8) (i32.const 39)) ;; integer?
|
|
(call $bind_prim (i32.const 0xE214) (i32.const 7) (i32.const 40)) ;; symbol?
|
|
(call $bind_prim (i32.const 0xE220) (i32.const 7) (i32.const 41)) ;; string?
|
|
(call $bind_prim (i32.const 0xE228) (i32.const 10) (i32.const 42)) ;; procedure?
|
|
(call $bind_prim (i32.const 0xE234) (i32.const 8) (i32.const 43)) ;; boolean?
|
|
(call $bind_prim (i32.const 0xE240) (i32.const 4) (i32.const 44)) ;; caar
|
|
(call $bind_prim (i32.const 0xE248) (i32.const 4) (i32.const 45)) ;; cadr
|
|
(call $bind_prim (i32.const 0xE250) (i32.const 4) (i32.const 46)) ;; cdar
|
|
(call $bind_prim (i32.const 0xE258) (i32.const 4) (i32.const 47)) ;; cddr
|
|
(call $bind_prim (i32.const 0xE260) (i32.const 5) (i32.const 48)) ;; caddr
|
|
(call $bind_prim (i32.const 0xE268) (i32.const 6) (i32.const 49)) ;; cadddr
|
|
(call $bind_prim (i32.const 0xE270) (i32.const 7) (i32.const 50)) ;; reverse
|
|
(call $bind_prim (i32.const 0xE278) (i32.const 6) (i32.const 51)) ;; append
|
|
(call $bind_prim (i32.const 0xE280) (i32.const 5) (i32.const 52)) ;; apply
|
|
(call $bind_prim (i32.const 0xE288) (i32.const 5) (i32.const 53)) ;; error
|
|
(call $bind_prim (i32.const 0xE290) (i32.const 6) (i32.const 54)) ;; member
|
|
(call $bind_prim (i32.const 0xE298) (i32.const 4) (i32.const 55)) ;; memq
|
|
(call $bind_prim (i32.const 0xE2A0) (i32.const 5) (i32.const 56)) ;; assoc
|
|
(call $bind_prim (i32.const 0xE2A8) (i32.const 4) (i32.const 57)) ;; assq
|
|
(call $bind_prim (i32.const 0xE2B0) (i32.const 8) (i32.const 58)) ;; list-ref
|
|
(call $bind_prim (i32.const 0xE2BC) (i32.const 9) (i32.const 59)) ;; list-tail
|
|
(call $bind_prim (i32.const 0xE2C8) (i32.const 4) (i32.const 60)) ;; void
|
|
(call $bind_prim (i32.const 0xE300) (i32.const 13) (i32.const 61)) ;; string-length
|
|
(call $bind_prim (i32.const 0xE310) (i32.const 10) (i32.const 62)) ;; string-ref
|
|
(call $bind_prim (i32.const 0xE31C) (i32.const 9) (i32.const 63)) ;; substring
|
|
(call $bind_prim (i32.const 0xE328) (i32.const 13) (i32.const 64)) ;; string-append
|
|
(call $bind_prim (i32.const 0xE338) (i32.const 8) (i32.const 65)) ;; string=?
|
|
(call $bind_prim (i32.const 0xE344) (i32.const 8) (i32.const 66)) ;; string<?
|
|
(call $bind_prim (i32.const 0xE350) (i32.const 13) (i32.const 67)) ;; string-upcase
|
|
(call $bind_prim (i32.const 0xE360) (i32.const 15) (i32.const 68)) ;; string-downcase
|
|
(call $bind_prim (i32.const 0xE374) (i32.const 12) (i32.const 69)) ;; string->list
|
|
(call $bind_prim (i32.const 0xE384) (i32.const 12) (i32.const 70)) ;; list->string
|
|
(call $bind_prim (i32.const 0xE394) (i32.const 14) (i32.const 71)) ;; string->symbol
|
|
(call $bind_prim (i32.const 0xE3A4) (i32.const 14) (i32.const 72)) ;; symbol->string
|
|
(call $bind_prim (i32.const 0xE3B4) (i32.const 11) (i32.const 73)) ;; make-string
|
|
(call $bind_prim (i32.const 0xE3C0) (i32.const 5) (i32.const 74)) ;; char?
|
|
(call $bind_prim (i32.const 0xE3C8) (i32.const 13) (i32.const 75)) ;; char->integer
|
|
(call $bind_prim (i32.const 0xE3D8) (i32.const 13) (i32.const 76)) ;; integer->char
|
|
(call $bind_prim (i32.const 0xE3E8) (i32.const 16) (i32.const 77)) ;; char-alphabetic?
|
|
(call $bind_prim (i32.const 0xE3FC) (i32.const 13) (i32.const 78)) ;; char-numeric?
|
|
(call $bind_prim (i32.const 0xE40C) (i32.const 16) (i32.const 79)) ;; char-whitespace?
|
|
(call $bind_prim (i32.const 0xE420) (i32.const 11) (i32.const 80)) ;; char-upcase
|
|
(call $bind_prim (i32.const 0xE42C) (i32.const 13) (i32.const 81)) ;; char-downcase
|
|
(call $bind_prim (i32.const 0xE43C) (i32.const 6) (i32.const 82)) ;; char=?
|
|
(call $bind_prim (i32.const 0xE444) (i32.const 6) (i32.const 83)) ;; char<?
|
|
(call $bind_prim (i32.const 0xE44C) (i32.const 14) (i32.const 84)) ;; number->string
|
|
(call $bind_prim (i32.const 0xE45C) (i32.const 14) (i32.const 85)) ;; string->number
|
|
(call $bind_prim (i32.const 0xE46C) (i32.const 15) (i32.const 86)) ;; string-contains
|
|
(call $bind_prim (i32.const 0xE47C) (i32.const 11) (i32.const 87)) ;; string-join
|
|
(call $bind_prim (i32.const 0xE490) (i32.const 6) (i32.const 88)) ;; vector
|
|
(call $bind_prim (i32.const 0xE498) (i32.const 7) (i32.const 89)) ;; vector?
|
|
(call $bind_prim (i32.const 0xE4A0) (i32.const 11) (i32.const 90)) ;; make-vector
|
|
(call $bind_prim (i32.const 0xE4AC) (i32.const 13) (i32.const 91)) ;; vector-length
|
|
(call $bind_prim (i32.const 0xE4BC) (i32.const 10) (i32.const 92)) ;; vector-ref
|
|
(call $bind_prim (i32.const 0xE4C8) (i32.const 11) (i32.const 93)) ;; vector-set!
|
|
(call $bind_prim (i32.const 0xE4D4) (i32.const 12) (i32.const 94)) ;; vector->list
|
|
(call $bind_prim (i32.const 0xE4E4) (i32.const 12) (i32.const 95)) ;; list->vector
|
|
(call $bind_prim (i32.const 0xE4F4) (i32.const 15) (i32.const 96)) ;; make-hash-table
|
|
(call $bind_prim (i32.const 0xE504) (i32.const 11) (i32.const 97)) ;; hash-table?
|
|
(call $bind_prim (i32.const 0xE510) (i32.const 15) (i32.const 98)) ;; hash-table-set!
|
|
(call $bind_prim (i32.const 0xE520) (i32.const 14) (i32.const 99)) ;; hash-table-ref
|
|
(call $bind_prim (i32.const 0xE530) (i32.const 22) (i32.const 100)) ;; hash-table-ref/default
|
|
(call $bind_prim (i32.const 0xE548) (i32.const 18) (i32.const 101)) ;; hash-table-delete!
|
|
(call $bind_prim (i32.const 0xE55C) (i32.const 18) (i32.const 102)) ;; hash-table-exists?
|
|
(call $bind_prim (i32.const 0xE570) (i32.const 15) (i32.const 103)) ;; hash-table-size
|
|
(call $bind_prim (i32.const 0xE580) (i32.const 15) (i32.const 104)) ;; hash-table-keys
|
|
(call $bind_prim (i32.const 0xE590) (i32.const 17) (i32.const 105)) ;; hash-table-values
|
|
(call $bind_prim (i32.const 0xE5A4) (i32.const 17) (i32.const 106)) ;; hash-table->alist
|
|
(call $bind_prim (i32.const 0xE5B8) (i32.const 5) (i32.const 107)) ;; write
|
|
(call $bind_prim (i32.const 0xE5C0) (i32.const 12) (i32.const 108)) ;; write-string
|
|
(call $bind_prim (i32.const 0xE5D0) (i32.const 10) (i32.const 109)) ;; bend!-call
|
|
(call $eval_prelude))
|
|
|
|
;; ─── Public eval entry ─────────────────────────────────────────
|
|
;; JS writes UTF-8 source into 0x20000 and calls lumbda_eval(len).
|
|
;; Returns: nothing. Output is at 0x10000, length in $output_len.
|
|
(func $lumbda_eval (export "lumbda_eval") (param $src_len i32)
|
|
(local $val i32)
|
|
(call $lumbda_init)
|
|
(global.set $output_len (i32.const 0))
|
|
(global.set $flush_start (i32.const 0))
|
|
(global.set $source_ptr (i32.const 0x20000))
|
|
(global.set $source_end (i32.add (i32.const 0x20000) (local.get $src_len)))
|
|
(local.set $val (global.get $VOID))
|
|
(block $done
|
|
(loop $loop
|
|
(call $skip_ws)
|
|
(br_if $done (i32.ge_u (global.get $source_ptr) (global.get $source_end)))
|
|
;; Top-level env = NIL. env_lookup walks env to NIL then falls back
|
|
;; to the CURRENT global_env. Closures defined at top-level capture
|
|
;; NIL too, so when re-running a demo the new top-level defines are
|
|
;; visible without older snapshots shadowing them. Without this,
|
|
;; running mandelbrot twice on a cached instance corrupts every
|
|
;; other cell because escape-count's captured global_env points
|
|
;; into a chain that no longer reflects current bindings.
|
|
(local.set $val (call $eval (call $read) (global.get $NIL)))
|
|
(br $loop)))
|
|
(if (i32.ne (local.get $val) (global.get $VOID))
|
|
(then
|
|
(if (i32.gt_u (global.get $output_len) (i32.const 0))
|
|
(then
|
|
(if (i32.ne
|
|
(i32.load8_u
|
|
(i32.sub (i32.add (i32.const 0x10000) (global.get $output_len))
|
|
(i32.const 1)))
|
|
(i32.const 10))
|
|
(then (call $out_char (i32.const 10))))))
|
|
(call $print_value (local.get $val))))
|
|
;; Trailing-content flush — print_value's repr doesn't end with a
|
|
;; newline, so any bytes past $flush_start would otherwise miss
|
|
;; the streaming path and only reach the UI through the final
|
|
;; lumbda_output_ptr / lumbda_output_len read. If the host
|
|
;; consumed it, recycle the buffer so the final output_ptr/len
|
|
;; read returns 0 bytes — the loader already accumulated the
|
|
;; trailing slice via emit_chunk, no need to re-deliver. If the
|
|
;; host didn't consume (return 0), advance flush_start so a
|
|
;; later final-buffer read still sees the content.
|
|
(block $skip_trail
|
|
(br_if $skip_trail
|
|
(i32.le_u (global.get $output_len) (global.get $flush_start)))
|
|
(if (call $js_emit_chunk
|
|
(i32.add (i32.const 0x10000) (global.get $flush_start))
|
|
(i32.sub (global.get $output_len) (global.get $flush_start)))
|
|
(then
|
|
(global.set $output_len (i32.const 0))
|
|
(global.set $flush_start (i32.const 0)))
|
|
(else
|
|
(global.set $flush_start (global.get $output_len)))))
|
|
;; Trigger GC when the heap exceeds 60% of available memory. This is
|
|
;; the only safe collection point — the eval call stack has unwound,
|
|
;; so the only roots are the globals the collector knows about.
|
|
(if (i32.gt_u
|
|
(i32.sub (global.get $heap_ptr) (i32.const 0x30000))
|
|
(i32.div_u (i32.mul (memory.size) (i32.const 65536)) (i32.const 2)))
|
|
(then (call $gc_collect))))
|
|
|
|
;; Manual GC trigger, exposed so JS can force-collect (e.g. the REPL's
|
|
;; "reboot tier" button could call this instead of terminating the
|
|
;; worker for a softer reclaim).
|
|
(func $lumbda_gc (export "lumbda_gc")
|
|
(call $gc_collect))
|
|
|
|
(func $lumbda_output_ptr (export "lumbda_output_ptr") (result i32)
|
|
(i32.const 0x10000))
|
|
(func $lumbda_output_len (export "lumbda_output_len") (result i32)
|
|
(global.get $output_len))
|
|
(func $lumbda_source_ptr (export "lumbda_source_ptr") (result i32)
|
|
(i32.const 0x20000))
|
|
|
|
;; Heap diagnostics — JS-side memory pressure indicators. heap_used is
|
|
;; bytes consumed by the bump allocator since boot; heap_total is the
|
|
;; current memory.size in bytes. No GC yet so heap_used only grows;
|
|
;; the REPL "reboot tier" button is the user-facing reclaim path.
|
|
(func $lumbda_heap_used (export "lumbda_heap_used") (result i32)
|
|
(i32.sub (global.get $heap_ptr) (i32.const 0x30000)))
|
|
(func $lumbda_heap_total (export "lumbda_heap_total") (result i32)
|
|
(i32.mul (memory.size) (i32.const 65536)))
|
|
)
|