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
2985 lines
117 KiB
3 years ago
|
;; 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))
|
||
|
)
|