Multiple implementations (JS, Wasm, C) of a Lisp.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

2985 lines
117 KiB

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