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