You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
2984 lines
117 KiB
2984 lines
117 KiB
;; lisp.wat |
|
|
|
(module |
|
|
|
;; Import our myprint function |
|
(import "env" "jsprint" (func $jsprint (param i32))) |
|
|
|
;; Define a single page memory of 64KB. |
|
(memory $0 32) |
|
;; (data (i32.const 0) "0") |
|
;; (data (i32.const 4) "65536") |
|
|
|
;; Store the Hello World (null terminated) string at byte offset 0 |
|
;; (data (i32.const 0) "Hello World!\00") |
|
|
|
;; Export the memory so it can be access in the host environment. |
|
(export "pagememory" (memory $0)) |
|
|
|
;; Define a function to be called from our host |
|
(func $helloworld |
|
(call $jsprint (i32.const 0))) |
|
|
|
(global $free_list_start (mut i32) (i32.const 0)) |
|
|
|
;; Env |
|
(global $env (mut i32) (i32.const 0)) |
|
|
|
;; Types |
|
(global $cons i32 (i32.const 1)) |
|
(global $symbol i32 (i32.const 2)) |
|
(global $number i32 (i32.const 3)) |
|
(global $lambda i32 (i32.const 4)) |
|
(global $char i32 (i32.const 5)) |
|
(global $error i32 (i32.const 6)) |
|
|
|
(global $symbols (mut i32) (i32.const 0)) |
|
;; Symbols |
|
(global $nil (mut i32) (i32.const 0)) |
|
(global $true (mut i32) (i32.const 0)) |
|
(global $ampbody (mut i32) (i32.const 0)) |
|
(global $amprest (mut i32) (i32.const 0)) |
|
|
|
;; OPS |
|
(global $op:add (mut i32) (i32.const 0)) |
|
(global $op:sub (mut i32) (i32.const 0)) |
|
(global $op:mul (mut i32) (i32.const 0)) |
|
(global $op:div (mut i32) (i32.const 0)) |
|
(global $op:bit-xor (mut i32) (i32.const 0)) |
|
(global $op:bit-or (mut i32) (i32.const 0)) |
|
(global $op:bit-and (mut i32) (i32.const 0)) |
|
(global $op:bit-not (mut i32) (i32.const 0)) |
|
(global $op:mod (mut i32) (i32.const 0)) |
|
(global $op:pow (mut i32) (i32.const 0)) |
|
(global $op:sqrt (mut i32) (i32.const 0)) |
|
(global $op:eq (mut i32) (i32.const 0)) |
|
(global $op:gt (mut i32) (i32.const 0)) |
|
(global $op:ge (mut i32) (i32.const 0)) |
|
(global $op:lt (mut i32) (i32.const 0)) |
|
(global $op:le (mut i32) (i32.const 0)) |
|
(global $op:and (mut i32) (i32.const 0)) |
|
(global $op:or (mut i32) (i32.const 0)) |
|
(global $op:if (mut i32) (i32.const 0)) |
|
(global $op:not (mut i32) (i32.const 0)) |
|
(global $op:ne (mut i32) (i32.const 0)) |
|
(global $op:let (mut i32) (i32.const 0)) |
|
(global $op:def (mut i32) (i32.const 0)) |
|
(global $op:set (mut i32) (i32.const 0)) |
|
(global $op:fn (mut i32) (i32.const 0)) |
|
(global $op:list (mut i32) (i32.const 0)) |
|
(global $op:cons (mut i32) (i32.const 0)) |
|
(global $op:car (mut i32) (i32.const 0)) |
|
(global $op:cdr (mut i32) (i32.const 0)) |
|
(global $op:quote (mut i32) (i32.const 0)) |
|
(global $op:eval (mut i32) (i32.const 0)) |
|
(global $op:read (mut i32) (i32.const 0)) |
|
(global $op:set-macro-character (mut i32) (i32.const 0)) |
|
(global $op:defmacro (mut i32) (i32.const 0)) |
|
(global $op:print (mut i32) (i32.const 0)) |
|
(global $op:loop (mut i32) (i32.const 0)) |
|
(global $op:break (mut i32) (i32.const 0)) |
|
(global $op:continue (mut i32) (i32.const 0)) |
|
(global $op:return (mut i32) (i32.const 0)) |
|
|
|
;; Reader |
|
(global $reader-ptr (mut i32) (i32.const 0)) |
|
(global $reader-pos (mut i32) (i32.const 0)) |
|
(global $reader-macro-characters (mut i32) (i32.const 0)) |
|
|
|
;; Output |
|
(global $output-stream (mut i32) (i32.const 0)) |
|
(global $output-stream-index (mut i32) (i32.const 0)) |
|
(global $output-stream-length (mut i32) (i32.const 0)) |
|
|
|
;; Macros |
|
(global $macros (mut i32) (i32.const 10)) |
|
|
|
(func $main |
|
(local $cons i32) |
|
(local $car i32) |
|
(local $cdr i32) |
|
;; Memory mapping |
|
(i32.store (i32.const 0) (i32.const -1)) |
|
(i32.store (i32.const 4) (i32.const 2097152)) |
|
|
|
;; Setup symbols |
|
(global.set $nil |
|
(call $define-symbol/i32 (i32.const 0x004C494E))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $nil) |
|
(global.get $nil))) |
|
|
|
;; T symbol |
|
(global.set $true |
|
(call $define-symbol/i32 (i32.const 0x0054))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $true) |
|
(local.get $cons))) |
|
|
|
;; &body symbol |
|
(global.set $ampbody |
|
(call $define-symbol/i64 (i64.const 0x0059444F4226))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $ampbody) |
|
(local.get $cons))) |
|
|
|
;; &rest symbol |
|
(global.set $amprest |
|
(call $define-symbol/i64 (i64.const 0x005453455226))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $amprest) |
|
(local.get $cons))) |
|
|
|
;; + symbol |
|
(global.set $op:add |
|
(call $define-symbol/i32 (i32.const 0x002B))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:add) |
|
(local.get $cons))) |
|
|
|
;; - symbol |
|
(global.set $op:sub |
|
(call $define-symbol/i32 (i32.const 0x002D))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:sub) |
|
(local.get $cons))) |
|
|
|
;; * symbol |
|
(global.set $op:mul |
|
(call $define-symbol/i32 (i32.const 0x002A))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:mul) |
|
(local.get $cons))) |
|
|
|
;; / symbol |
|
(global.set $op:div |
|
(call $define-symbol/i32 (i32.const 0x002F))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:div) |
|
(local.get $cons))) |
|
|
|
;; ^ symbol |
|
(global.set $op:bit-xor |
|
(call $define-symbol/i32 (i32.const 0x005E))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:bit-xor) |
|
(local.get $cons))) |
|
|
|
;; | symbol |
|
(global.set $op:bit-or |
|
(call $define-symbol/i32 (i32.const 0x007C))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:bit-or) |
|
(local.get $cons))) |
|
|
|
;; & symbol |
|
(global.set $op:bit-and |
|
(call $define-symbol/i32 (i32.const 0x0026))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:bit-and) |
|
(local.get $cons))) |
|
|
|
;; ~ symbol |
|
(global.set $op:bit-not |
|
(call $define-symbol/i32 (i32.const 0x007E))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:bit-not) |
|
(local.get $cons))) |
|
|
|
;; % symbol |
|
(global.set $op:mod |
|
(call $define-symbol/i32 (i32.const 0x0025))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:mod) |
|
(local.get $cons))) |
|
|
|
;; pow symbol |
|
(global.set $op:pow |
|
(call $define-symbol/i32 (i32.const 0x00574F50))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:pow) |
|
(local.get $cons))) |
|
|
|
;; sqrt symbol |
|
(global.set $op:sqrt |
|
(call $define-symbol/i64 (i64.const 0x0054525153))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:sqrt) |
|
(local.get $cons))) |
|
|
|
;; = symbol |
|
(global.set $op:eq |
|
(call $define-symbol/i32 (i32.const 0x003D))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:eq) |
|
(local.get $cons))) |
|
|
|
;; > symbol |
|
(global.set $op:gt |
|
(call $define-symbol/i32 (i32.const 0x003E))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:gt) |
|
(local.get $cons))) |
|
|
|
;; >= symbol |
|
(global.set $op:ge |
|
(call $define-symbol/i32 (i32.const 0x003D3E))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:ge) |
|
(local.get $cons))) |
|
|
|
;; < symbol |
|
(global.set $op:lt |
|
(call $define-symbol/i32 (i32.const 0x003C))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:lt) |
|
(local.get $cons))) |
|
|
|
;; <= symbol |
|
(global.set $op:le |
|
(call $define-symbol/i32 (i32.const 0x003D3C))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:le) |
|
(local.get $cons))) |
|
|
|
;; && symbol |
|
(global.set $op:and |
|
(call $define-symbol/i32 (i32.const 0x002626))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:and) |
|
(local.get $cons))) |
|
|
|
;; || symbol |
|
(global.set $op:or |
|
(call $define-symbol/i32 (i32.const 0x007C7C))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:or) |
|
(local.get $cons))) |
|
|
|
;; if symbol |
|
(global.set $op:if |
|
(call $define-symbol/i32 (i32.const 0x004649))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:if) |
|
(local.get $cons))) |
|
|
|
;; ! symbol |
|
(global.set $op:not |
|
(call $define-symbol/i32 (i32.const 0x0021))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:not) |
|
(local.get $cons))) |
|
|
|
;; != symbol |
|
(global.set $op:ne |
|
(call $define-symbol/i32 (i32.const 0x003D21))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:ne) |
|
(local.get $cons))) |
|
|
|
;; let symbol |
|
(global.set $op:let |
|
(call $define-symbol/i32 (i32.const 0x0054454C))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:let) |
|
(local.get $cons))) |
|
|
|
;; def symbol |
|
(global.set $op:def |
|
(call $define-symbol/i32 (i32.const 0x00464544))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:def) |
|
(local.get $cons))) |
|
|
|
;; set symbol |
|
(global.set $op:set |
|
(call $define-symbol/i32 (i32.const 0x00544553))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:set) |
|
(local.get $cons))) |
|
|
|
;; fn symbol |
|
(global.set $op:fn |
|
(call $define-symbol/i32 (i32.const 0x004E46))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:fn) |
|
(local.get $cons))) |
|
|
|
;; list symbol |
|
(global.set $op:list |
|
(call $define-symbol/i64 (i64.const 0x005453494C))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:list) |
|
(local.get $cons))) |
|
|
|
;; cons symbol |
|
(global.set $op:cons |
|
(call $define-symbol/i64 (i64.const 0x00534E4F43))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:cons) |
|
(local.get $cons))) |
|
|
|
;; car symbol |
|
(global.set $op:car |
|
(call $define-symbol/i32 (i32.const 0x00524143))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:car) |
|
(local.get $cons))) |
|
|
|
;; cdr symbol |
|
(global.set $op:cdr |
|
(call $define-symbol/i32 (i32.const 0x00524443))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:cdr) |
|
(local.get $cons))) |
|
|
|
;; quote symbol |
|
(global.set $op:quote |
|
(call $define-symbol/i64 (i64.const 0x0045544F5551))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:quote) |
|
(local.get $cons))) |
|
|
|
;; eval symbol |
|
(global.set $op:eval |
|
(call $define-symbol/i64 (i64.const 0x004C415645))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:eval) |
|
(local.get $cons))) |
|
|
|
;; read symbol |
|
(global.set $op:read |
|
(call $define-symbol/i64 (i64.const 0x0044414552))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:read) |
|
(local.get $cons))) |
|
|
|
;; set-macro-character symbol |
|
(global.set $op:set-macro-character |
|
(call $define-symbol/i160 |
|
(i64.const 0x5243414D2D544553) |
|
(i64.const 0x4341524148432D4F) |
|
(i32.const 0x00524554))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:set-macro-character) |
|
(local.get $cons))) |
|
|
|
;; defmacro symbol |
|
(global.set $op:defmacro |
|
(call $define-symbol/i96 |
|
(i64.const 0x4F5243414D464544) |
|
(i32.const 0))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:defmacro) |
|
(local.get $cons))) |
|
|
|
;; print symbol |
|
(global.set $op:print |
|
(call $define-symbol/i64 (i64.const 0x00544E495250))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:print) |
|
(local.get $cons))) |
|
|
|
;; loop symbol |
|
(global.set $op:loop |
|
(call $define-symbol/i64 (i64.const 0x00504F4F4C))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:loop) |
|
(local.get $cons))) |
|
|
|
;; break symbol |
|
(global.set $op:break |
|
(call $define-symbol/i64 (i64.const 0x004B41455242))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:break) |
|
(local.get $cons))) |
|
|
|
;; continue symbol |
|
(global.set $op:continue |
|
(call $define-symbol/i96 |
|
(i64.const 0x45554E49544E4F43) |
|
(i32.const 0x00))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:continue) |
|
(local.get $cons))) |
|
|
|
;; return symbol |
|
(global.set $op:return |
|
(call $define-symbol/i64 (i64.const 0x004E5255544552))) |
|
(local.set $cons (call $add-symbol-to-list |
|
(global.get $op:return) |
|
(local.get $cons))) |
|
|
|
(global.set $symbols (local.get $cons)) |
|
(global.set $env (global.get $nil)) |
|
(global.set $reader-macro-characters (global.get $nil)) |
|
(global.set $macros (global.get $nil))) |
|
;; 65536 |
|
|
|
(start $main) |
|
|
|
(func $add-symbol-to-list (param $symbol i32) (param $cdr i32) (result i32) |
|
(local $cons i32) |
|
(local.set $cons (call $alloc (i32.const 8))) |
|
(i32.store (local.get $cons) (local.get $symbol)) |
|
(i32.store (i32.add (local.get $cons) (i32.const 4)) (local.get $cdr)) |
|
(local.get $cons)) |
|
|
|
(func $define-symbol/i32 (param $text i32) (result i32) |
|
(local $symbol i32) |
|
(local.set $symbol (call $alloc (i32.const 8))) |
|
(i32.store (local.get $symbol) (global.get $symbol)) |
|
(i32.store (i32.add (local.get $symbol) (i32.const 4)) (local.get $text)) |
|
(local.get $symbol)) |
|
|
|
(func $define-symbol/i64 (param $text i64) (result i32) |
|
(local $symbol i32) |
|
(local.set $symbol (call $alloc (i32.const 12))) |
|
(i32.store (local.get $symbol) (global.get $symbol)) |
|
(i64.store (i32.add (local.get $symbol) (i32.const 4)) (local.get $text)) |
|
(local.get $symbol)) |
|
|
|
(func $define-symbol/i96 (param $text1 i64) (param $text2 i32) (result i32) |
|
(local $symbol i32) |
|
(local.set $symbol (call $alloc (i32.const 16))) |
|
(i32.store (local.get $symbol) (global.get $symbol)) |
|
(i64.store (i32.add (local.get $symbol) (i32.const 4)) (local.get $text1)) |
|
(i32.store (i32.add (local.get $symbol) (i32.const 12)) (local.get $text2)) |
|
(local.get $symbol)) |
|
|
|
(func $define-symbol/i160 (param $text1 i64) (param $text2 i64) (param $text3 i32) |
|
(result i32) |
|
(local $symbol i32) |
|
(local.set $symbol (call $alloc (i32.const 24))) |
|
(i32.store (local.get $symbol) (global.get $symbol)) |
|
(i64.store (i32.add (local.get $symbol) (i32.const 4)) (local.get $text1)) |
|
(i64.store (i32.add (local.get $symbol) (i32.const 12)) (local.get $text2)) |
|
(i32.store (i32.add (local.get $symbol) (i32.const 20)) (local.get $text3)) |
|
(local.get $symbol)) |
|
|
|
(func $align (export "align") |
|
(param $n i32) (param $word i32) (result i32) |
|
|
|
(i32.and |
|
(i32.sub (i32.add (local.get $n) |
|
(local.get $word)) |
|
(i32.const 1)) |
|
(i32.xor (i32.sub (local.get $word) |
|
(i32.const 1)) |
|
(i32.const 0xffffffff)))) |
|
|
|
(func $i32.min (export "min") (param $a i32) (param $b i32) (result i32) |
|
(i32.xor (local.get $b) |
|
(i32.and (i32.xor (local.get $a) |
|
(local.get $b)) |
|
(i32.mul (i32.const -1) |
|
(i32.lt_s (local.get $a) |
|
(local.get $b)))))) |
|
|
|
(func $i32.max (export "max") (param $a i32) (param $b i32) (result i32) |
|
(i32.xor (local.get $a) |
|
(i32.and (i32.xor (local.get $a) |
|
(local.get $b)) |
|
(i32.mul (i32.const -1) |
|
(i32.lt_s (local.get $a) |
|
(local.get $b)))))) |
|
|
|
(func $alloc (export "alloc") |
|
(param $size i32) (result i32) |
|
(local $free_node_index i32) |
|
(local $free_node_last_index i32) |
|
(local $free_node_next_index i32) |
|
(local $free_node_size i32) |
|
(local.set $size (call $align (local.get $size) (i32.const 8))) |
|
;; (local.set $size (call $i32.max (local.get $size) (i32.const 8))) |
|
(local.set $free_node_index (global.get $free_list_start)) |
|
(local.set $free_node_last_index (global.get $free_list_start)) |
|
(loop $continue |
|
(block $break |
|
(local.set $free_node_size |
|
(i32.load (i32.add (local.get $free_node_index) |
|
(i32.const 4)))) |
|
(local.set $free_node_next_index (i32.load (local.get $free_node_index))) |
|
(br_if $break |
|
(i32.le_u (local.get $size) |
|
(local.get $free_node_size))) |
|
(local.set $free_node_last_index (local.get $free_node_index)) |
|
(local.set $free_node_index (local.get $free_node_next_index)) |
|
(if (i32.eq (local.get $free_node_next_index) (i32.const -1)) |
|
(then (return (i32.const -1)))) ;; No free slot to alloc to! |
|
(br $continue))) |
|
(if (i32.lt_u (local.get $size) |
|
(local.get $free_node_size)) |
|
(then (i32.store (i32.add (local.get $free_node_index) |
|
(local.get $size)) |
|
(local.get $free_node_next_index)) |
|
(i32.store (i32.add (i32.add (local.get $free_node_index) |
|
(local.get $size)) |
|
(i32.const 4)) |
|
(i32.sub (local.get $free_node_size) |
|
(local.get $size))) |
|
(if (i32.eq (local.get $free_node_last_index) |
|
(global.get $free_list_start)) |
|
(then (global.set $free_list_start |
|
(i32.add (local.get $free_node_index) |
|
(local.get $size)))) |
|
(else (i32.store (local.get $free_node_last_index) |
|
(i32.add (local.get $free_node_index) |
|
(local.get $size)))))) |
|
(else (if (i32.eq (local.get $free_node_last_index) |
|
(global.get $free_list_start)) |
|
(then (global.set $free_list_start |
|
(local.get $free_node_next_index))) |
|
(else (i32.store (local.get $free_node_last_index) |
|
(local.get $free_node_next_index)))))) |
|
|
|
;; Could clear the memory, but meh. Just like C, I give you dirty memory, have fun buddy! |
|
;; (return (call $create_pointer (local.get $free_node_index) (local.get $size))) |
|
(local.get $free_node_index)) |
|
|
|
(func $free (export "free") (param $index i32) (param $size i32) |
|
(local $i i32) |
|
(local $i_size i32) |
|
(local $next i32) |
|
|
|
(local $previous_block_index i32) |
|
(local $previous_block_size i32) |
|
(local $previous_block_next i32) |
|
(local $previous_block_previous i32) |
|
|
|
(local $next_block_index i32) |
|
(local $next_block_size i32) |
|
(local $next_block_next i32) |
|
(local $next_block_previous i32) |
|
|
|
(local.set $size (call $align (local.get $size) (i32.const 4))) |
|
(local.set $size (call $i32.max (local.get $size) (i32.const 8))) |
|
|
|
(local.set $i (global.get $free_list_start)) |
|
|
|
(local.set $previous_block_index (i32.const -1)) |
|
(local.set $previous_block_next (i32.const -1)) |
|
(local.set $previous_block_previous (i32.const -1)) |
|
(local.set $next_block_index (i32.const -1)) |
|
(local.set $next_block_next (i32.const -1)) |
|
(local.set $next_block_previous (i32.const -1)) |
|
|
|
(loop $continue |
|
(block $break |
|
(local.set $next (i32.load (local.get $i))) |
|
(local.set $i_size (i32.load (i32.add (local.get $i) (i32.const 4)))) |
|
|
|
(if (i32.eq (i32.add (local.get $next) |
|
(i32.load (i32.add (local.get $next) |
|
(i32.const 4)))) |
|
(local.get $index)) |
|
(then (local.set $previous_block_previous (local.get $i)))) |
|
|
|
(if (i32.eq (i32.add (local.get $i) (local.get $i_size)) |
|
(local.get $index)) |
|
(then (local.set $previous_block_index (local.get $i)) |
|
(local.set $previous_block_size (local.get $i_size)) |
|
(local.set $previous_block_next (local.get $next)))) |
|
|
|
(if (i32.eq (i32.add (local.get $index) (local.get $size)) |
|
(local.get $next)) |
|
(then (local.set $next_block_previous (local.get $i)))) |
|
|
|
(if (i32.eq (i32.add (local.get $index) (local.get $size)) |
|
(local.get $i)) |
|
(then (local.set $next_block_index (local.get $i)) |
|
(local.set $next_block_size (local.get $i_size)) |
|
(local.set $next_block_next (local.get $next)))) |
|
|
|
(br_if $break (i32.eq (local.get $next) (i32.const -1))) |
|
(local.set $i (local.get $next)) |
|
(br $continue))) |
|
|
|
;; Fix the links of the swallowed blocks |
|
(if (i32.and (i32.ne (local.get $next_block_index) (i32.const -1)) |
|
(i32.ne (local.get $previous_block_index) (i32.const -1))) |
|
(then (if (i32.eq (local.get $previous_block_next) (local.get $next_block_index)) |
|
(then (if (i32.eq (local.get $previous_block_previous) (i32.const -1)) |
|
(then (global.set $free_list_start (local.get $next_block_next))) |
|
(else (i32.store (local.get $previous_block_previous) |
|
(local.get $next_block_next))))) |
|
(else (if (i32.eq (local.get $next_block_next) (local.get $previous_block_index)) |
|
(then (if (i32.eq (local.get $next_block_previous) (i32.const -1)) |
|
(then (global.set $free_list_start (local.get $previous_block_next))) |
|
(else (i32.store (local.get $next_block_previous) |
|
(local.get $previous_block_next))))) |
|
(else (if (i32.ne (local.get $previous_block_previous) (i32.const -1)) |
|
(then (i32.store (local.get $previous_block_previous) |
|
(local.get $previous_block_next))) |
|
(else (global.set $free_list_start (local.get $previous_block_next)))) |
|
(if (i32.ne (local.get $next_block_previous) (i32.const -1)) |
|
(then (i32.store (local.get $next_block_previous) |
|
(local.get $next_block_next))) |
|
(else (global.set $free_list_start (local.get $next_block_next))))))))) ;; Block Avant => Block Apres |
|
(else (if (i32.ne (local.get $previous_block_index) (i32.const -1)) |
|
(then (if (i32.ne (local.get $previous_block_previous) (i32.const -1)) |
|
(then (i32.store (local.get $previous_block_previous) |
|
(local.get $previous_block_next))) |
|
(else (global.set $free_list_start (local.get $previous_block_next)))))) |
|
(if (i32.ne (local.get $next_block_index) (i32.const -1)) |
|
(then (if (i32.ne (local.get $next_block_previous) (i32.const -1)) |
|
(then (i32.store (local.get $next_block_previous) |
|
(local.get $next_block_next))) |
|
(else (global.set $free_list_start (local.get $next_block_next)))))))) |
|
|
|
(if (i32.ne (local.get $previous_block_index) (i32.const -1)) |
|
(then (local.set $index (local.get $previous_block_index)) |
|
(local.set $size (i32.add (local.get $size) |
|
(local.get $previous_block_size))))) |
|
|
|
(if (i32.ne (local.get $next_block_index) (i32.const -1)) |
|
(then (local.set $size (i32.add (local.get $size) |
|
(local.get $next_block_size))))) |
|
|
|
(i32.store (local.get $index) |
|
(global.get $free_list_start)) |
|
(i32.store (i32.add (local.get $index) (i32.const 4)) |
|
(local.get $size)) |
|
(global.set $free_list_start (local.get $index))) |
|
|
|
;; REP |
|
|
|
(func $is-number (export "is_number") (param $ptr i32) (param $len i32) (result i32) |
|
(local $c i32) |
|
(local $i i32) |
|
(local $is-decimal i32) |
|
(local $has-exponent i32) |
|
(local $result i32) |
|
|
|
(loop $continue |
|
(block $break |
|
(br_if $break (i32.ge_u (local.get $i) (local.get $len))) |
|
(local.set $c (i32.load8_u (i32.add (local.get $ptr) (local.get $i)))) |
|
|
|
(if (i32.and (i32.ge_u (local.get $c) (i32.const 48)) ;; 0 |
|
(i32.le_u (local.get $c) (i32.const 57))) ;; 9 |
|
(then (local.set $i (i32.add (local.get $i) (i32.const 1))) |
|
(br $continue))) |
|
|
|
(if (i32.and (i32.eq (local.get $c) (i32.const 46)) ;; . |
|
(i32.ne (local.get $is-decimal) (i32.const 1))) |
|
(then (local.set $is-decimal (i32.const 1)) |
|
(local.set $i (i32.add (local.get $i) (i32.const 1))) |
|
(br $continue))) |
|
|
|
(if (i32.and (i32.eqz (local.get $i)) ;; at sign position |
|
(i32.or (i32.eq (local.get $c) (i32.const 43)) ;; + |
|
(i32.eq (local.get $c) (i32.const 45)))) ;; - |
|
(then (local.set $i (i32.add (local.get $i) (i32.const 1))) |
|
(br $continue))) |
|
|
|
(if (i32.and (i32.or (i32.eq (local.get $c) (i32.const 101)) ;; e |
|
(i32.eq (local.get $c) (i32.const 69))) ;; E |
|
(i32.eq (local.get $has-exponent) (i32.const 1))) |
|
(then (local.set $has-exponent (i32.const 1)) |
|
(local.set $i (i32.add (local.get $i) (i32.const 1))) |
|
(br $continue))) |
|
|
|
(return (i32.const 0)))) |
|
|
|
(i32.const 1)) |
|
|
|
(func $normalize-left (param $mantissa i64) (param $rest i32) (result i64) |
|
(loop $continue |
|
(block $break |
|
(br_if $break (i64.gt_u (i64.and (local.get $mantissa) |
|
(i64.const 0x8000000000000000)) |
|
(i64.const 0))) |
|
(local.set $mantissa (i64.add (i64.shl (local.get $mantissa) (i64.const 1)) |
|
(i64.const 1))) |
|
(local.set $rest (i32.shl (local.get $rest) (i32.const 1))) |
|
(br $continue))) |
|
(local.get $mantissa)) |
|
|
|
(func $i64.normalize-left (param $num i64) (param $target i64) (result i64) |
|
(if (i64.eqz (local.get $num)) |
|
(then (return (i64.const 0)))) |
|
(loop $continue |
|
(block $break |
|
(br_if $break (i64.gt_u (i64.and (local.get $num) |
|
(local.get $target)) |
|
(i64.const 0))) |
|
(local.set $num (i64.shl (local.get $num) (i64.const 1))) |
|
(br $continue))) |
|
(local.get $num)) |
|
|
|
(func $i32.normalize-left (param $num i32) (param $target i32) (result i32) |
|
(if (i32.eqz (local.get $num)) |
|
(then (return (i32.const 0)))) |
|
(loop $continue |
|
(block $break |
|
(br_if $break (i32.gt_u (i32.and (local.get $num) |
|
(local.get $target)) |
|
(i32.const 0))) |
|
(local.set $num (i32.shl (local.get $num) (i32.const 1))) |
|
(br $continue))) |
|
(local.get $num)) |
|
|
|
(global $f64-plus-zero i64 (i64.const 0x0000000000000000)) |
|
(global $f64-minus-zero i64 (i64.const 0x8000000000000000)) |
|
(global $f64-plus-infinity i64 (i64.const 0x7FF0000000000000)) |
|
(global $f64-minus-infinity i64 (i64.const 0xFFF0000000000000)) |
|
(global $f64-nan i64 (i64.const 0xFFF0000000000001)) |
|
|
|
(func $to-float (param $sign i32) (param $mantissa i64) (param $exponent i32) (result f64) |
|
(local $2-exponent i32) |
|
(local $whole i64) |
|
(local $rest i32) |
|
(if (i64.eqz (local.get $mantissa)) |
|
(if (i32.eqz (local.get $sign)) |
|
(then (return (f64.reinterpret/i64 (global.get $f64-plus-zero)))) |
|
(else (return (f64.reinterpret/i64 (global.get $f64-minus-zero)))))) |
|
(local.set $whole (local.get $mantissa)) |
|
|
|
(if (i32.gt_s (local.get $exponent) (i32.const 0)) |
|
(then (loop $continue |
|
(block $break |
|
(br_if $break (i64.eq (local.get $whole) (i64.const 1))) |
|
(local.set $2-exponent (i32.add (local.get $2-exponent) (i32.const 1))) |
|
(local.set $whole (i64.shr_u (local.get $whole) (i64.const 1))) |
|
(br $continue))) |
|
(loop $continue |
|
(block $break |
|
(br_if $break (i32.eqz (local.get $exponent))) |
|
(local.set $exponent (i32.sub (local.get $exponent) (i32.const 1))) |
|
(local.set $mantissa (call $i64.normalize-left |
|
(local.get $mantissa) |
|
(i64.const 0x0800000000000000))) |
|
(local.set $mantissa (i64.mul (local.get $mantissa) (i64.const 10))) |
|
(loop $continue-2-exponent |
|
(block $break-2-exponent |
|
(br_if $break-2-exponent (i64.eqz (i64.and (local.get $mantissa) |
|
(i64.const 0xF000000000000000)))) |
|
(local.set $2-exponent (i32.add (local.get $2-exponent) (i32.const 1))) |
|
(local.set $mantissa (i64.shr_u (local.get $mantissa) (i64.const 1))) |
|
(br $continue-2-exponent))) |
|
(br $continue)))) |
|
(else (local.set $mantissa (call $i64.normalize-left |
|
(local.get $mantissa) |
|
(i64.const 0x8000000000000000))) |
|
(loop $continue |
|
(block $break |
|
(br_if $break (i32.eqz (local.get $exponent))) |
|
(local.set $exponent (i32.add (local.get $exponent) (i32.const 1))) |
|
|
|
(local.set $rest (i32.wrap/i64 (i64.rem_u (local.get $mantissa) |
|
(i64.const 10)))) |
|
(local.set $rest (call $i32.normalize-left |
|
(i32.div_u (i32.shl (call $i32.normalize-left |
|
(local.get $rest) |
|
(i32.const 0x00000008)) |
|
(i32.const 28)) |
|
(i32.const 10)) |
|
(i32.const 0x80000000))) |
|
(local.set $mantissa (i64.div_u (local.get $mantissa) (i64.const 10))) |
|
|
|
(local.set $2-exponent (i32.sub (local.get $2-exponent) |
|
(i64.eqz (i64.and (local.get $mantissa) |
|
(i64.const 0x8000000000000000))))) |
|
(local.set $2-exponent (i32.sub (local.get $2-exponent) |
|
(i64.eqz (i64.and (local.get $mantissa) |
|
(i64.const 0xC000000000000000))))) |
|
(local.set $2-exponent (i32.sub (local.get $2-exponent) |
|
(i64.eqz (i64.and (local.get $mantissa) |
|
(i64.const 0xE000000000000000))))) |
|
(local.set $2-exponent (i32.sub (local.get $2-exponent) |
|
(i64.eqz (i64.and (local.get $mantissa) |
|
(i64.const 0xF000000000000000))))) |
|
|
|
(local.set $mantissa (call $normalize-left (local.get $mantissa) (local.get $rest))) |
|
(br $continue))) |
|
(loop $continue |
|
(block $break |
|
(br_if $break (i64.eq (local.get $whole) (i64.const 1))) |
|
(local.set $2-exponent (i32.add (local.get $2-exponent) (i32.const 1))) |
|
(local.set $whole (i64.shr_u (local.get $whole) (i64.const 1))) |
|
(br $continue))))) |
|
|
|
(local.set $mantissa (i64.shr_u (i64.shl (call $i64.normalize-left |
|
(local.get $mantissa) |
|
(i64.const 0x8000000000000000)) |
|
(i64.const 1)) |
|
(i64.const 1))) |
|
|
|
(if (i64.gt_u (i64.and (local.get $mantissa) |
|
(i64.const 0x0000000000000400)) |
|
(i64.const 0)) |
|
(then (if (i64.gt_u (i64.and (local.get $mantissa) |
|
(i64.const 0x0000000000000800)) |
|
(i64.const 0)) |
|
(then (local.set $mantissa (i64.add (local.get $mantissa) |
|
(i64.const 0x0000000000000800)))) |
|
(else (if (i64.gt_u (i64.and (local.get $mantissa) |
|
(i64.const 0x0000000000000200)) |
|
(i64.const 0)) |
|
(then (local.set $mantissa (i64.add (local.get $mantissa) |
|
(i64.const 0x0000000000000800)))) |
|
(else (if (i64.gt_u (i64.and (local.get $mantissa) |
|
(i64.const 0x0000000000000100)) |
|
(i64.const 0)) |
|
(then (local.set $mantissa (i64.add (local.get $mantissa) |
|
(i64.const 0x0000000000000800))))))))))) |
|
|
|
(if (i64.gt_u (i64.and (local.get $mantissa) |
|
(i64.const 0x8000000000000000)) |
|
(i64.const 0)) |
|
(then (local.set $2-exponent (i32.add (local.get $2-exponent) (i32.const 1))))) |
|
|
|
(if (i32.gt_s (local.get $2-exponent) (i32.const 1023)) |
|
(then (if (i32.eqz (local.get $sign)) |
|
(then (return (f64.reinterpret/i64 (global.get $f64-plus-infinity)))) |
|
(else (return (f64.reinterpret/i64 (global.get $f64-minus-infinity))))))) |
|
|
|
(f64.reinterpret/i64 |
|
(i64.xor (i64.shl (i64.extend_u/i32 (local.get $sign)) (i64.const 63)) |
|
(i64.xor (i64.shr_u (local.get $mantissa) (i64.const 11)) |
|
(i64.shl (i64.add (i64.extend_s/i32 (local.get $2-exponent)) |
|
(i64.const 1023)) |
|
(i64.const 52)))))) |
|
|
|
(func $parse-float (export "parse_float") (param $ptr i32) (param $len i32) (result f64) |
|
(local $negative i32) |
|
(local $exponent i32) |
|
(local $mantissa i64) |
|
(local $i i32) |
|
(local $c i32) |
|
(local $explicit-exponent i32) |
|
(local $explicit-exponent-sign i32) |
|
(local $nums i32) |
|
(local $has-nums i32) |
|
|
|
(local.set $c (i32.load8_u (local.get $ptr))) |
|
(if (i32.or (i32.eq (local.get $c) (i32.const 43)) |
|
(i32.eq (local.get $c) (i32.const 45))) |
|
(then (local.set $i (i32.const 1)) |
|
(local.set $negative (i32.eq (local.get $c) (i32.const 45))))) |
|
|
|
;; Trim zeros |
|
(loop $continue |
|
(block $break |
|
(br_if $break (i32.ge_u (local.get $i) (local.get $len))) |
|
(local.set $c (i32.load8_u (i32.add (local.get $ptr) (local.get $i)))) |
|
(br_if $break (i32.ne (local.get $c) (i32.const 48))) |
|
(local.set $i (i32.add (local.get $i) (i32.const 1))) |
|
(local.set $has-nums (i32.const 1)) |
|
(br $continue))) |
|
|
|
;; Parsing full numbers |
|
(loop $continue |
|
(block $break |
|
(br_if $break (i32.ge_u (local.get $i) (local.get $len))) |
|
(local.set $c (i32.load8_u (i32.add (local.get $ptr) (local.get $i)))) |
|
(br_if $break (i32.eqz (i32.and (i32.ge_u (local.get $c) (i32.const 48)) ;; 0 |
|
(i32.le_u (local.get $c) (i32.const 57))))) ;; 9 |
|
(if (i32.lt_u (local.get $nums) (i32.const 18)) |
|
(then (local.set $nums (i32.add (local.get $nums) (i32.const 1))) |
|
(local.set $mantissa (i64.add (i64.mul (local.get $mantissa) (i64.const 10)) |
|
(i64.extend_u/i32 (i32.sub (local.get $c) |
|
(i32.const 48)))))) |
|
(else (local.set $exponent (i32.add (local.get $exponent) (i32.const 1))))) |
|
(local.set $i (i32.add (local.get $i) (i32.const 1))) |
|
(local.set $has-nums (i32.const 1)) |
|
(br $continue))) |
|
|
|
;; Parsing decimal numbers |
|
(if (i32.eq (i32.load8_u (i32.add (local.get $ptr) (local.get $i))) |
|
(i32.const 46)) ;;. |
|
(then (local.set $i (i32.add (local.get $i) (i32.const 1))) |
|
(if (i64.eqz (local.get $mantissa)) |
|
(then (loop $continue |
|
(block $break |
|
(br_if $break (i32.ge_u (local.get $i) (local.get $len))) |
|
(local.set $c (i32.load8_u (i32.add (local.get $ptr) (local.get $i)))) |
|
(br_if $break (i32.ne (local.get $c) (i32.const 48))) |
|
(local.set $exponent (i32.add (local.get $exponent) (i32.const -1))) |
|
(local.set $i (i32.add (local.get $i) (i32.const 1))) |
|
(br $continue))))) |
|
(loop $continue |
|
(block $break |
|
(br_if $break (i32.ge_u (local.get $i) (local.get $len))) |
|
(local.set $c (i32.load8_u (i32.add (local.get $ptr) (local.get $i)))) |
|
(br_if $break (i32.eqz (i32.and (i32.ge_u (local.get $c) (i32.const 48)) ;; 0 |
|
(i32.le_u (local.get $c) (i32.const 57))))) ;; 9 |
|
(br_if $break (i32.ge_u (local.get $nums) (i32.const 18))) |
|
(local.set $nums (i32.add (local.get $nums) (i32.const 1))) |
|
(local.set $mantissa (i64.add (i64.mul (local.get $mantissa) (i64.const 10)) |
|
(i64.extend_u/i32 (i32.sub (local.get $c) |
|
(i32.const 48))))) |
|
(local.set $exponent (i32.add (local.get $exponent) (i32.const -1))) |
|
(local.set $i (i32.add (local.get $i) (i32.const 1))) |
|
(local.set $has-nums (i32.const 1)) |
|
(br $continue))))) |
|
|
|
;; Parsing explicit exponent |
|
(if (i32.or (i32.eq (local.get $c) (i32.const 101)) ;; e |
|
(i32.eq (local.get $c) (i32.const 69))) ;; E |
|
(then (local.set $i (i32.add (local.get $i) (i32.const 1))) |
|
(local.set $c (i32.load8_u (i32.add (local.get $ptr) (local.get $i)))) |
|
(if (i32.or (i32.eq (local.get $c) (i32.const 43)) |
|
(i32.eq (local.get $c) (i32.const 45))) |
|
(then (local.set $i (i32.add (local.get $i) (i32.const 1))) |
|
(local.set $explicit-exponent-sign (i32.eq (local.get $c) (i32.const 45))))) |
|
|
|
(local.set $nums (i32.const 0)) |
|
(loop $continue |
|
(block $break |
|
(br_if $break (i32.ge_u (local.get $i) (local.get $len))) |
|
(local.set $c (i32.load8_u (i32.add (local.get $ptr) (local.get $i)))) |
|
(br_if $break (i32.eqz (i32.and (i32.ge_u (local.get $c) (i32.const 48)) ;; 0 |
|
(i32.le_u (local.get $c) (i32.const 57))))) ;; 9 |
|
(br_if $break (i32.ge_u (local.get $nums) (i32.const 18))) |
|
(local.set $explicit-exponent |
|
(i32.add (i32.mul (local.get $explicit-exponent) (i32.const 10)) |
|
(i32.sub (local.get $c) |
|
(i32.const 48)))) |
|
(local.set $i (i32.add (local.get $i) (i32.const 1))) |
|
(br $continue))) |
|
(if (i32.eqz (local.get $explicit-exponent-sign)) |
|
(then (local.set $exponent (i32.add (local.get $exponent) |
|
(local.get $explicit-exponent)))) |
|
(else (local.set $exponent (i32.sub (local.get $exponent) |
|
(local.get $explicit-exponent))))))) |
|
|
|
;; Converting to float |
|
(if (i32.and (i32.eq (local.get $len) |
|
(local.get $i)) |
|
(local.get $has-nums)) |
|
(then (return (call $to-float |
|
(local.get $negative) |
|
(local.get $mantissa) |
|
(local.get $exponent))))) |
|
(f64.reinterpret/i64 (global.get $f64-nan))) |
|
|
|
(func $get-reader-macro-character (param $c i32) (result i32) |
|
(local $macros i32) |
|
(local.set $macros (global.get $reader-macro-characters)) |
|
(loop $continue |
|
(block $break |
|
(br_if $break (i32.eq (local.get $macros) (global.get $nil))) |
|
(if (i32.eq (i32.load (local.get $macros)) (local.get $c)) |
|
(return (i32.load (i32.add (local.get $macros) (i32.const 8))))) |
|
(local.set $macros (i32.load (i32.add (local.get $macros) (i32.const 4)))) |
|
(br $continue))) |
|
(global.get $nil)) |
|
|
|
(func $read-data (result i32) |
|
(local $start i32) |
|
(local $end i32) |
|
(local $i i32) |
|
(local $c i32) |
|
(local $size i32) |
|
(local $result i32) |
|
(local $num f64) |
|
|
|
(if (i32.and (i32.eq (call $reader-peek) (i32.const 0x23)) ;; # |
|
(i32.eq (call $reader-peek-next) (i32.const 0x5C))) ;; \ |
|
(then (local.set $result (call $alloc (i32.const 8))) |
|
(drop (call $reader-read)) |
|
(drop (call $reader-read)) |
|
(i64.store (local.get $result) (i64.xor (i64.extend_u/i32 (global.get $char)) |
|
(i64.shl (i64.extend_u/i32 (call $reader-read)) |
|
(i64.const 32))))) |
|
(else (local.set $start (global.get $reader-pos)) |
|
|
|
(loop $continue |
|
(block $break |
|
(br_if $break (i32.eqz (local.tee $c (call $reader-peek)))) |
|
|
|
(br_if $break (i32.eq (local.get $c) (i32.const 0x28))) ;; ( |
|
(br_if $break (i32.eq (local.get $c) (i32.const 0x29))) ;; ) |
|
(br_if $break (i32.eq (local.get $c) (i32.const 0x20))) ;; SPACE |
|
(br_if $break (i32.eq (local.get $c) (i32.const 0x09))) ;; TAB |
|
(br_if $break (i32.eq (local.get $c) (i32.const 0x0A))) ;; RETURN |
|
(br_if $break (i32.eq (local.get $c) (i32.const 0x3B))) ;; ; |
|
(br_if $break (i32.ne (call $get-reader-macro-character (local.get $c)) |
|
(global.get $nil))) |
|
(call $reader-read) |
|
(br $continue))) |
|
(local.set $end (global.get $reader-pos)) |
|
(local.set $size (i32.sub (local.get $end) (local.get $start))) |
|
(local.set $num (call $parse-float |
|
(i32.add (global.get $reader-ptr) (local.get $start)) |
|
(local.get $size))) |
|
(if (i64.eq (i64.reinterpret/f64 (local.get $num)) (global.get $f64-nan)) |
|
(then (local.set $result (call $read-symbol (local.get $start) (local.get $size)))) |
|
(else (local.set $result (call $alloc (i32.const 12))) |
|
(i32.store (local.get $result) (global.get $number)) |
|
(f64.store (i32.add (local.get $result) (i32.const 4)) |
|
(local.get $num)))))) |
|
;; (local.set $result (call $read-symbol (local.get $start) (local.get $size))) |
|
|
|
(local.get $result)) |
|
|
|
(func $read-symbol (param $start i32) (param $size i32) (result i32) |
|
(local $i i32) |
|
(local $result i32) |
|
(local $car i32) |
|
(local $cdr i32) |
|
(local $c i32) |
|
(local $n i32) |
|
(local $cons i32) |
|
|
|
(local.set $cdr (global.get $symbols)) |
|
|
|
(loop $continue |
|
(block $break |
|
(local.set $car (i32.load (local.get $cdr))) |
|
(local.set $cdr (i32.load (i32.add (local.get $cdr) |
|
(i32.const 4)))) |
|
|
|
(local.set $i (i32.const 0)) |
|
(loop $continue-char |
|
(block $break-char |
|
(local.set $n (i32.load8_u (i32.add (local.get $car) |
|
(i32.add (i32.const 4) |
|
(local.get $i))))) |
|
(if (i32.and (i32.eq (local.get $i) (local.get $size)) |
|
(i32.eqz (local.get $n))) |
|
(return (local.get $car))) |
|
(br_if $break-char (i32.ge_u (local.get $i) (local.get $size))) |
|
(local.set $c (i32.load8_u (i32.add (global.get $reader-ptr) |
|
(i32.add (local.get $start) |
|
(local.get $i))))) |
|
(if (i32.and (i32.ge_u (local.get $c) (i32.const 0x61)) |
|
(i32.le_u (local.get $c) (i32.const 0x7A))) |
|
(local.set $c (i32.sub (local.get $c) (i32.const 0x20)))) |
|
(br_if $break-char (i32.ne (local.get $c) (local.get $n))) |
|
(if (i32.and (i32.eqz (local.get $c)) |
|
(i32.eqz (local.get $n))) |
|
(return (local.get $car))) |
|
(local.set $i (i32.add (local.get $i) (i32.const 1))) |
|
(br $continue-char))) |
|
|
|
(br_if $break (i32.eq (local.get $cdr) (global.get $nil))) |
|
(br $continue))) |
|
|
|
(local.set $result (call $alloc (i32.add (local.get $size) (i32.const 5)))) |
|
(i32.store (local.get $result) (global.get $symbol)) |
|
|
|
|
|
(local.set $cons (call $alloc (i32.const 8))) ;; i32: car, i32: cdr |
|
(i32.store (local.get $cons) (local.get $result)) |
|
(i32.store (i32.add (local.get $cons) (i32.const 4)) |
|
(global.get $symbols)) |
|
(global.set $symbols (local.get $cons)) |
|
|
|
(local.set $i (i32.const 0)) |
|
(loop $continue |
|
(block $break |
|
(br_if $break (i32.ge_u (local.get $i) (local.get $size))) |
|
(local.set $c (i32.load8_u (i32.add (global.get $reader-ptr) |
|
(i32.add (local.get $start) |
|
(local.get $i))))) |
|
(if (i32.and (i32.ge_u (local.get $c) (i32.const 0x61)) |
|
(i32.le_u (local.get $c) (i32.const 0x7A))) |
|
(local.set $c (i32.sub (local.get $c) (i32.const 0x20)))) |
|
(i32.store8 (i32.add (i32.add (local.get $result) |
|
(i32.const 4)) |
|
(local.get $i)) |
|
(local.get $c)) |
|
(local.set $i (i32.add (local.get $i) (i32.const 1))) |
|
(br $continue))) |
|
|
|
(i32.store8 (i32.add (i32.add (local.get $result) |
|
(i32.const 4)) |
|
(local.get $size)) |
|
(i32.const 0)) |
|
|
|
(local.get $result)) |
|
|
|
(func $munch-white-spaces |
|
(local $c i32) |
|
(loop $continue |
|
(block $break |
|
(br_if $break (i32.eqz (local.tee $c (call $reader-peek)))) |
|
|
|
(if (i32.and (i32.and (i32.ne (local.get $c) (i32.const 32)) ;; SPACE |
|
(i32.ne (local.get $c) (i32.const 9))) |
|
(i32.ne (local.get $c) (i32.const 0x0A))) ;; TAB |
|
(then (br $break))) |
|
|
|
;; Loop back if we're dealing with white spaces |
|
(call $reader-read) |
|
(br $continue)))) |
|
|
|
(func $read-cons (result i32) |
|
(local $c i32) |
|
(local $cons i32) |
|
(local $car i32) |
|
(local $cdr i32) |
|
|
|
(local.set $cons (call $alloc (i32.const 12))) ;; i32: type, i32: car, i32: cdr |
|
(i32.store (local.get $cons) (global.get $cons)) |
|
(local.set $car (global.get $nil)) |
|
(local.set $cdr (global.get $nil)) |
|
|
|
(local.set $car (call $read)) |
|
|
|
(if (i32.ne (local.tee $c (call $reader-peek)) (i32.const 0x29)) ;; ) |
|
(then (if (i32.and (i32.eq (local.get $c) (i32.const 0x2E)) ;; . |
|
(i32.or (i32.eq (local.tee $c (call $reader-peek-next)) (i32.const 0x20)) |
|
(i32.eq (local.get $c) (i32.const 0x09)))) |
|
;; IF we have a pair of two value |
|
(then (drop (call $reader-read)) |
|
(call $munch-white-spaces) |
|
(if (i32.eq (call $reader-peek) (i32.const 0x29)) ;; ) |
|
(then (return (global.get $nil)))) ;; ERROR: no value!!!! |
|
(local.set $cdr (call $read-data)) |
|
(call $munch-white-spaces) |
|
(if (i32.ne (call $reader-peek) (i32.const 0x29)) ;; ) |
|
(then (return (global.get $nil)))) ;; ERROR: should not have another value!!!! |
|
(drop (call $reader-read))) |
|
(else (local.set $cdr (call $read-cons))))) |
|
(else (drop (call $reader-read)))) |
|
|
|
(i32.store (i32.add (local.get $cons) |
|
(i32.const 4)) |
|
(local.get $car)) |
|
|
|
(i32.store (i32.add (local.get $cons) |
|
(i32.const 8)) |
|
(local.get $cdr)) |
|
|
|
(local.get $cons)) |
|
|
|
(func $reader-peek (result i32) |
|
(i32.load8_u (i32.add (global.get $reader-ptr) |
|
(global.get $reader-pos)))) |
|
|
|
(func $reader-peek-next (result i32) |
|
(if (call $reader-peek) |
|
(return (i32.load8_u (i32.add (global.get $reader-ptr) |
|
(i32.add (global.get $reader-pos) |
|
(i32.const 1)))))) |
|
(return (i32.const 0))) |
|
|
|
(func $reader-read (result i32) |
|
(local $c i32) |
|
(local.set $c (call $reader-peek)) |
|
(if (local.get $c) |
|
(global.set $reader-pos (i32.add (global.get $reader-pos) |
|
(i32.const 1)))) |
|
(local.get $c)) |
|
|
|
(func $eval-reader-macro (param $macro i32) (param $c i32) (result i32) |
|
(local $cons i32) |
|
(local $char i32) |
|
(local.set $char (call $alloc (i32.const 8))) |
|
(i32.store (local.get $char) (global.get $char)) |
|
(i32.store (i32.add (local.get $char) (i32.const 4)) (local.get $c)) |
|
(local.set $cons (call $alloc (i32.const 12))) |
|
(i32.store (local.get $cons) (global.get $cons)) |
|
(i32.store (i32.add (local.get $cons) (i32.const 4)) (local.get $char)) |
|
(i32.store (i32.add (local.get $cons) (i32.const 8)) (global.get $nil)) |
|
(call $eval-fn (local.get $macro) (local.get $cons))) |
|
|
|
(func $munch-comment |
|
(local $c i32) |
|
(if (i32.ne (call $reader-peek) (i32.const 0x3B)) (return)) |
|
(loop $continue |
|
(block $break |
|
(br_if $break (i32.eqz (local.tee $c (call $reader-read)))) |
|
(br_if $break (i32.eq (local.get $c) (i32.const 0x0A))) |
|
(br $continue)))) |
|
|
|
(func $read (result i32) |
|
(local $root i32) |
|
(local $macro i32) |
|
|
|
(call $munch-white-spaces) |
|
(call $munch-comment) |
|
|
|
(local.set $root (global.get $nil)) |
|
(if (i32.ne (local.tee $macro |
|
(call $get-reader-macro-character (call $reader-peek))) |
|
(global.get $nil)) |
|
(then (return (call $eval-reader-macro |
|
(local.get $macro) |
|
(call $reader-read))))) |
|
(if (i32.eq (call $reader-peek) (i32.const 40)) ;; ( |
|
(then (drop (call $reader-read)) |
|
(call $munch-white-spaces) |
|
(call $munch-comment) |
|
(if (i32.ne (call $reader-peek) (i32.const 41)) ;; ) |
|
(then (local.set $root (call $read-cons))) |
|
(else (drop (call $reader-read))))) |
|
(else (local.set $root (call $read-data)))) ;; We have a cons as a CAR |
|
(call $munch-white-spaces) |
|
|
|
(local.get $root)) |
|
|
|
(func $print-char (param $c i32) |
|
(local $old-output-stream i32) |
|
(local $old-output-stream-length i32) |
|
(local $i i32) |
|
(if (i32.eq (global.get $output-stream-index) (global.get $output-stream-length)) |
|
(then (local.set $old-output-stream (global.get $output-stream)) |
|
(local.set $old-output-stream-length (global.get $output-stream-length)) |
|
(global.set $output-stream-length (i32.shl (global.get $output-stream-length) (i32.const 1))) |
|
(global.set $output-stream (call $alloc (global.get $output-stream-length))) |
|
(loop $continue |
|
(block $break |
|
(br_if $break (i32.ge_u (local.get $i) (local.get $old-output-stream-length))) |
|
(i64.store (i32.add (global.get $output-stream) (local.get $i)) |
|
(i64.load (i32.add (local.get $old-output-stream) (local.get $i)))) |
|
(local.set $i (i32.add (local.get $i) (i32.const 8))) |
|
(br $continue))) |
|
(call $free (local.get $old-output-stream) (local.get $old-output-stream-length)))) |
|
(i32.store8 (i32.add (global.get $output-stream) |
|
(global.get $output-stream-index)) |
|
(local.get $c)) |
|
(global.set $output-stream-index |
|
(i32.add (global.get $output-stream-index) (i32.const 1)))) |
|
|
|
(func $print-int (param $num i64) |
|
(local $n i64) |
|
(local.set $n (i64.rem_u (local.get $num) (i64.const 10))) |
|
(local.set $num (i64.div_u (local.get $num) (i64.const 10))) |
|
(if (i64.gt_u (local.get $num) (i64.const 0)) |
|
(call $print-int (local.get $num))) |
|
(call $print-char (i32.wrap/i64 (i64.add (local.get $n) (i64.const 48))))) |
|
|
|
(func $print-zeros (param $exponent i32) |
|
(loop $continue |
|
(block $break |
|
(br_if $break (i32.eqz (local.get $exponent))) |
|
|
|
(call $print-char (i32.const 48)) |
|
(if (i32.gt_s (local.get $exponent) (i32.const 0)) |
|
(then (local.set $exponent |
|
(i32.sub (local.get $exponent) (i32.const 1)))) |
|
(else (local.set $exponent |
|
(i32.add (local.get $exponent) (i32.const 1))))) |
|
(br $continue)))) |
|
|
|
(func $print-number** |
|
(param $num i64) |
|
(param $exponent i32) |
|
(local $n i64) |
|
(local $meh i32) |
|
(local.set $n (i64.rem_u (local.get $num) (i64.const 10))) |
|
(local.set $num (i64.div_u (local.get $num) (i64.const 10))) |
|
(if (i32.lt_s (local.get $exponent) (i32.const 0)) |
|
(then (call $print-number** |
|
(local.get $num) |
|
(i32.add (local.get $exponent) (i32.const 1)))) |
|
(else (if (i64.gt_u (local.get $num) (i64.const 0)) |
|
(then (call $print-number** |
|
(local.get $num) |
|
(local.get $exponent)))))) |
|
(if (i32.eqz (i32.add (local.get $exponent) (i32.const 1))) |
|
(call $print-char (i32.const 46))) |
|
(call $print-char (i32.wrap/i64 (i64.add (local.get $n) (i64.const 48))))) |
|
|
|
(func $print-number* (param $num f64) |
|
(local $n i64) |
|
(local $is-negative i32) |
|
(local $2-exponent i32) |
|
(local $mantissa i64) |
|
(local $10-exponent i32) |
|
(local $whole i64) |
|
(local $fraction i64) |
|
(local.set $n (i64.reinterpret/f64 (local.get $num))) |
|
(local.set $is-negative (i32.wrap/i64 (i64.shr_u (i64.and (local.get $n) |
|
(i64.const 0x8000000000000000)) |
|
(i64.const 63)))) |
|
|
|
(if (local.get $is-negative) |
|
(call $print-char (i32.const 45))) |
|
|
|
(if (i64.eqz (local.get $n)) |
|
(then (call $print-char (i32.const 0x30)) |
|
(return))) |
|
|
|
(local.set $2-exponent (i32.sub (i32.wrap/i64 (i64.shr_u (i64.and (local.get $n) |
|
(i64.const 0x7FF0000000000000)) |
|
(i64.const 52))) |
|
(i32.const 1023))) |
|
|
|
(local.set $mantissa (i64.shl (i64.and (local.get $n) (i64.const 0x000FFFFFFFFFFFFF)) |
|
(i64.const 12))) |
|
|
|
;; If Infinity return Infinity |
|
(if (i64.eqz (i64.xor (i64.and (local.get $n) |
|
(i64.const 0x7FF0000000000000)) |
|
(i64.const 0x7FF0000000000000))) |
|
(then (call $print-char (i32.const 0x49)) |
|
(call $print-char (i32.const 0x6E)) |
|
(call $print-char (i32.const 0x66)) |
|
(call $print-char (i32.const 0x69)) |
|
(call $print-char (i32.const 0x6E)) |
|
(call $print-char (i32.const 0x69)) |
|
(call $print-char (i32.const 0x74)) |
|
(call $print-char (i32.const 0x79)) |
|
(return))) |
|
|
|
(local.set $fraction (i64.const 1)) |
|
|
|
|
|
(if (i32.gt_s (local.get $2-exponent) (i32.const -1)) |
|
(then (local.set $whole (i64.const 1)) |
|
(loop $continue |
|
(block $break |
|
(br_if $break (i32.eqz (local.get $2-exponent))) |
|
(if (i64.gt_u (i64.and (local.get $whole) (i64.const 0x8000000000000000)) |
|
(i64.const 0)) |
|
(then (local.set $whole (i64.div_u (local.get $whole) (i64.const 10))) |
|
(local.set $10-exponent (i32.add (local.get $10-exponent) (i32.const 1))))) |
|
(local.set $whole (i64.xor (i64.shl (local.get $whole) (i64.const 1)) |
|
(i64.shr_u (i64.and (local.get $mantissa) |
|
(i64.const 0x8000000000000000)) |
|
(i64.const 63)))) |
|
(local.set $mantissa (i64.shl (local.get $mantissa) (i64.const 1))) |
|
(local.set $2-exponent (i32.sub (local.get $2-exponent) (i32.const 1))) |
|
(br $continue)))) |
|
(else (local.set $mantissa (i64.add (i64.shr_u (local.get $mantissa) (i64.const 1)) |
|
(i64.const 0x8000000000000000))) |
|
(local.set $2-exponent (i32.add (local.get $2-exponent) (i32.const 1))) |
|
(loop $continue |
|
(block $break |
|
(br_if $break (i32.eqz (local.get $2-exponent))) |
|
(if (i64.gt_u (i64.and (local.get $mantissa) (i64.const 0x0000000000000001)) |
|
(i64.const 0)) |
|
(then (if (i64.eqz (i64.and (local.get $mantissa) (i64.const 0xF000000000000000))) |
|
(then (local.set $mantissa (i64.mul (local.get $mantissa) |
|
(i64.const 10))) |
|
(local.set $10-exponent (i32.sub (local.get $10-exponent) |
|
(i32.const 1))))))) |
|
(local.set $mantissa (i64.shr_u (local.get $mantissa) (i64.const 1))) |
|
(local.set $2-exponent (i32.add (local.get $2-exponent) (i32.const 1))) |
|
(br $continue))))) |
|
|
|
(loop $continue |
|
(block $break |
|
(br_if $break (i64.eqz (local.get $mantissa))) |
|
|
|
(local.set $fraction (i64.mul (local.get $fraction) (i64.const 5))) |
|
(if (i64.gt_u (i64.and (local.get $whole) (i64.const 0xF000000000000000)) |
|
(i64.const 0)) |
|
(then (local.set $fraction (i64.div_u (local.get $fraction) (i64.const 10)))) |
|
(else (local.set $whole (i64.mul (local.get $whole) (i64.const 10))) |
|
(local.set $10-exponent (i32.sub (local.get $10-exponent) (i32.const 1))))) |
|
|
|
(local.set $whole |
|
(i64.add (local.get $whole) |
|
(i64.mul (i64.shr_u (i64.and (local.get $mantissa) |
|
(i64.const 0x8000000000000000)) |
|
(i64.const 63)) |
|
(local.get $fraction)))) |
|
|
|
(local.set $mantissa (i64.shl (local.get $mantissa) (i64.const 1))) |
|
(br $continue))) |
|
|
|
(if (i64.eqz (local.get $whole)) |
|
(then (call $print-char (i32.const 48))) |
|
(else |
|
(if (i64.gt_u (i64.and (local.get $whole) |
|
(i64.const 0xF000000000000000)) |
|
(i64.const 0)) |
|
(then (local.set $fraction (i64.rem_u (local.get $whole) (i64.const 10000))) |
|
(local.set $whole (i64.div_u (local.get $whole) (i64.const 10000))) |
|
(if (i64.eq (local.get $fraction) (i64.const 5000)) |
|
(then (if (i64.ne (i64.and (local.get $whole) (i64.const 1)) (i64.const 0)) |
|
(local.set $whole (i64.add (local.get $whole) (i64.const 1))))) |
|
(else (if (i64.gt_u (local.get $fraction) (i64.const 5000)) |
|
(then (local.set $whole (i64.add (local.get $whole) (i64.const 1))))))) |
|
(local.set $10-exponent (i32.add (local.get $10-exponent) (i32.const 4))))) |
|
|
|
(loop $continue |
|
(block $break |
|
(br_if $break (i64.eqz (local.get $whole))) |
|
(br_if $break (i32.eqz (local.get $10-exponent))) |
|
(br_if $break (i64.ne (i64.rem_u (local.get $whole) (i64.const 10)) |
|
(i64.const 0))) |
|
|
|
(local.set $whole (i64.div_u (local.get $whole) (i64.const 10))) |
|
(local.set $10-exponent (i32.add (local.get $10-exponent) (i32.const 1))) |
|
(br $continue))) |
|
|
|
(call $print-number** |
|
(local.get $whole) |
|
(local.get $10-exponent)) |
|
|
|
(if (i32.gt_s (local.get $10-exponent) (i32.const 0)) |
|
(then (call $print-zeros (local.get $10-exponent))))))) |
|
|
|
(func $print-number (param $ptr i32) |
|
(call $print-number* (f64.load (i32.add (local.get $ptr) (i32.const 4))))) |
|
|
|
(func $print-symbol (param $ptr i32) |
|
(local $c i32) |
|
(local $i i32) |
|
(local.set $ptr (i32.add (local.get $ptr) (i32.const 4))) |
|
(loop $continue |
|
(block $break |
|
(local.set $c (i32.load8_u (i32.add (local.get $ptr) |
|
(local.get $i)))) |
|
(br_if $break (i32.eqz (local.get $c))) |
|
(call $print-char (local.get $c)) |
|
(local.set $i (i32.add (local.get $i) (i32.const 1))) |
|
(br $continue)))) |
|
|
|
|
|
(func $car (param $cons i32) (result i32) |
|
(if (i32.eq (local.get $cons) (global.get $nil)) (return (local.get $cons))) |
|
(i32.load (i32.add (local.get $cons) (i32.const 4)))) |
|
|
|
(func $cdr (param $cons i32) (result i32) |
|
(if (i32.eq (local.get $cons) (global.get $nil)) (return (local.get $cons))) |
|
(i32.load (i32.add (local.get $cons) (i32.const 8)))) |
|
|
|
(func $print-list (param $ptr i32) |
|
(local $car i32) |
|
(local $cdr i32) |
|
(local $type i32) |
|
(call $print-char (i32.const 40)) |
|
(local.set $cdr (local.get $ptr)) |
|
(loop $continue |
|
(block $break |
|
(local.set $car (call $car (local.get $cdr))) |
|
(local.set $cdr (call $cdr (local.get $cdr))) |
|
(call $print (local.get $car)) |
|
|
|
(br_if $break (i32.eq (local.get $cdr) (global.get $nil))) |
|
(call $print-char (i32.const 0x20)) |
|
|
|
(br_if $continue (i32.eq (local.tee $type (i32.load (local.get $cdr))) |
|
(global.get $cons))) |
|
|
|
(call $print-char (i32.const 0x2E)) |
|
(call $print-char (i32.const 0x20)) |
|
(call $print (local.get $cdr)) |
|
|
|
(br $break))) |
|
|
|
(call $print-char (i32.const 41))) |
|
|
|
(func $print (param $ptr i32) (result i32) |
|
(local $type i32) |
|
(local.set $type (i32.load (local.get $ptr))) |
|
(if (i32.eq (local.tee $type (i32.load (local.get $ptr))) |
|
(global.get $symbol)) |
|
(then (call $print-symbol (local.get $ptr))) |
|
(else (if (i32.eq (local.get $type) (global.get $char)) |
|
(then (call $print-char (i32.load (i32.add (local.get $ptr) |
|
(i32.const 4))))) |
|
(else (if (i32.eq (local.get $type) (global.get $number)) |
|
(then (call $print-number (local.get $ptr))) |
|
(else (call $print-list (local.get $ptr)))))))) |
|
(local.get $ptr)) |
|
|
|
(func $add (param $cons i32) (result i32) |
|
(local $type i32) |
|
(local $car i32) |
|
(local $cdr i32) |
|
(local $result i32) |
|
(local $num f64) |
|
(local.set $type (i32.load (local.get $cons))) |
|
|
|
;; Error if not a list |
|
(if (i32.ne (local.get $type) (global.get $cons)) |
|
(then (local.set $car (call $alloc (i32.const 4))) |
|
(i32.store (local.get $car) (global.get $error)) |
|
(return (local.get $car)))) |
|
|
|
(local.set $result (call $alloc (i32.const 12))) |
|
(i32.store (local.get $result) (global.get $number)) |
|
|
|
(local.set $cdr (local.get $cons)) |
|
(loop $continue |
|
(block $break |
|
(local.set $car (call $car (local.get $cdr))) |
|
(local.set $cdr (call $cdr (local.get $cdr))) |
|
(local.set $type (i32.load (local.get $car))) |
|
|
|
;; (if (i32.ne (local.get $type) (global.get $number)) |
|
;; (then (local.set $car (call $alloc (i32.const 4))) |
|
;; (i32.store (local.get $car) (global.get $error)) |
|
;; (return (local.get $car)))) ;; ERROR: Can't add NaN! |
|
|
|
(local.set $num (f64.add (local.get $num) |
|
(f64.load (i32.add (local.get $car) (i32.const 4))))) |
|
|
|
(br_if $break (i32.eq (local.get $cdr) (global.get $nil))) |
|
|
|
;; Error if not a list |
|
(if (i32.ne (i32.load (local.get $cdr)) (global.get $cons)) |
|
(then (local.set $car (call $alloc (i32.const 4))) |
|
(i32.store (local.get $car) (global.get $error)) |
|
(return (local.get $car)))) |
|
(br $continue))) |
|
|
|
(f64.store (i32.add (local.get $result) (i32.const 4)) (local.get $num)) |
|
(local.get $result)) |
|
|
|
(func $sub (param $cons i32) (result i32) |
|
(local $type i32) |
|
(local $car i32) |
|
(local $cdr i32) |
|
(local $result i32) |
|
(local $num f64) |
|
(local.set $type (i32.load (local.get $cons))) |
|
|
|
;; Error if not a list |
|
(if (i32.ne (local.get $type) (global.get $cons)) |
|
(then (local.set $car (call $alloc (i32.const 4))) |
|
(i32.store (local.get $car) (global.get $error)) |
|
(return (local.get $car)))) |
|
|
|
(local.set $result (call $alloc (i32.const 12))) |
|
(i32.store (local.get $result) (global.get $number)) |
|
|
|
(local.set $car (call $car (local.get $cons))) |
|
(local.set $cdr (call $cdr (local.get $cons))) |
|
(if (i32.eq (local.get $cdr) (global.get $nil)) |
|
(then (local.set $num (f64.sub (f64.const 0) |
|
(f64.load (i32.add (local.get $car) |
|
(i32.const 4)))))) |
|
(else (local.set $num (f64.load (i32.add (local.get $car) |
|
(i32.const 4)))) |
|
(loop $continue |
|
(block $break |
|
(local.set $car (call $car (local.get $cdr))) |
|
(local.set $cdr (call $cdr (local.get $cdr))) |
|
(local.set $type (i32.load (local.get $car))) |
|
|
|
(if (i32.ne (local.get $type) (global.get $number)) |
|
(then (local.set $car (call $alloc (i32.const 4))) |
|
(i32.store (local.get $car) (global.get $error)) |
|
(return (local.get $car)))) ;; ERROR: Can't add NaN! |
|
|
|
(local.set $num (f64.sub (local.get $num) |
|
(f64.load (i32.add (local.get $car) (i32.const 4))))) |
|
|
|
(br_if $break (i32.eq (local.get $cdr) (global.get $nil))) |
|
|
|
;; Error if not a list |
|
(if (i32.ne (i32.load (local.get $cdr)) (global.get $cons)) |
|
(then (local.set $car (call $alloc (i32.const 4))) |
|
(i32.store (local.get $car) (global.get $error)) |
|
(return (local.get $car)))) |
|
(br $continue))))) |
|
|
|
|
|
(f64.store (i32.add (local.get $result) (i32.const 4)) (local.get $num)) |
|
(local.get $result)) |
|
|
|
(func $mul (param $cons i32) (result i32) |
|
(local $type i32) |
|
(local $car i32) |
|
(local $cdr i32) |
|
(local $result i32) |
|
(local $num f64) |
|
(local.set $type (i32.load (local.get $cons))) |
|
|
|
;; Error if not a list |
|
(if (i32.ne (local.get $type) (global.get $cons)) |
|
(then (local.set $car (call $alloc (i32.const 4))) |
|
(i32.store (local.get $car) (global.get $error)) |
|
(return (local.get $car)))) |
|
|
|
(local.set $result (call $alloc (i32.const 12))) |
|
(i32.store (local.get $result) (global.get $number)) |
|
|
|
(local.set $cdr (local.get $cons)) |
|
(local.set $num (f64.const 1)) |
|
|
|
(loop $continue |
|
(block $break |
|
(local.set $car (call $car (local.get $cdr))) |
|
(local.set $cdr (call $cdr (local.get $cdr))) |
|
(local.set $type (i32.load (local.get $car))) |
|
|
|
(if (i32.ne (local.get $type) (global.get $number)) |
|
(then (local.set $car (call $alloc (i32.const 4))) |
|
(i32.store (local.get $car) (global.get $error)) |
|
(return (local.get $car)))) ;; ERROR: Can't add NaN! |
|
|
|
(local.set $num (f64.mul (local.get $num) |
|
(f64.load (i32.add (local.get $car) (i32.const 4))))) |
|
|
|
(br_if $break (i32.eq (local.get $cdr) (global.get $nil))) |
|
|
|
;; Error if not a list |
|
(if (i32.ne (i32.load (local.get $cdr)) (global.get $cons)) |
|
(then (local.set $car (call $alloc (i32.const 4))) |
|
(i32.store (local.get $car) (global.get $error)) |
|
(return (local.get $car)))) |
|
(br $continue))) |
|
|
|
|
|
(f64.store (i32.add (local.get $result) (i32.const 4)) (local.get $num)) |
|
(local.get $result)) |
|
|
|
(func $div (param $cons i32) (result i32) |
|
(local $type i32) |
|
(local $car i32) |
|
(local $cdr i32) |
|
(local $result i32) |
|
(local $num f64) |
|
(local.set $type (i32.load (local.get $cons))) |
|
|
|
;; Error if not a list |
|
(if (i32.ne (local.get $type) (global.get $cons)) |
|
(then (local.set $car (call $alloc (i32.const 4))) |
|
(i32.store (local.get $car) (global.get $error)) |
|
(return (local.get $car)))) |
|
|
|
(local.set $result (call $alloc (i32.const 12))) |
|
(i32.store (local.get $result) (global.get $number)) |
|
|
|
(local.set $car (call $car (local.get $cons))) |
|
(local.set $cdr (call $cdr (local.get $cons))) |
|
(if (i32.eq (local.get $cdr) (global.get $nil)) |
|
(then (local.set $num (f64.div (f64.const 1) |
|
(f64.load (i32.add (local.get $car) |
|
(i32.const 4)))))) |
|
(else (local.set $num (f64.load (i32.add (local.get $car) |
|
(i32.const 4)))) |
|
(loop $continue |
|
(block $break |
|
(local.set $car (call $car (local.get $cdr))) |
|
(local.set $cdr (call $cdr (local.get $cdr))) |
|
(local.set $type (i32.load (local.get $car))) |
|
|
|
(if (i32.ne (local.get $type) (global.get $number)) |
|
(then (local.set $car (call $alloc (i32.const 4))) |
|
(i32.store (local.get $car) (global.get $error)) |
|
(return (local.get $car)))) ;; ERROR: Can't add NaN! |
|
|
|
(local.set $num (f64.div (local.get $num) |
|
(f64.load (i32.add (local.get $car) (i32.const 4))))) |
|
|
|
(br_if $break (i32.eq (local.get $cdr) (global.get $nil))) |
|
|
|
;; Error if not a list |
|
(if (i32.ne (i32.load (local.get $cdr)) (global.get $cons)) |
|
(then (local.set $car (call $alloc (i32.const 4))) |
|
(i32.store (local.get $car) (global.get $error)) |
|
(return (local.get $car)))) |
|
(br $continue))))) |
|
|
|
(f64.store (i32.add (local.get $result) (i32.const 4)) (local.get $num)) |
|
(local.get $result)) |
|
|
|
(func $bit-xor (param $cons i32) (result i32) |
|
(local $type i32) |
|
(local $car i32) |
|
(local $cdr i32) |
|
(local $result i32) |
|
(local $num i64) |
|
(local.set $type (i32.load (local.get $cons))) |
|
|
|
;; Error if not a list |
|
(if (i32.ne (local.get $type) (global.get $cons)) |
|
(then (local.set $car (call $alloc (i32.const 4))) |
|
(i32.store (local.get $car) (global.get $error)) |
|
(return (local.get $car)))) |
|
|
|
(local.set $result (call $alloc (i32.const 12))) |
|
(i32.store (local.get $result) (global.get $number)) |
|
|
|
(local.set $cdr (local.get $cons)) |
|
(local.set $num (i64.const 0)) |
|
|
|
(loop $continue |
|
(block $break |
|
(local.set $car (call $car (local.get $cdr))) |
|
(local.set $cdr (call $cdr (local.get $cdr))) |
|
(local.set $type (i32.load (local.get $car))) |
|
|
|
(if (i32.ne (local.get $type) (global.get $number)) |
|
(then (local.set $car (call $alloc (i32.const 4))) |
|
(i32.store (local.get $car) (global.get $error)) |
|
(return (local.get $car)))) ;; ERROR: Can't add NaN! |
|
|
|
(local.set $num (i64.xor (local.get $num) |
|
(i64.trunc_s/f64 (f64.load (i32.add (local.get $car) |
|
(i32.const 4)))))) |
|
|
|
(br_if $break (i32.eq (local.get $cdr) (global.get $nil))) |
|
|
|
;; Error if not a list |
|
(if (i32.ne (i32.load (local.get $cdr)) (global.get $cons)) |
|
(then (local.set $car (call $alloc (i32.const 4))) |
|
(i32.store (local.get $car) (global.get $error)) |
|
(return (local.get $car)))) |
|
(br $continue))) |
|
|
|
|
|
(f64.store (i32.add (local.get $result) (i32.const 4)) |
|
(f64.convert_s/i64 (local.get $num))) |
|
(local.get $result)) |
|
|
|
(func $bit-or (param $cons i32) (result i32) |
|
(local $type i32) |
|
(local $car i32) |
|
(local $cdr i32) |
|
(local $result i32) |
|
(local $num i64) |
|
(local.set $type (i32.load (local.get $cons))) |
|
|
|
;; Error if not a list |
|
(if (i32.ne (local.get $type) (global.get $cons)) |
|
(then (local.set $car (call $alloc (i32.const 4))) |
|
(i32.store (local.get $car) (global.get $error)) |
|
(return (local.get $car)))) |
|
|
|
(local.set $result (call $alloc (i32.const 12))) |
|
(i32.store (local.get $result) (global.get $number)) |
|
|
|
(local.set $cdr (local.get $cons)) |
|
(local.set $num (i64.const 0)) |
|
|
|
(loop $continue |
|
(block $break |
|
(local.set $car (call $car (local.get $cdr))) |
|
(local.set $cdr (call $cdr (local.get $cdr))) |
|
(local.set $type (i32.load (local.get $car))) |
|
|
|
(if (i32.ne (local.get $type) (global.get $number)) |
|
(then (local.set $car (call $alloc (i32.const 4))) |
|
(i32.store (local.get $car) (global.get $error)) |
|
(return (local.get $car)))) ;; ERROR: Can't add NaN! |
|
|
|
(local.set $num (i64.or (local.get $num) |
|
(i64.trunc_s/f64 (f64.load (i32.add (local.get $car) |
|
(i32.const 4)))))) |
|
|
|
(br_if $break (i32.eq (local.get $cdr) (global.get $nil))) |
|
|
|
;; Error if not a list |
|
(if (i32.ne (i32.load (local.get $cdr)) (global.get $cons)) |
|
(then (local.set $car (call $alloc (i32.const 4))) |
|
(i32.store (local.get $car) (global.get $error)) |
|
(return (local.get $car)))) |
|
(br $continue))) |
|
|
|
|
|
(f64.store (i32.add (local.get $result) (i32.const 4)) |
|
(f64.convert_s/i64 (local.get $num))) |
|
(local.get $result)) |
|
|
|
(func $bit-and (param $cons i32) (result i32) |
|
(local $type i32) |
|
(local $car i32) |
|
(local $cdr i32) |
|
(local $result i32) |
|
(local $num i64) |
|
(local.set $type (i32.load (local.get $cons))) |
|
|
|
;; Error if not a list |
|
(if (i32.ne (local.get $type) (global.get $cons)) |
|
(then (local.set $car (call $alloc (i32.const 4))) |
|
(i32.store (local.get $car) (global.get $error)) |
|
(return (local.get $car)))) |
|
|
|
|
|
(local.set $cdr (local.get $cons)) |
|
(local.set $car (call $car (local.get $cdr))) |
|
(local.set $cdr (call $cdr (local.get $cdr))) |
|
(if (i32.eq (local.get $cdr) (global.get $nil)) |
|
(then (return (local.get $car)))) |
|
|
|
(local.set $result (call $alloc (i32.const 12))) |
|
(i32.store (local.get $result) (global.get $number)) |
|
(local.set $num (i64.trunc_s/f64 (f64.load (i32.add (local.get $car) |
|
(i32.const 4))))) |
|
(loop $continue |
|
(block $break |
|
(local.set $car (call $car (local.get $cdr))) |
|
(local.set $cdr (call $cdr (local.get $cdr))) |
|
(local.set $type (i32.load (local.get $car))) |
|
(if (i32.ne (local.get $type) (global.get $number)) |
|
(then (local.set $car (call $alloc (i32.const 4))) |
|
(i32.store (local.get $car) (global.get $error)) |
|
(return (local.get $car)))) ;; ERROR: Can't add NaN! |
|
|
|
(local.set $num (i64.and (local.get $num) |
|
(i64.trunc_s/f64 (f64.load (i32.add (local.get $car) |
|
(i32.const 4)))))) |
|
|
|
(br_if $break (i32.eq (local.get $cdr) (global.get $nil))) |
|
|
|
;; Error if not a list |
|
(if (i32.ne (i32.load (local.get $cdr)) (global.get $cons)) |
|
(then (local.set $car (call $alloc (i32.const 4))) |
|
(i32.store (local.get $car) (global.get $error)) |
|
(return (local.get $car)))) |
|
(br $continue))) |
|
|
|
|
|
(f64.store (i32.add (local.get $result) (i32.const 4)) |
|
(f64.convert_s/i64 (local.get $num))) |
|
(local.get $result)) |
|
|
|
(func $bit-not (param $cons i32) (result i32) |
|
(local $type i32) |
|
(local $car i32) |
|
(local $cdr i32) |
|
(local $result i32) |
|
(local $num i64) |
|
(local.set $type (i32.load (local.get $cons))) |
|
|
|
;; Error if not a list |
|
(if (i32.ne (local.get $type) (global.get $cons)) |
|
(then (local.set $car (call $alloc (i32.const 4))) |
|
(i32.store (local.get $car) (global.get $error)) |
|
(return (local.get $car)))) |
|
|
|
(local.set $car (call $car (local.get $cons))) |
|
(local.set $cdr (call $cdr (local.get $cons))) |
|
|
|
(local.set $result (call $alloc (i32.const 12))) |
|
(i32.store (local.get $result) (global.get $number)) |
|
(local.set $num (i64.trunc_s/f64 (f64.load (i32.add (local.get $car) |
|
(i32.const 4))))) |
|
(local.set $num (i64.sub (i64.mul (local.get $num) (i64.const -1)) |
|
(i64.const 1))) |
|
(f64.store (i32.add (local.get $result) (i32.const 4)) |
|
(f64.convert_s/i64 (local.get $num))) |
|
(local.get $result)) |
|
|
|
;; pow! |
|
(global $bp f64 (f64.const 0.5)) |
|
(global $dp_h f64 (f64.const 5.84962487220764160156e-01)) ;; 0x3FE2B803, 0x40000000 |
|
(global $dp_l f64 (f64.const 1.35003920212974897128e-08)) ;; 0x3E4CFDEB, 0x43CFD006 |
|
(global $zero f64 (f64.const 0.0)) |
|
(global $one f64 (f64.const 1.0)) |
|
(global $two f64 (f64.const 2.0)) |
|
(global $two53 f64 (f64.const 9007199254740992.0)) ;; 0x43400000, 0x00000000 |
|
(global $huge f64 (f64.const 1.0e300)) |
|
(global $tiny f64 (f64.const 1.0e-300)) |
|
;; poly coefs for (3/2)*(log(x)-2s-2/3*s**3 |
|
(global $L1 f64 (f64.const 5.99999999999994648725e-01)) ;; 0x3FE33333, 0x33333303 |
|
(global $L2 f64 (f64.const 4.28571428578550184252e-01)) ;; 0x3FDB6DB6, 0xDB6FABFF |
|
(global $L3 f64 (f64.const 3.33333329818377432918e-01)) ;; 0x3FD55555, 0x518F264D |
|
(global $L4 f64 (f64.const 2.72728123808534006489e-01)) ;; 0x3FD17460, 0xA91D4101 |
|
(global $L5 f64 (f64.const 2.30660745775561754067e-01)) ;; 0x3FCD864A, 0x93C9DB65 |
|
(global $L6 f64 (f64.const 2.06975017800338417784e-01)) ;; 0x3FCA7E28, 0x4A454EEF |
|
(global $P1 f64 (f64.const 1.66666666666666019037e-01)) ;; 0x3FC55555, 0x5555553E |
|
(global $P2 f64 (f64.const -2.77777777770155933842e-03)) ;; 0xBF66C16C, 0x16BEBD93 |
|
(global $P3 f64 (f64.const 6.61375632143793436117e-05)) ;; 0x3F11566A, 0xAF25DE2C |
|
(global $P4 f64 (f64.const -1.65339022054652515390e-06)) ;; 0xBEBBBD41, 0xC5D26BF1 |
|
(global $P5 f64 (f64.const 4.13813679705723846039e-08)) ;; 0x3E663769, 0x72BEA4D0 |
|
(global $lg2 f64 (f64.const 6.93147180559945286227e-01)) ;; 0x3FE62E42, 0xFEFA39EF |
|
(global $lg2_h f64 (f64.const 6.93147182464599609375e-01)) ;; 0x3FE62E43, 0x00000000 |
|
(global $lg2_l f64 (f64.const -1.90465429995776804525e-09)) ;; 0xBE205C61, 0x0CA86C39 |
|
(global $ovt f64 (f64.const 8.0085662595372944372e-0017)) ;; -(1024-log2(ovfl+.5ulp)) |
|
(global $cp f64 (f64.const 9.61796693925975554329e-01)) ;; 0x3FEEC709, 0xDC3A03FD =2/(3ln2) |
|
(global $cp_h f64 (f64.const 9.61796700954437255859e-01)) ;; 0x3FEEC709, 0xE0000000 =(float)cp |
|
(global $cp_l f64 (f64.const -7.02846165095275826516e-09)) ;; 0xBE3E2FE0, 0x145B01F5 =tail of cp_h |
|
(global $ivln2 f64 (f64.const 1.44269504088896338700e+00)) ;; 0x3FF71547, 0x652B82FE =1/ln2 |
|
(global $ivln2_h f64 (f64.const 1.44269502162933349609e+00)) ;; 0x3FF71547, 0x60000000 =24b 1/ln2 |
|
(global $ivln2_l f64 (f64.const 1.92596299112661746887e-0)) ;; 0x3E54AE0B, 0xF85DDF44 =1/ln2 tail |
|
(global $two54 f64 (f64.const 1.80143985094819840000e+16)) |
|
(global $twom54 f64 (f64.const 5.55111512312578270212e-17)) |
|
(func $copysign (param $x f64) (param $y f64) (result f64) |
|
(f64.reinterpret/i64 (i64.or (i64.and (i64.reinterpret/f64 (local.get $x)) |
|
(i64.const 0x7FFFFFFFFFFFFFFF)) |
|
(i64.and (i64.reinterpret/f64 (local.get $y)) |
|
(i64.const 0x8000000000000000))))) |
|
(func $scalbn (param $x f64) (param $n i32) (result f64) |
|
(local $k i32) |
|
(local $hx i32) |
|
(local $lx i32) |
|
(local.set $hx (i32.wrap/i64 (i64.shr_u (i64.reinterpret/f64 (local.get $x)) (i64.const 32)))) |
|
(local.set $lx (i32.wrap/i64 (i64.reinterpret/f64 (local.get $x)))) |
|
(local.set $k (i32.shr_u (i32.and (local.get $hx) (i32.const 0x7ff00000)) (i32.const 20))) |
|
(if (i32.eqz (local.get $k)) |
|
(then (if (i32.eqz (i32.or (local.get $lx) (i32.and (local.get $hx) (i32.const 0x7fffffff)))) |
|
(return (local.get $x))) |
|
(local.set $x (f64.mul (local.get $x) (global.get $two54))) |
|
(local.set $hx (i32.wrap/i64 (i64.shr_u (i64.reinterpret/f64 (local.get $x)) |
|
(i64.const 32)))) |
|
(local.set $k (i32.sub (i32.shr_u (i32.and (local.get $hx) (i32.const 0x7ff00000)) |
|
(i32.const 20)) |
|
(i32.const 54))) |
|
(if (i32.lt_s (local.get $n) (i32.const -50000)) |
|
(return (f64.mul (global.get $tiny) (local.get $x)))))) |
|
(if (i32.eq (local.get $k) (i32.const 0x7ff)) (return (f64.add (local.get $x) (local.get $x)))) |
|
(local.set $k (i32.add (local.get $k) (local.get $n))) |
|
(if (i32.gt_s (local.get $k) (i32.const 0x7FE)) |
|
(return (f64.mul (global.get $huge) (call $copysign (global.get $huge) (local.get $x))))) |
|
(if (i32.gt_s (local.get $k) (i32.const 0)) |
|
(return (f64.reinterpret/i64 |
|
(i64.or |
|
(i64.shl (i64.extend_u/i32 (i32.or (i32.and (local.get $hx) |
|
(i32.const 0x800fffff)) |
|
(i32.shl (local.get $k) |
|
(i32.const 20)))) |
|
(i64.const 32)) |
|
(i64.and (i64.reinterpret/f64 (local.get $x)) |
|
(i64.const 0x00000000FFFFFFFF)))))) |
|
(if (i32.lt_s (local.get $k) (i32.const -54)) |
|
(if (i32.gt_s (local.get $n) (i32.const 50000)) |
|
(then (return (f64.mul (global.get $huge) (call $copysign |
|
(global.get $huge) |
|
(local.get $x))))) |
|
(else (return (f64.mul (global.get $tiny) (call $copysign |
|
(global.get $tiny) |
|
(local.get $x))))))) |
|
(local.set $k (i32.add (local.get $k) (i32.const 54))) |
|
(f64.mul (f64.reinterpret/i64 |
|
(i64.or |
|
(i64.shl (i64.extend_u/i32 (i32.or (i32.and (local.get $hx) |
|
(i32.const 0x800fffff)) |
|
(i32.shl (local.get $k) |
|
(i32.const 20)))) |
|
(i64.const 32)) |
|
(i64.and (i64.reinterpret/f64 (local.get $x)) |
|
(i64.const 0x00000000FFFFFFFF)))) |
|
(global.get $twom54))) |
|
|
|
(func $pow (param $x f64) (param $y f64) (result f64) |
|
(local $z f64) |
|
(local $ax f64) |
|
(local $z_h f64) |
|
(local $z_l f64) |
|
(local $p_h f64) |
|
(local $p_l f64) |
|
(local $y1 f64) |
|
(local $t1 f64) |
|
(local $t2 f64) |
|
(local $r f64) |
|
(local $s f64) |
|
(local $t f64) |
|
(local $u f64) |
|
(local $v f64) |
|
(local $w f64) |
|
(local $i i32) |
|
(local $j i32) |
|
(local $k i32) |
|
(local $yisint i32) |
|
(local $n i32) |
|
(local $hx i32) |
|
(local $hy i32) |
|
(local $ix i32) |
|
(local $iy i32) |
|
(local $lx i32) |
|
(local $ly i32) |
|
(local $ss f64) |
|
(local $s2 f64) |
|
(local $s_h f64) |
|
(local $s_l f64) |
|
(local $t_h f64) |
|
(local $t_l f64) |
|
(local.set $hx (i32.wrap/i64 (i64.shr_u (i64.reinterpret/f64 (local.get $x)) (i64.const 32)))) |
|
(local.set $lx (i32.wrap/i64 (i64.reinterpret/f64 (local.get $x)))) |
|
(local.set $hy (i32.wrap/i64 (i64.shr_u (i64.reinterpret/f64 (local.get $y)) (i64.const 32)))) |
|
(local.set $ly (i32.wrap/i64 (i64.reinterpret/f64 (local.get $y)))) |
|
(local.set $ix (i32.and (local.get $hx) (i32.const 0x7fffffff))) |
|
(local.set $iy (i32.and (local.get $hy) (i32.const 0x7fffffff))) |
|
|
|
;; y==zero: x**0 = 1 |
|
(if (i32.eqz (i32.or (local.get $iy) (local.get $ly))) |
|
(return (global.get $one))) |
|
|
|
;; +-NaN return x+y |
|
(if (i32.or (i32.or (i32.or (i32.gt_u (local.get $ix) (i32.const 0x7ff00000)) |
|
(i32.and (i32.eq (local.get $ix) (i32.const 0x7ff00000)) |
|
(i32.ne (local.get $lx) (i32.const 0)))) |
|
(i32.gt_u (local.get $iy) (i32.const 0x7ff00000))) |
|
(i32.and (i32.eq (local.get $iy) (i32.const 0x7ff00000)) |
|
(i32.ne (local.get $ly) (i32.const 0)))) |
|
(return (f64.add (local.get $x) (local.get $y)))) |
|
|
|
;; determine if y is an odd int when x < 0 |
|
;; yisint = 0 ... y is not an integer |
|
;; yisint = 1 ... y is an odd int |
|
;; yisint = 2 ... y is an even int |
|
(if (i32.lt_s (local.get $hx) (i32.const 0)) |
|
(then |
|
(if (i32.ge_u (local.get $iy) (i32.const 0x43400000)) |
|
(then (local.set $yisint (i32.const 2))) ;; even integer y |
|
(else (if (i32.ge_u (local.get $iy) (i32.const 0x3ff00000)) |
|
(then (local.set $k (i32.sub (i32.shr_u (local.get $iy) (i32.const 20)) |
|
(i32.const 0x3ff))) ;; exponent |
|
(if (i32.gt_u (local.get $k) (i32.const 20)) |
|
(then (local.set $j (i32.shr_u (local.get $ly) |
|
(i32.sub (i32.const 52) |
|
(local.get $k)))) |
|
(if (i32.eq (i32.shl (local.get $j) |
|
(i32.sub (i32.const 52) |
|
(local.get $k))) |
|
(local.get $ly)) |
|
(local.set $yisint |
|
(i32.sub (i32.const 2) |
|
(i32.and (local.get $j) |
|
(i32.const 1)))))) |
|
(else (if (i32.eqz (local.get $ly)) |
|
(then (local.set $j (i32.shr_u (local.get $iy) |
|
(i32.sub (i32.const 20) |
|
(local.get $k)))) |
|
(if (i32.eq (i32.shl (local.get $j) |
|
(i32.sub (i32.const 20) |
|
(local.get $k))) |
|
(local.get $iy)) |
|
(local.set $yisint |
|
(i32.sub (i32.const 2) |
|
(i32.and (local.get $j) |
|
(i32.const 1))))))))))))))) |
|
|
|
;; special value of y |
|
(if (i32.eqz (local.get $ly)) |
|
(then (if (i32.eq (local.get $iy) (i32.const 0x7ff00000)) ;; y is +-inf |
|
(if (i32.eqz (i32.or (i32.sub (local.get $ix) |
|
(i32.const 0x3ff00000)) |
|
(local.get $lx))) |
|
(then (return (f64.sub (local.get $y) (local.get $y)))) ;; inf**+-1 is NaN |
|
;; (|x|>1)**+-inf = inf, 0 |
|
(else (if (i32.ge_u (local.get $ix) (i32.const 0x3ff00000)) |
|
(then (if (i32.ge_s (local.get $hy) (i32.const 0)) |
|
(then (return (local.get $y))) |
|
(else (return (global.get $zero))))) |
|
;; (|x|<1)**-,+inf = inf,0 |
|
(else (if (i32.lt_s (local.get $hy) (i32.const 0)) |
|
(then (return (f64.mul (local.get $y) (f64.const -1)))) |
|
(else (return (global.get $zero))))))))) |
|
(if (i32.eq (local.get $iy) (i32.const 0x3ff00000)) ;; y is +-1 |
|
(if (i32.lt_s (local.get $hy) (i32.const 0)) |
|
(then (return (f64.div (f64.const 1) (local.get $x)))) |
|
(else (return (local.get $x))))) |
|
(if (i32.eq (local.get $hy) (i32.const 0x40000000)) ;; y is 2 |
|
(return (f64.mul (local.get $x) (local.get $x)))) |
|
(if (i32.eq (local.get $hy) (i32.const 0x3fe00000)) |
|
(if (i32.ge_u (local.get $hx) (i32.const 0)) |
|
(return (f64.sqrt (local.get $x))))))) |
|
|
|
(local.set $ax (f64.abs (local.get $x))) |
|
;; special value of x |
|
(if (i32.and (i32.eqz (local.get $lx)) |
|
(i32.or (i32.eq (local.get $ix) (i32.const 0x7ff00000)) |
|
(i32.or (i32.eqz (local.get $ix)) |
|
(i32.eq (local.get $ix) (i32.const 0x3ff00000))))) |
|
(then (local.set $z (local.get $ax)) ;; x is +-0,+-inf,+-1 |
|
(if (i32.lt_s (local.get $hy) (i32.const 0)) |
|
(local.set $z (f64.div (global.get $one) (local.get $z)))) ;; z = (1/|x|) |
|
(if (i32.lt_s (local.get $hx) (i32.const 0)) |
|
(if (i32.eqz (i32.or (i32.sub (local.get $ix) (i32.const 0x3ff00000)) |
|
(local.get $yisint))) |
|
(then (local.set $z (f64.div (f64.sub (local.get $z) (local.get $z)) |
|
(f64.sub (local.get $z) (local.get $z))))) ;; (-1)**non-int is NaN |
|
(else (if (i32.eq (local.get $yisint) (i32.const 1)) |
|
(then (local.set $z (f64.mul (f64.const -1) (local.get $z)))))))) ;; (x<0)**odd = -(|x|**odd) |
|
(return (local.get $z)))) |
|
|
|
(local.set $n (i32.add (i32.shr_u (local.get $hx) (i32.const 31)) |
|
(i32.const 1))) |
|
|
|
;; (x<0)**(non-int) is NaN |
|
(if (i32.eqz (i32.or (local.get $n) (local.get $yisint))) |
|
(return (f64.div (f64.sub (local.get $x) (local.get $x)) |
|
(f64.sub (local.get $x) (local.get $x))))) |
|
|
|
(local.set $s (f64.const 1)) ;; s (sign of result -ve**odd) = -1 else = 1 |
|
(if (i32.eqz (i32.or (local.get $n) (i32.sub (local.get $yisint) (i32.const 1)))) |
|
(local.set $s (f64.mul (f64.const -1) |
|
(global.get $one)))) ;; (-ve)**(odd int) |
|
|
|
;; |y| is huge |
|
(if (i32.gt_u (local.get $iy) (i32.const 0x41e00000)) ;; if |y| > 2**31 |
|
(then (if (i32.gt_u (local.get $iy) (i32.const 0x43f00000)) ;; if |y| > 2**64, must o/uflow |
|
(then (if (i32.le_u (local.get $ix) (i32.const 0x3fefffff)) |
|
(if (i32.lt_s (local.get $hy) (i32.const 0)) |
|
(then (return (f64.mul (global.get $huge) (global.get $huge)))) |
|
(else (return (f64.mul (global.get $tiny) (global.get $tiny)))))) |
|
(if (i32.ge_u (local.get $ix) (i32.const 0x3ff00000)) |
|
(if (i32.gt_s (local.get $hy) (i32.const 0)) |
|
(then (return (f64.mul (global.get $huge) (global.get $huge)))) |
|
(else (return (f64.mul (global.get $tiny) (global.get $tiny)))))))) |
|
;; over/underflow if x is not close to one |
|
(if (i32.lt_u (local.get $ix) (i32.const 0x3fefffff)) |
|
(if (i32.lt_s (local.get $hy) (i32.const 0)) |
|
(then (return (f64.mul (local.get $s) |
|
(f64.mul (global.get $huge) (global.get $huge))))) |
|
(else (return (f64.mul (local.get $s) |
|
(f64.mul (global.get $tiny) (global.get $tiny))))))) |
|
(if (i32.gt_u (local.get $ix) (i32.const 0x3ff00000)) |
|
(if (i32.gt_s (local.get $hy) (i32.const 0)) |
|
(then (return (f64.mul (local.get $s) |
|
(f64.mul (global.get $huge) (global.get $huge))))) |
|
(else (return (f64.mul (local.get $s) |
|
(f64.mul (global.get $tiny) (global.get $tiny))))))) |
|
;; now |1-x| is tiny <= 2**-20, suffice to compute log(x) by x-x^2/2+x^3/3-x^4/4 |
|
(local.set $t (f64.sub (local.get $ax) (global.get $one))) ;; t has 20 trailing zeros |
|
(local.set $w (f64.mul (f64.mul (local.get $t) (local.get $t)) |
|
(f64.sub (f64.const 0.5) |
|
(f64.mul (local.get $t) |
|
(f64.sub (f64.const 0.3333333333333333333333) |
|
(f64.mul (local.get $t) |
|
(f64.const 0.25))))))) |
|
(local.set $u (f64.mul (global.get $ivln2_h) (local.get $t))) ;; ivln2_h has 21 sig. bits |
|
(local.set $v (f64.sub (f64.mul (local.get $t) (global.get $ivln2_l)) |
|
(f64.mul (local.get $w) (global.get $ivln2)))) |
|
(local.set $t1 (f64.reinterpret/i64 |
|
(i64.and (i64.reinterpret/f64 (f64.add (local.get $u) |
|
(local.get $v))) |
|
(i64.const 0xFFFFFFFF00000000)))) |
|
(local.set $t2 (f64.sub (local.get $v) |
|
(f64.sub (local.get $t1) (local.get $u))))) |
|
(else (local.set $n (i32.const 0)) |
|
;; take care subnormal number |
|
(if (i32.lt_u (local.get $ix) (i32.const 0x00100000)) |
|
(then (local.set $ax (f64.mul (local.get $ax) (global.get $two53))) |
|
(local.set $n (i32.sub (local.get $n) (i32.const 53))) |
|
(local.set $ix (i32.wrap/i64 (i64.shr_u (i64.reinterpret/f64 (local.get $ax)) |
|
(i64.const 32)))))) |
|
(local.set $n (i32.add (local.get $n) |
|
(i32.sub (i32.shr_u (local.get $ix) |
|
(i32.const 20)) |
|
(i32.const 0x3ff)))) |
|
(local.set $j (i32.and (local.get $ix) |
|
(i32.const 0x000fffff))) |
|
;; determine interval |
|
(local.set $ix (i32.or (local.get $j) (i32.const 0x3ff00000))) ;; normalize ix |
|
(if (i32.le_u (local.get $j) (i32.const 0x3988E)) ;; |x|<sqrt(3/2) |
|
(then (local.set $k (i32.const 0))) |
|
(else (if (i32.lt_u (local.get $j) (i32.const 0xBB67A)) |
|
(then (local.set $k (i32.const 1))) ;; |x|<sqrt(3) |
|
(else (local.set $k (i32.const 0)) |
|
(local.set $n (i32.add (local.get $n) (i32.const 1))) |
|
(local.set $ix (i32.sub (local.get $ix) (i32.const 0x00100000))))))) |
|
(local.set $ax (f64.reinterpret/i64 |
|
(i64.xor (i64.and (i64.reinterpret/f64 (local.get $ax)) |
|
(i64.const 0x00000000FFFFFFFF)) |
|
(i64.shl (i64.extend_u/i32 (local.get $ix)) (i64.const 32))))) |
|
|
|
;; compute ss = s_h+s_l = (x-1)/(x+1) or (x-1.5)/(x+1.5) |
|
(local.set $u (f64.sub (local.get $ax) |
|
(f64.add (global.get $one) |
|
(f64.mul (f64.convert_s/i32 (local.get $k)) |
|
(global.get $bp))))) |
|
(local.set $v (f64.div (global.get $one) |
|
(f64.add (local.get $ax) |
|
(f64.add (global.get $one) |
|
(f64.mul (f64.convert_s/i32 (local.get $k)) |
|
(global.get $bp)))))) |
|
(local.set $ss (f64.mul (local.get $u) (local.get $v))) |
|
(local.set $s_h (f64.reinterpret/i64 (i64.and (i64.reinterpret/f64 (local.get $ss)) |
|
(i64.const 0xFFFFFFFF00000000)))) |
|
;; t_h=ax+bp[k] High |
|
(local.set $t_h (f64.reinterpret/i64 |
|
(i64.shl (i64.extend_u/i32 (i32.add (i32.or (i32.shr_u (local.get $ix) |
|
(i32.const 1)) |
|
(i32.const 0x20000000)) |
|
(i32.add (i32.const 0x00080000) |
|
(i32.shl (local.get $k) |
|
(i32.const 18))))) |
|
(i64.const 32)))) |
|
(local.set $t_l (f64.sub (local.get $ax) |
|
(f64.sub (local.get $t_h) |
|
(f64.add (global.get $one) |
|
(f64.mul (f64.convert_s/i32 (local.get $k)) |
|
(global.get $bp)))))) |
|
(local.set $s_l (f64.mul (local.get $v) |
|
(f64.sub (f64.sub (local.get $u) |
|
(f64.mul (local.get $s_h) |
|
(local.get $t_h))) |
|
(f64.mul (local.get $s_h) |
|
(local.get $t_l))))) |
|
;; compute log(ax) |
|
(local.set $s2 (f64.mul (local.get $ss) (local.get $ss))) |
|
(local.set $r |
|
(f64.mul |
|
(local.get $s2) |
|
(f64.mul |
|
(local.get $s2) |
|
(f64.add |
|
(global.get $L1) |
|
(f64.mul |
|
(local.get $s2) |
|
(f64.add |
|
(global.get $L2) |
|
(f64.mul |
|
(local.get $s2) |
|
(f64.add |
|
(global.get $L3) |
|
(f64.mul |
|
(local.get $s2) |
|
(f64.add |
|
(global.get $L4) |
|
(f64.mul |
|
(local.get $s2) |
|
(f64.add |
|
(global.get $L5) |
|
(f64.mul |
|
(local.get $s2) |
|
(global.get $L6)))))))))))))) |
|
(local.set $r (f64.add (local.get $r) |
|
(f64.mul (local.get $s_l) |
|
(f64.add (local.get $s_h) |
|
(local.get $ss))))) |
|
(local.set $s2 (f64.mul (local.get $s_h) |
|
(local.get $s_h))) |
|
(local.set $t_h (f64.add (f64.const 3.0) (f64.add (local.get $s2) (local.get $r)))) |
|
(local.set $t_h (f64.reinterpret/i64 (i64.and (i64.reinterpret/f64 (local.get $t_h)) |
|
(i64.const 0xFFFFFFFF00000000)))) |
|
(local.set $t_l (f64.sub (local.get $r) |
|
(f64.sub (f64.sub (local.get $t_h) |
|
(f64.const 3.0)) |
|
(local.get $s2)))) |
|
;; u+v = ss*(1+...) |
|
(local.set $u (f64.mul (local.get $s_h) (local.get $t_h))) |
|
(local.set $v (f64.add (f64.mul (local.get $s_l) |
|
(local.get $t_h)) |
|
(f64.mul (local.get $t_l) |
|
(local.get $ss)))) |
|
;; 2/(3log2)*(ss+...) |
|
(local.set $p_h (f64.add (local.get $u) (local.get $v))) |
|
(local.set $p_h (f64.reinterpret/i64 (i64.and (i64.reinterpret/f64 (local.get $p_h)) |
|
(i64.const 0xFFFFFFFF00000000)))) |
|
(local.set $p_l (f64.sub (local.get $v) |
|
(f64.sub (local.get $p_h) |
|
(local.get $u)))) |
|
(local.set $z_h (f64.mul (global.get $cp_h) (local.get $p_h))) ;; cp_h + cp_l = 2/(3*log2) |
|
(local.set $z_l (f64.add (f64.add (f64.mul (global.get $cp_l) (local.get $p_h)) |
|
(f64.mul (local.get $p_l) (global.get $cp))) |
|
(f64.mul (f64.convert_u/i32 (local.get $k)) |
|
(global.get $dp_l)))) |
|
;; log2(ax) = (ss++..)*2/(3*log2) = n + dp_h + z_h + z_l |
|
(local.set $t (f64.convert_s/i32 (local.get $n))) |
|
(local.set $t1 (f64.add (f64.add (f64.add (local.get $z_h) (local.get $z_l)) |
|
(f64.mul (f64.convert_u/i32 (local.get $k)) |
|
(global.get $dp_h))) |
|
(local.get $t))) |
|
(local.set $t1 (f64.reinterpret/i64 (i64.and (i64.reinterpret/f64 (local.get $t1)) |
|
(i64.const 0xFFFFFFFF00000000)))) |
|
(local.set $t2 (f64.sub (local.get $z_l) |
|
(f64.sub (f64.sub (f64.sub (local.get $t1) (local.get $t)) |
|
(f64.mul (f64.convert_u/i32 (local.get $k)) |
|
(global.get $dp_h))) |
|
(local.get $z_h)))))) |
|
|
|
;; split up y into y1 + y2 and compute (y1+y2)*(t1+t2) |
|
(local.set $y1 (local.get $y)) |
|
(local.set $y1 (f64.reinterpret/i64 (i64.and (i64.reinterpret/f64 (local.get $y1)) |
|
(i64.const 0xFFFFFFFF00000000)))) |
|
(local.set $p_l (f64.add (f64.mul (f64.sub (local.get $y) (local.get $y1)) |
|
(local.get $t1)) |
|
(f64.mul (local.get $y) |
|
(local.get $t2)))) |
|
(local.set $p_h (f64.mul (local.get $y1) (local.get $t1))) |
|
(local.set $z (f64.add (local.get $p_l) (local.get $p_h))) |
|
(local.set $j (i32.wrap/i64 (i64.shr_u (i64.reinterpret/f64 (local.get $z)) |
|
(i64.const 32)))) |
|
(local.set $i (i32.wrap/i64 (i64.reinterpret/f64 (local.get $z)))) |
|
(if (i32.ge_s (local.get $j) (i32.const 0x40900000)) ;; z >= 1024 |
|
(then (if (i32.ne (i32.or (i32.sub (local.get $j) (i32.const 0x40900000)) |
|
(local.get $i)) |
|
(i32.const 0)) ;; if z > 1024 |
|
;; overflow |
|
(then (return (f64.mul (local.get $s) (global.get $huge) (global.get $huge)))) |
|
(else (if (f64.gt (f64.add (local.get $p_l) (global.get $ovt)) |
|
(f64.sub (local.get $z) (local.get $p_h))) |
|
;; overflow |
|
(return (f64.mul (local.get $s) (global.get $huge) (global.get $huge))))))) |
|
(else (if (i32.ge_u (i32.and (local.get $j) (i32.const 0x7fffffff)) |
|
(i32.const 0x4090cc00)) ;; z <= -1075 |
|
(if (i32.ne (i32.or (i32.sub (local.get $j) (i32.const 0xc090cc00)) |
|
(local.get $i)) |
|
(i32.const 0)) ;; z < -1075 |
|
;; underflow |
|
(then (return (f64.mul (local.get $s) (global.get $tiny) (global.get $tiny)))) |
|
(else (if (f64.le (local.get $p_l) (f64.sub (local.get $z) (local.get $p_h))) |
|
(return (f64.mul (local.get $s) |
|
(global.get $tiny) |
|
(global.get $tiny))))))))) ;; underflow |
|
;; compute 2**(p_h+p_l) |
|
(local.set $i (i32.and (local.get $j) (i32.const 0x7fffffff))) |
|
(local.set $k (i32.sub (i32.shr_u (local.get $i) (i32.const 20)) (i32.const 0x3ff))) |
|
(local.set $n (i32.const 0)) |
|
(if (i32.gt_u (local.get $i) (i32.const 0x3fe00000)) |
|
(then (local.set $n (i32.add (local.get $j) |
|
(i32.shr_u (i32.const 0x00100000) |
|
(i32.add (local.get $k) (i32.const 1))))) |
|
(local.set $k (i32.sub (i32.shr_u (i32.and (local.get $n) (i32.const 0x7fffffff)) |
|
(i32.const 20)) |
|
(i32.const 0x3FF))) |
|
(local.set $t (f64.reinterpret/i64 |
|
(i64.shl (i64.extend_u/i32 |
|
(i32.and (local.get $n) |
|
(i32.sub (i32.mul (i32.shr_u (i32.const 0x000fffff) |
|
(local.get $k)) |
|
(i32.const -1)) |
|
(i32.const 1)))) |
|
(i64.const 32)))) |
|
(local.set $n (i32.shr_u (i32.or (i32.and (local.get $n) (i32.const 0x000fffff)) |
|
(i32.const 0x00100000)) |
|
(i32.sub (i32.const 20) (local.get $k)))) |
|
(if (i32.lt_s (local.get $j) (i32.const 0)) |
|
(local.set $n (i32.mul (i32.const -1) (local.get $n)))) |
|
(local.set $p_h (f64.sub (local.get $p_h) (local.get $t))))) |
|
(local.set $t (f64.add (local.get $p_l) (local.get $p_h))) |
|
(local.set $t (f64.reinterpret/i64 (i64.and (i64.reinterpret/f64 (local.get $t)) |
|
(i64.const 0xFFFFFFFF00000000)))) |
|
(local.set $u (f64.mul (local.get $t) (global.get $lg2_h))) |
|
(local.set $v (f64.add (f64.mul (f64.sub (local.get $p_l) (f64.sub (local.get $t) (local.get $p_h))) |
|
(global.get $lg2)) |
|
(f64.mul (local.get $t) (global.get $lg2_l)))) |
|
(local.set $z (f64.add (local.get $u) (local.get $v))) |
|
(local.set $w (f64.sub (local.get $v (f64.sub (local.get $z) (local.get $u))))) |
|
(local.set $t (f64.mul (local.get $z) (local.get $z))) |
|
(local.set $t1 |
|
(f64.sub |
|
(local.get $z) |
|
(f64.mul |
|
(local.get $t) |
|
(f64.add |
|
(global.get $P1) |
|
(f64.mul |
|
(local.get $t) |
|
(f64.add |
|
(global.get $P2) |
|
(f64.mul |
|
(local.get $t) |
|
(f64.add (global.get $P3) |
|
(f64.mul (local.get $t) |
|
(f64.add (global.get $P4) |
|
(f64.mul (local.get $t) (global.get $P5)))))))))))) |
|
(local.set $r (f64.sub (f64.div (f64.mul (local.get $z) (local.get $t1)) |
|
(f64.sub (local.get $t1) (global.get $two))) |
|
(f64.add (local.get $w) |
|
(f64.mul (local.get $z) (local.get $w))))) |
|
(local.set $z (f64.sub (global.get $one) (f64.sub (local.get $r) (local.get $z)))) |
|
(local.set $j (i32.wrap/i64 (i64.shr_u (i64.reinterpret/f64 (local.get $z)) (i64.const 32)))) |
|
(local.set $j (i32.add (local.get $j) (i32.shl (local.get $n) (i32.const 20)))) |
|
(if (i32.lt_s (i32.shr_u (local.get $j) (i32.const 20)) (i32.const 0)) |
|
(then (local.set $z (call $scalbn (local.get $z) (local.get $n)))) |
|
(else (local.set $z |
|
(f64.reinterpret/i64 |
|
(i64.add (i64.reinterpret/f64 (local.get $z)) |
|
(i64.shl (i64.extend_u/i32 (i32.shl (local.get $n) |
|
(i32.const 20))) |
|
(i64.const 32))))))) |
|
|
|
|
|
(f64.mul (local.get $s) (local.get $z))) |
|
|
|
(func $pow-op (param $cons i32) (result i32) |
|
(local $type i32) |
|
(local $car i32) |
|
(local $cdr i32) |
|
(local $base f64) |
|
(local $power f64) |
|
(local $result i32) |
|
(local.set $type (i32.load (local.get $cons))) |
|
|
|
;; Error if not a list |
|
(if (i32.ne (local.get $type) (global.get $cons)) |
|
(then (local.set $car (call $alloc (i32.const 4))) |
|
(i32.store (local.get $car) (global.get $error)) |
|
(return (local.get $car)))) |
|
|
|
(local.set $car (call $car (local.get $cons))) |
|
(local.set $cdr (call $cdr (local.get $cons))) |
|
|
|
;; Error if less than 2 argument |
|
;; (if (i32.ne (local.get $cdr) (global.get $cons)) |
|
;; (then (local.set $car (call $alloc (i32.const 4))) |
|
;; (i32.store (local.get $car) (global.get $error)) |
|
;; (return (local.get $car)))) |
|
|
|
(local.set $base (f64.load (i32.add (local.get $car) |
|
(i32.const 4)))) |
|
(local.set $power (f64.load (i32.add (call $car (local.get $cdr)) |
|
(i32.const 4)))) |
|
|
|
;; Error if more than 2 argument |
|
(if (i32.ne (call $cdr (local.get $cdr)) (global.get $nil)) |
|
(then (local.set $car (call $alloc (i32.const 4))) |
|
(i32.store (local.get $car) (global.get $error)) |
|
(return (local.get $car)))) |
|
|
|
(local.set $result (call $alloc (i32.const 12))) |
|
(i32.store (local.get $result) (global.get $number)) |
|
(f64.store (i32.add (local.get $result) (i32.const 4)) |
|
(call $pow (local.get $base) (local.get $power))) |
|
(local.get $result)) |
|
|
|
(func $sqrt (param $cons i32) (result i32) |
|
(local $type i32) |
|
(local $car i32) |
|
(local $cdr i32) |
|
(local $result i32) |
|
(local.set $type (i32.load (local.get $cons))) |
|
|
|
;; Error if not a list |
|
(if (i32.ne (local.get $type) (global.get $cons)) |
|
(then (local.set $car (call $alloc (i32.const 4))) |
|
(i32.store (local.get $car) (global.get $error)) |
|
(return (local.get $car)))) |
|
|
|
(local.set $car (call $car (local.get $cons))) |
|
(local.set $cdr (call $cdr (local.get $cons))) |
|
|
|
;; Error if less than 1 argument |
|
;; (if (i32.ne (local.get $cdr) (global.get $cons)) |
|
;; (then (local.set $car (call $alloc (i32.const 4))) |
|
;; (i32.store (local.get $car) (global.get $error)) |
|
;; (return (local.get $car)))) |
|
|
|
;; Error if more than 1 argument |
|
(if (i32.ne (local.get $cdr) (global.get $nil)) |
|
(then (local.set $car (call $alloc (i32.const 4))) |
|
(i32.store (local.get $car) (global.get $error)) |
|
(return (local.get $car)))) |
|
|
|
(local.set $result (call $alloc (i32.const 12))) |
|
(i32.store (local.get $result) (global.get $number)) |
|
(f64.store (i32.add (local.get $result) (i32.const 4)) |
|
(f64.sqrt (f64.load (i32.add (local.get $car) |
|
(i32.const 4))))) |
|
(local.get $result)) |
|
|
|
(func $eq (param $cons i32) (result i32) |
|
;; 2 arguments |
|
(local $car i32) |
|
(local $car-type i32) |
|
(local $cadr i32) |
|
(local $cadr-type i32) |
|
(local.set $car (call $car (local.get $cons))) |
|
(local.set $cadr (call $car (call $cdr (local.get $cons)))) |
|
(local.set $car-type (i32.load (local.get $car))) |
|
(local.set $cadr-type (i32.load (local.get $cadr))) |
|
(if (i32.ne (local.get $car-type) (local.get $cadr-type)) |
|
(return (global.get $nil))) |
|
|
|
(if (i32.eq (local.get $car-type) (global.get $number)) |
|
(if (f64.eq (f64.load (i32.add (local.get $car) (i32.const 4))) |
|
(f64.load (i32.add (local.get $cadr) (i32.const 4)))) |
|
(then (return (global.get $true))) |
|
(else (return (global.get $nil))))) |
|
|
|
(if (i32.eq (local.get $car) (local.get $cadr)) |
|
(then (return (global.get $true)))) |
|
|
|
(global.get $nil)) |
|
|
|
(func $lt (param $cons i32) (result i32) |
|
;; 2 arguments |
|
(local $car i32) |
|
(local $car-type i32) |
|
(local $cadr i32) |
|
(local $cadr-type i32) |
|
(local.set $car (call $car (local.get $cons))) |
|
(local.set $cadr (call $car (call $cdr (local.get $cons)))) |
|
(local.set $car-type (i32.load (local.get $car))) |
|
(local.set $cadr-type (i32.load (local.get $cadr))) |
|
(if (i32.or (i32.ne (local.get $car-type) (local.get $cadr-type)) |
|
(i32.ne (local.get $car-type) (global.get $number))) |
|
(return (global.get $nil))) |
|
|
|
(if (f64.lt (f64.load (i32.add (local.get $car) (i32.const 4))) |
|
(f64.load (i32.add (local.get $cadr) (i32.const 4)))) |
|
(return (global.get $true))) |
|
(global.get $nil)) |
|
|
|
(func $le (param $cons i32) (result i32) |
|
;; 2 arguments |
|
(local $car i32) |
|
(local $car-type i32) |
|
(local $cadr i32) |
|
(local $cadr-type i32) |
|
(local.set $car (call $car (local.get $cons))) |
|
(local.set $cadr (call $car (call $cdr (local.get $cons)))) |
|
(local.set $car-type (i32.load (local.get $car))) |
|
(local.set $cadr-type (i32.load (local.get $cadr))) |
|
(if (i32.or (i32.ne (local.get $car-type) (local.get $cadr-type)) |
|
(i32.ne (local.get $car-type) (global.get $number))) |
|
(return (global.get $nil))) |
|
|
|
(if (f64.le (f64.load (i32.add (local.get $car) (i32.const 4))) |
|
(f64.load (i32.add (local.get $cadr) (i32.const 4)))) |
|
(return (global.get $true))) |
|
(global.get $nil)) |
|
|
|
(func $gt (param $cons i32) (result i32) |
|
;; 2 arguments |
|
(local $car i32) |
|
(local $car-type i32) |
|
(local $cadr i32) |
|
(local $cadr-type i32) |
|
(local.set $car (call $car (local.get $cons))) |
|
(local.set $cadr (call $car (call $cdr (local.get $cons)))) |
|
(local.set $car-type (i32.load (local.get $car))) |
|
(local.set $cadr-type (i32.load (local.get $cadr))) |
|
(if (i32.or (i32.ne (local.get $car-type) (local.get $cadr-type)) |
|
(i32.ne (local.get $car-type) (global.get $number))) |
|
(return (global.get $nil))) |
|
|
|
(if (f64.gt (f64.load (i32.add (local.get $car) (i32.const 4))) |
|
(f64.load (i32.add (local.get $cadr) (i32.const 4)))) |
|
(return (global.get $true))) |
|
(global.get $nil)) |
|
|
|
(func $ge (param $cons i32) (result i32) |
|
;; 2 arguments |
|
(local $car i32) |
|
(local $car-type i32) |
|
(local $cadr i32) |
|
(local $cadr-type i32) |
|
(local.set $car (call $car (local.get $cons))) |
|
(local.set $cadr (call $car (call $cdr (local.get $cons)))) |
|
(local.set $car-type (i32.load (local.get $car))) |
|
(local.set $cadr-type (i32.load (local.get $cadr))) |
|
(if (i32.or (i32.ne (local.get $car-type) (local.get $cadr-type)) |
|
(i32.ne (local.get $car-type) (global.get $number))) |
|
(return (global.get $nil))) |
|
|
|
(if (f64.ge (f64.load (i32.add (local.get $car) (i32.const 4))) |
|
(f64.load (i32.add (local.get $cadr) (i32.const 4)))) |
|
(return (global.get $true))) |
|
(global.get $nil)) |
|
|
|
(func $not (param $cons i32) (result i32) |
|
;; 2 arguments |
|
(local $car i32) |
|
(local.set $car (call $car (local.get $cons))) |
|
(if (i32.eq (local.get $car) (global.get $nil)) |
|
(return (global.get $true))) |
|
(global.get $true)) |
|
|
|
(func $ne (param $cons i32) (result i32) |
|
;; 2 arguments |
|
(local $car i32) |
|
(local $car-type i32) |
|
(local $cadr i32) |
|
(local $cadr-type i32) |
|
(local.set $car (call $car (local.get $cons))) |
|
(local.set $cadr (call $car (call $cdr (local.get $cons)))) |
|
(local.set $car-type (i32.load (local.get $car))) |
|
(local.set $cadr-type (i32.load (local.get $cadr))) |
|
(if (i32.ne (local.get $car-type) (local.get $cadr-type)) |
|
(return (global.get $true))) |
|
|
|
(if (i32.eq (local.get $car-type) (global.get $number)) |
|
(if (f64.eq (f64.load (i32.add (local.get $car) (i32.const 4))) |
|
(f64.load (i32.add (local.get $cadr) (i32.const 4)))) |
|
(then (return (global.get $nil))) |
|
(else (return (global.get $true))))) |
|
|
|
(if (i32.eq (local.get $car) (local.get $cadr)) |
|
(return (global.get $nil))) |
|
|
|
(global.get $true)) |
|
|
|
(func $and (param $cons i32) (param $env i32) (result i32) |
|
(local $car i32) |
|
(local $cdr i32) |
|
(local $result i32) |
|
(local.set $cdr (local.get $cons)) |
|
(loop $continue |
|
(block $break |
|
(local.set $car (call $car (local.get $cdr))) |
|
(local.set $result (call $eval (local.get $car) (local.get $env))) |
|
(br_if $break (i32.eq (local.get $result) (global.get $nil))) |
|
(local.set $cdr (call $cdr (local.get $cdr))) |
|
(br_if $break (i32.eq (local.get $cdr) (global.get $nil))) |
|
(br $continue))) |
|
(local.get $result)) |
|
|
|
(func $or (param $cons i32) (param $env i32) (result i32) |
|
(local $car i32) |
|
(local $cdr i32) |
|
(local $result i32) |
|
(local.set $cdr (local.get $cons)) |
|
(loop $continue |
|
(block $break |
|
(local.set $car (call $car (local.get $cdr))) |
|
(local.set $result (call $eval (local.get $car) (local.get $env))) |
|
(br_if $break (i32.ne (local.get $result) (global.get $nil))) |
|
(local.set $cdr (call $cdr (local.get $cdr))) |
|
(br_if $break (i32.eq (local.get $cdr) (global.get $nil))) |
|
(br $continue))) |
|
(local.get $result)) |
|
|
|
(func $if (param $cons i32) (param $env i32) (result i32) |
|
(local $i i32) |
|
(if (i32.ne (call $eval (call $car (local.get $cons)) |
|
(local.get $env)) |
|
(global.get $nil)) |
|
(return (call $eval (call $car (call $cdr (local.get $cons))) |
|
(local.get $env)))) |
|
|
|
(local.set $i (call $cdr (call $cdr (local.get $cons)))) |
|
(if (i32.ne (local.get $i) (global.get $nil)) |
|
(return (call $eval (call $car (local.get $i)) (local.get $env)))) |
|
(global.get $nil)) |
|
|
|
;; (let ((a 5) (b 3)) (+ a b)) |
|
(func $let (param $cons i32) (param $env i32) (result i32) |
|
(local $table i32) |
|
(local $body i32) |
|
(local $key i32) |
|
(local $value i32) |
|
(local $car i32) |
|
(local $cdr i32) |
|
(local $result i32) |
|
(local.set $result (global.get $nil)) |
|
(local.set $table (call $car (local.get $cons))) |
|
(local.set $body (call $cdr (local.get $cons))) |
|
(if (i32.ne (local.get $table) (global.get $nil)) |
|
(then (local.set $cdr (local.get $table)) |
|
(loop $continue |
|
(block $break |
|
(local.set $car (call $car (local.get $cdr))) |
|
(local.set $key (call $car (local.get $car))) |
|
(local.set $cons (call $alloc (i32.const 12))) |
|
(i32.store (local.get $cons) (local.get $key)) |
|
(i32.store (i32.add (local.get $cons) (i32.const 4)) (local.get $env)) |
|
(local.set $env (local.get $cons)) |
|
(local.set $value (call $eval |
|
(call $car (call $cdr (local.get $car))) |
|
(local.get $env))) |
|
(i32.store (i32.add (local.get $cons) (i32.const 8)) (local.get $value)) |
|
(local.set $cdr (call $cdr (local.get $cdr))) |
|
(br_if $break (i32.eq (local.get $cdr) (global.get $nil))) |
|
(br $continue))))) |
|
|
|
(local.set $cdr (local.get $body)) |
|
(loop $continue |
|
(block $break |
|
(local.set $car (call $car (local.get $cdr))) |
|
(local.set $result (call $eval (local.get $car) (local.get $env))) |
|
(local.set $cdr (call $cdr (local.get $cdr))) |
|
(br_if $break (i32.eq (local.get $cdr) (global.get $nil))) |
|
(br $continue))) |
|
(local.get $result)) |
|
|
|
(func $def (param $cons i32) (param $env i32) (result i32) |
|
(local $key i32) |
|
(local $value i32) |
|
(local.set $key (call $car (local.get $cons))) |
|
(local.set $value (call $eval (call $car (call $cdr (local.get $cons))) (local.get $env))) |
|
(local.set $cons (call $alloc (i32.const 12))) |
|
(i32.store (local.get $cons) (local.get $key)) |
|
(i32.store (i32.add (local.get $cons) (i32.const 4)) (global.get $env)) |
|
(i32.store (i32.add (local.get $cons) (i32.const 8)) (local.get $value)) |
|
(global.set $env (local.get $cons)) |
|
(local.get $key)) |
|
|
|
(func $set (param $cons i32) (param $env i32) (result i32) |
|
(local $key i32) |
|
(local $value i32) |
|
(local $ptr i32) |
|
(local $cdr i32) |
|
(local.set $key (call $car (local.get $cons))) |
|
(local.set $value (call $eval (call $car (call $cdr (local.get $cons))) (local.get $env))) |
|
(block $found |
|
(local.set $cdr (local.get $env)) |
|
(loop $continue |
|
(block $break |
|
(br_if $break (i32.eq (local.get $cdr) (global.get $nil))) |
|
|
|
(if (i32.eq (i32.load (local.get $cdr)) (local.get $key)) |
|
(then (local.set $ptr (i32.add (local.get $cdr) (i32.const 8))) |
|
(br $found))) |
|
(local.set $cdr (i32.load (i32.add (local.get $cdr) (i32.const 4)))) |
|
(br $continue))) |
|
(local.set $cdr (global.get $env)) |
|
(loop $continue |
|
(block $break |
|
(br_if $break (i32.eq (local.get $cdr) (global.get $nil))) |
|
|
|
(if (i32.eq (i32.load (local.get $cdr)) (local.get $key)) |
|
(then (local.set $ptr (i32.add (local.get $cdr) (i32.const 8))) |
|
(br $found))) |
|
(local.set $cdr (i32.load (i32.add (local.get $cdr) (i32.const 4)))) |
|
(br $continue))) |
|
;; ERROR: Not found! |
|
) |
|
(i32.store (local.get $ptr) (local.get $value)) |
|
(local.get $value)) |
|
|
|
(func $fn (param $cons i32) (param $env i32) (result i32) |
|
(local $args i32) |
|
(local $body i32) |
|
(local $result i32) |
|
(local.set $args (call $car (local.get $cons))) |
|
(local.set $body (call $cdr (local.get $cons))) |
|
(local.set $result (call $alloc (i32.const 16))) |
|
(i32.store (local.get $result) (global.get $lambda)) |
|
(i32.store (i32.add (local.get $result) (i32.const 4)) (local.get $args)) |
|
(i32.store (i32.add (local.get $result) (i32.const 8)) (local.get $body)) |
|
(i32.store (i32.add (local.get $result) (i32.const 12)) (local.get $env)) |
|
(local.get $result)) |
|
|
|
(func $eval-fn (param $fn i32) (param $params i32) (result i32) |
|
(local $body i32) |
|
(local $env i32) |
|
(local $args i32) |
|
(local $param i32) |
|
(local $arg i32) |
|
(local $cons i32) |
|
(local $result i32) |
|
(local.set $args (i32.load (i32.add (local.get $fn) (i32.const 4)))) |
|
(local.set $body (i32.load (i32.add (local.get $fn) (i32.const 8)))) |
|
(local.set $env (i32.load (i32.add (local.get $fn) (i32.const 12)))) |
|
|
|
;; Generate new env with params |
|
(loop $continue |
|
(block $break |
|
(local.set $param (call $car (local.get $params))) |
|
(local.set $arg (call $car (local.get $args))) |
|
|
|
(local.set $cons (call $alloc (i32.const 12))) |
|
(if (i32.or (i32.eq (local.get $arg) (global.get $ampbody)) |
|
(i32.eq (local.get $arg) (global.get $amprest))) |
|
(then (i32.store (local.get $cons) |
|
(call $car (call $cdr (local.get $args)))) |
|
(i32.store (i32.add (local.get $cons) (i32.const 4)) |
|
(local.get $env)) |
|
(i32.store (i32.add (local.get $cons) (i32.const 8)) |
|
(local.get $params))) |
|
(else (i32.store (local.get $cons) (local.get $arg)) |
|
(i32.store (i32.add (local.get $cons) (i32.const 4)) |
|
(local.get $env)) |
|
(i32.store (i32.add (local.get $cons) (i32.const 8)) |
|
(local.get $param)))) |
|
(local.set $env (local.get $cons)) |
|
|
|
(local.set $params (call $cdr (local.get $params))) |
|
(local.set $args (call $cdr (local.get $args))) |
|
|
|
;; ERROR: their would be an error if one finish before the other! |
|
(br_if $break (i32.eq (local.get $params) (global.get $nil))) |
|
(br_if $break (i32.eq (local.get $args) (global.get $nil))) |
|
(br $continue))) |
|
|
|
(loop $continue |
|
(block $break |
|
(local.set $cons (call $car (local.get $body))) |
|
(local.set $result (call $eval (local.get $cons) (local.get $env))) |
|
(br_if $break (i32.eq (local.tee $body (call $cdr (local.get $body))) |
|
(global.get $nil))) |
|
(br $continue))) |
|
(local.get $result)) |
|
|
|
(func $cons (param $cons i32) (result i32) |
|
(i32.store (i32.add (local.get $cons) (i32.const 8)) |
|
(i32.load (i32.add (call $cdr (local.get $cons)) (i32.const 4)))) |
|
(local.get $cons)) |
|
|
|
(func $set-macro-character (param $cons i32) (result i32) |
|
(local $macro i32) |
|
(local.set $macro (call $alloc (i32.const 12))) |
|
(i32.store (local.get $macro) |
|
(i32.load (i32.add (call $car (local.get $cons)) (i32.const 4)))) |
|
(i32.store (i32.add (local.get $macro) (i32.const 4)) |
|
(global.get $reader-macro-characters)) |
|
(i32.store (i32.add (local.get $macro) (i32.const 8)) |
|
(call $car (call $cdr (local.get $cons)))) |
|
(global.set $reader-macro-characters (local.get $macro)) |
|
(global.get $nil)) |
|
|
|
;; (defmacro add5 (a) (list '+ a 5)) |
|
(func $defmacro (param $cons i32) (result i32) |
|
(local $symbol i32) |
|
(local $macro i32) |
|
(local.set $macro (call $alloc (i32.const 12))) |
|
(i32.store (local.get $macro) (local.tee $symbol (call $car (local.get $cons)))) |
|
(i32.store (i32.add (local.get $macro) (i32.const 4)) (global.get $macros)) |
|
(i32.store (i32.add (local.get $macro) (i32.const 8)) |
|
(call $fn (call $cdr (local.get $cons)) (global.get $nil))) |
|
(global.set $macros (local.get $macro)) |
|
(local.get $symbol)) |
|
|
|
(func $copy-cons (param $ptr i32) (result i32) |
|
(local $cons i32) |
|
|
|
(if (i32.ne (i32.load (local.get $ptr)) (global.get $cons)) |
|
(return (local.get $ptr))) |
|
|
|
(local.set $cons (call $alloc (i32.const 12))) |
|
(i32.store (local.get $cons) (global.get $cons)) |
|
(i32.store (i32.add (local.get $cons) (i32.const 4)) |
|
(call $car (local.get $ptr))) |
|
(i32.store (i32.add (local.get $cons) (i32.const 8)) |
|
(call $copy-cons (call $cdr (local.get $ptr)))) |
|
(local.get $cons)) |
|
|
|
(func $op:loop (param $cons i32) (param $env i32) (result i32) |
|
(local $cdr i32) |
|
(local.set $cdr (local.get $cons)) |
|
(loop $continue |
|
(block $break |
|
(br_if $break |
|
(i32.eq (call $eval |
|
(call $car (local.get $cdr)) |
|
(local.get $env)) |
|
(global.get $op:break))) |
|
(local.set $cdr (call $cdr (local.get $cdr))) |
|
(if (i32.eq (local.get $cdr) (global.get $nil)) |
|
(local.set $cdr (local.get $cons))) |
|
(br $continue))) |
|
(global.get $nil)) |
|
|
|
(func $eval (export "eval") (param $ptr i32) (param $env i32) (result i32) |
|
(local $op i32) |
|
(local $type i32) |
|
(local $car i32) |
|
(local $cdr i32) |
|
(local.set $ptr (call $copy-cons (local.get $ptr))) |
|
|
|
(if (i32.eq (local.tee $type (i32.load (local.get $ptr))) (global.get $cons)) |
|
(then (local.set $car (call $car (local.get $ptr))) |
|
|
|
;; Macro handling |
|
(local.set $cdr (global.get $macros)) |
|
(loop $continue |
|
(block $break |
|
(br_if $break (i32.eq (local.get $cdr) (global.get $nil))) |
|
|
|
(if (i32.eq (i32.load (local.get $cdr)) (local.get $car)) |
|
(then |
|
(local.set $op (i32.load (i32.add (local.get $cdr) (i32.const 8)))) |
|
(local.set $cdr (call $cdr (local.get $ptr))) |
|
(return (call $eval (call $eval-fn |
|
(local.get $op) |
|
(local.get $cdr)) |
|
(local.get $env))))) |
|
(local.set $cdr (i32.load (i32.add (local.get $cdr) (i32.const 4)))) |
|
(br $continue))) |
|
|
|
(local.set $op (call $eval (local.get $car) (local.get $env))) |
|
(local.set $cdr (call $cdr (local.get $ptr))) |
|
(if (i32.eq (local.get $op) (global.get $op:and)) |
|
(return (call $and (local.get $cdr) (local.get $env)))) |
|
(if (i32.eq (local.get $op) (global.get $op:or)) |
|
(return (call $or (local.get $cdr) (local.get $env)))) |
|
(if (i32.eq (local.get $op) (global.get $op:if)) |
|
(return (call $if (local.get $cdr) (local.get $env)))) |
|
(if (i32.eq (local.get $op) (global.get $op:let)) |
|
(return (call $let (local.get $cdr) (local.get $env)))) |
|
(if (i32.eq (local.get $op) (global.get $op:def)) |
|
(return (call $def (local.get $cdr) (local.get $env)))) |
|
(if (i32.eq (local.get $op) (global.get $op:set)) |
|
(return (call $set (local.get $cdr) (local.get $env)))) |
|
(if (i32.eq (local.get $op) (global.get $op:fn)) |
|
(return (call $fn (local.get $cdr) (local.get $env)))) |
|
(if (i32.eq (local.get $op) (global.get $op:quote)) |
|
(return (call $car (local.get $cdr)))) |
|
(if (i32.eq (local.get $op) (global.get $op:defmacro)) |
|
(return (call $defmacro (local.get $cdr)))) |
|
(if (i32.eq (local.get $op) (global.get $op:loop)) |
|
(return (call $op:loop (local.get $cdr) (local.get $env)))) |
|
|
|
(loop $continue |
|
(block $break |
|
(local.set $car (call $car (local.get $cdr))) |
|
(br_if $break (i32.eq (local.get $cdr) (global.get $nil))) |
|
(i32.store (i32.add (local.get $cdr) (i32.const 4)) |
|
(call $eval (local.get $car) (local.get $env))) |
|
(local.set $cdr (call $cdr (local.get $cdr))) |
|
(br $continue))) |
|
|
|
(local.set $cdr (call $cdr (local.get $ptr))) |
|
(if (i32.eq (i32.load (local.get $op)) (global.get $lambda)) |
|
(return (call $eval-fn (local.get $op) (local.get $cdr)))) |
|
(if (i32.eq (local.get $op) (global.get $op:add)) |
|
(return (call $add (local.get $cdr)))) |
|
(if (i32.eq (local.get $op) (global.get $op:sub)) |
|
(return (call $sub (local.get $cdr)))) |
|
(if (i32.eq (local.get $op) (global.get $op:mul)) |
|
(return (call $mul (local.get $cdr)))) |
|
(if (i32.eq (local.get $op) (global.get $op:div)) |
|
(return (call $div (local.get $cdr)))) |
|
(if (i32.eq (local.get $op) (global.get $op:bit-xor)) |
|
(return (call $bit-xor (local.get $cdr)))) |
|
(if (i32.eq (local.get $op) (global.get $op:bit-or)) |
|
(return (call $bit-or (local.get $cdr)))) |
|
(if (i32.eq (local.get $op) (global.get $op:bit-and)) |
|
(return (call $bit-and (local.get $cdr)))) |
|
(if (i32.eq (local.get $op) (global.get $op:bit-not)) |
|
(return (call $bit-not (local.get $cdr)))) |
|
(if (i32.eq (local.get $op) (global.get $op:pow)) |
|
(return (call $pow-op (local.get $cdr)))) |
|
(if (i32.eq (local.get $op) (global.get $op:sqrt)) |
|
(return (call $sqrt (local.get $cdr)))) |
|
(if (i32.eq (local.get $op) (global.get $op:eq)) |
|
(return (call $eq (local.get $cdr)))) |
|
(if (i32.eq (local.get $op) (global.get $op:lt)) |
|
(return (call $lt (local.get $cdr)))) |
|
(if (i32.eq (local.get $op) (global.get $op:le)) |
|
(return (call $le (local.get $cdr)))) |
|
(if (i32.eq (local.get $op) (global.get $op:gt)) |
|
(return (call $gt (local.get $cdr)))) |
|
(if (i32.eq (local.get $op) (global.get $op:ge)) |
|
(return (call $ge (local.get $cdr)))) |
|
(if (i32.eq (local.get $op) (global.get $op:not)) |
|
(return (call $not (local.get $cdr)))) |
|
(if (i32.eq (local.get $op) (global.get $op:ne)) |
|
(return (call $ne (local.get $cdr)))) |
|
(if (i32.eq (local.get $op) (global.get $op:list)) |
|
(return (local.get $cdr))) |
|
(if (i32.eq (local.get $op) (global.get $op:cons)) |
|
(return (call $cons (local.get $cdr)))) |
|
(if (i32.eq (local.get $op) (global.get $op:car)) |
|
(return (call $car (call $car (local.get $cdr))))) |
|
(if (i32.eq (local.get $op) (global.get $op:cdr)) |
|
(return (call $cdr (call $car (local.get $cdr))))) |
|
(if (i32.eq (local.get $op) (global.get $op:eval)) |
|
(return (call $eval (call $car (local.get $cdr)) (local.get $env)))) |
|
(if (i32.eq (local.get $op) (global.get $op:read)) |
|
(return (call $read))) |
|
(if (i32.eq (local.get $op) (global.get $op:set-macro-character)) |
|
(return (call $set-macro-character (local.get $cdr)))) |
|
(if (i32.eq (local.get $op) (global.get $op:print)) |
|
(return (call $print (call $car (local.get $cdr))))) |
|
;; ERROR something went wrong! |
|
)) |
|
|
|
(if (i32.eq (local.get $type) (global.get $symbol)) |
|
(then (local.set $cdr (local.get $env)) |
|
(loop $continue |
|
(block $break |
|
(br_if $break (i32.eq (local.get $cdr) (global.get $nil))) |
|
|
|
(if (i32.eq (i32.load (local.get $cdr)) (local.get $ptr)) |
|
(return (i32.load (i32.add (local.get $cdr) (i32.const 8))))) |
|
(local.set $cdr (i32.load (i32.add (local.get $cdr) (i32.const 4)))) |
|
(br $continue))) |
|
(local.set $cdr (global.get $env)) |
|
(loop $continue |
|
(block $break |
|
(br_if $break (i32.eq (local.get $cdr) (global.get $nil))) |
|
|
|
(if (i32.eq (i32.load (local.get $cdr)) (local.get $ptr)) |
|
(return (i32.load (i32.add (local.get $cdr) (i32.const 8))))) |
|
(local.set $cdr (i32.load (i32.add (local.get $cdr) |
|
(i32.const 4)))) |
|
(br $continue))))) |
|
|
|
(local.get $ptr)) |
|
|
|
|
|
(func $rep (export "rep") (param $ptr i32) (result i32) |
|
(global.set $output-stream (call $alloc (i32.const 128))) |
|
(global.set $output-stream-length (i32.const 128)) |
|
(global.set $output-stream-index (i32.const 0)) |
|
|
|
(global.set $reader-ptr (local.get $ptr)) |
|
(global.set $reader-pos (i32.const 0)) |
|
|
|
(loop $continue |
|
(block $break |
|
(drop (call $print (call $eval (call $read) (global.get $nil)))) |
|
(br_if $break (i32.eqz (call $reader-peek))) |
|
(call $print-char (i32.const 10)) |
|
(br $continue))) |
|
|
|
(call $print-char (i32.const 0)) |
|
(global.get $output-stream)) |
|
|
|
(func (export "print") (param $ptr i32) (result i32) |
|
(drop (call $print (local.get $ptr))) |
|
(global.get $output-stream)) |
|
(func (export "outputStream") (result i32) (global.get $output-stream)) |
|
)
|
|
|