wasm/step7_quote.wam

   1 (module $step7_quote
   2
   3   (global $repl_env (mut i32) (i32.const 0))
   4
   5   ;; READ
   6   (func $READ (param $str i32) (result i32)
   7     ($read_str $str)
   8   )
   9
  10   ;; EVAL
  11   (func $is_pair (param $ast i32) (result i32)
  12     (LET $type ($TYPE $ast))
  13     (AND (OR (i32.eq $type (global.get $LIST_T))
  14              (i32.eq $type (global.get $VECTOR_T)))
  15          (i32.ne ($VAL0 $ast) 0))
  16   )
  17
  18   (func $QUASIQUOTE (param $ast i32) (result i32)
  19     (LET $res 0 $sym 0 $second 0 $third 0)
  20     (if (i32.eqz ($is_pair $ast)) ;; QQ_QUOTE
  21       (then
  22         (local.set $sym ($STRING (global.get $SYMBOL_T) "quote"))
  23         ;; ['quote ast]
  24         (local.set $res ($LIST2 $sym $ast))
  25         ($RELEASE $sym))
  26       (else
  27         (local.set $res ($MEM_VAL1_ptr $ast))
  28         (if (AND (i32.eq ($TYPE $res) (global.get $SYMBOL_T))
  29                  (i32.eqz ($strcmp "unquote" ($to_String $res))))
  30           (then
  31             ;; ast[1]
  32             (local.set $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))))
  33         (else (if (AND ($is_pair $res)
  34                        (i32.eq ($TYPE ($MEM_VAL1_ptr $res))
  35                                (global.get $SYMBOL_T))
  36                        (i32.eqz ($strcmp "splice-unquote"
  37                                          ($to_String ($MEM_VAL1_ptr $res)))))
  38           (then
  39             ;; ['concat, ast[0][1], quasiquote(ast[1..])]
  40             (local.set $sym ($STRING (global.get $SYMBOL_T) "concat"))
  41             (local.set $second
  42                        ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL1_ptr $ast))))
  43             (local.set $third ($QUASIQUOTE ($MEM_VAL0_ptr $ast)))
  44             (local.set $res ($LIST3 $sym $second $third))
  45             ;; release inner quasiquoted since outer list take ownership
  46             ($RELEASE $third)
  47             ($RELEASE $sym))
  48           (else
  49             ;; ['cons, quasiquote(ast[0]), quasiquote(ast[1..])]
  50             (local.set $sym ($STRING (global.get $SYMBOL_T) "cons"))
  51             (local.set $second ($QUASIQUOTE ($MEM_VAL1_ptr $ast)))
  52             (local.set $third ($QUASIQUOTE ($MEM_VAL0_ptr $ast)))
  53             (local.set $res ($LIST3 $sym $second $third))
  54             ;; release inner quasiquoted since outer list takes ownership
  55             ($RELEASE $third)
  56             ($RELEASE $second)
  57             ($RELEASE $sym)))))))
  58     $res
  59   )
  60
  61   (func $EVAL_AST (param $ast i32 $env i32 $skiplast i32) (result i32)
  62     (LET $res 0 $val2 0 $val3 0 $type 0 $found 0
  63          $ret 0 $empty 0 $current 0)
  64
  65     (if (global.get $error_type) (return 0))
  66     (local.set $type ($TYPE $ast))
  67
  68     ;;($PR_VALUE ">>> EVAL_AST ast: '%s'\n" $ast)
  69
  70     ;;; switch(type)
  71     (block $done
  72       (block $default (block (block
  73       (br_table 2 2 2 2 2 0 1 1 1 2 2 2 2 2 2 2 $type))
  74       ;; symbol
  75       ;; found/res returned as hi 32/lo 32 of i64
  76       (local.set $res ($ENV_GET $env $ast))
  77       (br $done))
  78       ;; list, vector, hashmap
  79       ;; MAP_LOOP_START
  80       (local.set $res ($MAP_LOOP_START $type))
  81       ;; push MAP_LOOP stack
  82       ;;; empty = current = ret = res
  83       (local.set $ret $res)
  84       (local.set $current $res)
  85       (local.set $empty $res)
  86
  87       (block $done
  88         (loop $loop
  89           ;; check if we are done evaluating the source sequence
  90           (br_if $done (i32.eq ($VAL0 $ast) 0))
  91
  92           (if $skiplast
  93             (br_if $done (i32.eqz ($VAL0 ($MEM_VAL0_ptr $ast)))))
  94
  95           (if (i32.eq $type (global.get $HASHMAP_T))
  96             (then
  97               (local.set $res ($EVAL ($MEM_VAL2_ptr $ast) $env)))
  98             (else
  99               (local.set $res ($EVAL ($MEM_VAL1_ptr $ast) $env))))
 100           (local.set $val2 $res)
 101
 102           ;; if error, release the unattached element
 103           (if (global.get $error_type)
 104             (then
 105               ($RELEASE $res)
 106               (local.set $res 0)
 107               (br $done)))
 108
 109           ;; for hash-maps, copy the key (inc ref since we are going
 110           ;; to release it below)
 111           (if (i32.eq $type (global.get $HASHMAP_T))
 112             (then
 113               (local.set $val3 $val2)
 114               (local.set $val2 ($MEM_VAL1_ptr $ast))
 115               (drop ($INC_REF $val2))))
 116
 117           ;; MAP_LOOP_UPDATE
 118           (local.set $res ($MAP_LOOP_UPDATE $type $empty $current $val2 $val3))
 119           (if (i32.le_u $current (global.get $EMPTY_HASHMAP))
 120             ;; if first element, set return to new element
 121             (local.set $ret $res))
 122           ;; update current to point to new element
 123           (local.set $current $res)
 124
 125           (local.set $ast ($MEM_VAL0_ptr $ast))
 126
 127           (br $loop)
 128         )
 129       )
 130       ;; MAP_LOOP_DONE
 131       (local.set $res $ret)
 132       ;; EVAL_AST_RETURN: nothing to do
 133       (br $done))
 134       ;; default
 135       (local.set $res ($INC_REF $ast))
 136     )
 137
 138     $res
 139   )
 140
 141   (func $MAL_GET_A1 (param $ast i32) (result i32)
 142     ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast)))
 143   (func $MAL_GET_A2 (param $ast i32) (result i32)
 144     ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast))))
 145   (func $MAL_GET_A3 (param $ast i32) (result i32)
 146     ($MEM_VAL1_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr ($MEM_VAL0_ptr $ast)))))
 147
 148   (func $EVAL (param $orig_ast i32 $orig_env i32) (result i32)
 149     (LET $ast $orig_ast
 150          $env $orig_env
 151          $prev_ast 0 $prev_env 0 $res 0 $el 0
 152          $ftype 0 $f_args 0 $f 0 $args 0
 153          $a0 0 $a0sym 0 $a1 0 $a2 0)
 154
 155     (block $EVAL_return
 156     (loop $TCO_loop
 157
 158     (local.set $f_args 0)
 159     (local.set $f 0)
 160     (local.set $args 0)
 161
 162     (if (global.get $error_type)
 163       (then
 164         (local.set $res 0)
 165         (br $EVAL_return)))
 166
 167     ;;($PR_VALUE ">>> EVAL ast: '%s'\n" $ast)
 168
 169     (if (i32.ne ($TYPE $ast) (global.get $LIST_T))
 170       (then
 171         (local.set $res ($EVAL_AST $ast $env 0))
 172         (br $EVAL_return)))
 173
 174     ;; APPLY_LIST
 175     (if ($EMPTY_Q $ast)
 176       (then
 177         (local.set $res ($INC_REF $ast))
 178         (br $EVAL_return)))
 179
 180     (local.set $a0 ($MEM_VAL1_ptr $ast))
 181     (local.set $a0sym "")
 182     (if (i32.eq ($TYPE $a0) (global.get $SYMBOL_T))
 183       (local.set $a0sym ($to_String $a0)))
 184
 185     (if (i32.eqz ($strcmp "def!" $a0sym))
 186       (then
 187         (local.set $a1 ($MAL_GET_A1 $ast))
 188         (local.set $a2 ($MAL_GET_A2 $ast))
 189         (local.set $res ($EVAL $a2 $env))
 190         (br_if $EVAL_return (global.get $error_type))
 191
 192         ;; set a1 in env to a2
 193         (local.set $res ($ENV_SET $env $a1 $res))
 194         (br $EVAL_return))
 195     (else (if (i32.eqz ($strcmp "let*" $a0sym))
 196       (then
 197         (local.set $a1 ($MAL_GET_A1 $ast))
 198         (local.set $a2 ($MAL_GET_A2 $ast))
 199
 200         ;; create new environment with outer as current environment
 201         (local.set $prev_env $env) ;; save env for later release
 202         (local.set $env ($ENV_NEW $env))
 203
 204         (block $done
 205           (loop $loop
 206             (br_if $done (i32.eqz ($VAL0 $a1)))
 207             ;; eval current A1 odd element
 208             (local.set $res ($EVAL ($MEM_VAL1_ptr ($MEM_VAL0_ptr $a1)) $env))
 209
 210             (br_if $done (global.get $error_type))
 211
 212             ;; set key/value in the let environment
 213             (local.set $res ($ENV_SET $env ($MEM_VAL1_ptr $a1) $res))
 214             ;; release our use, ENV_SET took ownership
 215             ($RELEASE $res)
 216
 217             ;; skip to the next pair of a1 elements
 218             (local.set $a1 ($MEM_VAL0_ptr ($MEM_VAL0_ptr $a1)))
 219             (br $loop)
 220           )
 221         )
 222
 223         ;; release previous environment if not the current EVAL env
 224         (if (i32.ne $prev_env $orig_env)
 225           (then
 226             ($RELEASE $prev_env)
 227             (local.set $prev_env 0)))
 228
 229         (local.set $ast $a2)
 230         (br $TCO_loop))
 231     (else (if (i32.eqz ($strcmp "do" $a0sym))
 232       (then
 233         ;; EVAL the rest through second to last
 234         (local.set $el ($EVAL_AST ($MEM_VAL0_ptr $ast) $env 1))
 235         (local.set $ast ($LAST $ast))
 236         ($RELEASE $ast) ;; we already own it via ast
 237         ($RELEASE $el)
 238         (br $TCO_loop))
 239     (else (if (i32.eqz ($strcmp "quote" $a0sym))
 240       (then
 241         (local.set $res ($INC_REF ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))))
 242         (br $EVAL_return))
 243     (else (if (i32.eqz ($strcmp "quasiquote" $a0sym))
 244       (then
 245         (local.set $ast ($QUASIQUOTE ($MEM_VAL1_ptr ($MEM_VAL0_ptr $ast))))
 246
 247         ;; if we have already been here via TCO, release previous ast
 248         (if $prev_ast ($RELEASE $prev_ast))
 249         (local.set $prev_ast $ast)
 250         (br $TCO_loop))
 251     (else (if (i32.eqz ($strcmp "if" $a0sym))
 252       (then
 253         (local.set $a1 ($MAL_GET_A1 $ast))
 254         (local.set $res ($EVAL $a1 $env))
 255
 256         (if (global.get $error_type)
 257           (then (nop))
 258         (else (if (OR (i32.eq $res (global.get $NIL))
 259                       (i32.eq $res (global.get $FALSE)))
 260           (then
 261             ($RELEASE $res)
 262             ;; if no false case (A3), return nil
 263             (if (i32.lt_u ($COUNT $ast) 4)
 264               (then
 265                 (local.set $res ($INC_REF (global.get $NIL)))
 266                 (br $EVAL_return))
 267               (else
 268                 (local.set $ast ($MAL_GET_A3 $ast)))))
 269         (else
 270           ($RELEASE $res)
 271           (local.set $ast ($MAL_GET_A2 $ast))))))
 272         (br $TCO_loop))
 273     (else (if (i32.eqz ($strcmp "fn*" $a0sym))
 274       (then
 275         (local.set $a1 ($MAL_GET_A1 $ast))
 276         (local.set $a2 ($MAL_GET_A2 $ast))
 277         (local.set $res ($MALFUNC $a2 $a1 $env))
 278         (br $EVAL_return))
 279     (else
 280       ;; EVAL_INVOKE
 281       (local.set $res ($EVAL_AST $ast $env 0))
 282       (local.set $f_args $res)
 283
 284       ;; if error, return f/args for release by caller
 285       (if (global.get $error_type)
 286        (then
 287          (local.set $res $f_args)
 288          (br $EVAL_return)))
 289
 290       (local.set $args ($MEM_VAL0_ptr $f_args)) ;; rest
 291       (local.set $f ($MEM_VAL1_ptr $f_args)) ;; value
 292
 293       (local.set $ftype ($TYPE $f))
 294       (if (i32.eq $ftype (global.get $FUNCTION_T))
 295         (then
 296           (if (i32.eq ($VAL0 $f) 0) ;; eval
 297             (then
 298               (local.set $res ($EVAL ($MEM_VAL1_ptr $args)
 299                                      (global.get $repl_env))))
 300             (else
 301               (local.set $res (call_indirect (type $fnT) $args ($VAL0 $f)))))
 302           ;; release f/args
 303           ($RELEASE $f_args)
 304           (br $EVAL_return))
 305       (else (if (i32.eq $ftype (global.get $MALFUNC_T))
 306         (then
 307           ;; save the current environment for release
 308           (local.set $prev_env $env)
 309           ;; create new environment using env and params stored in function
 310           (local.set $env ($ENV_NEW_BINDS ($MEM_VAL2_ptr $f)
 311                                           ($MEM_VAL1_ptr $f) $args))
 312
 313           ;; release previous environment if not the current EVAL env
 314           ;; because our new env refers to it and we no longer need to
 315           ;; track it (since we are TCO recurring)
 316           (if (i32.ne $prev_env $orig_env)
 317             (then
 318               ($RELEASE $prev_env)
 319               (local.set $prev_env 0)))
 320
 321           ;; claim the AST before releasing the list containing it
 322           (local.set $ast ($MEM_VAL0_ptr $f))
 323           (drop ($INC_REF $ast))
 324
 325           ;; if we have already been here via TCO, release previous
 326           ;; ast
 327           ;; PEND_A_LV
 328           (if $prev_ast ($RELEASE $prev_ast))
 329           (local.set $prev_ast $ast)
 330
 331           ;; release f/args
 332           ($RELEASE $f_args)
 333
 334           (br $TCO_loop))
 335       (else
 336         ($THROW_STR_1 "apply of non-function type: %d\n" $ftype)
 337         (local.set $res 0)
 338         ($RELEASE $f_args)
 339         (br $EVAL_return)))))))))))))))))))
 340
 341     ) ;; end of TCO_loop
 342     ) ;; end of EVAL_return
 343
 344     ;; EVAL_RETURN
 345     (if (i32.ne $env $orig_env) ($RELEASE $env))
 346     (if $prev_ast ($RELEASE $prev_ast))
 347
 348     $res
 349   )
 350
 351   ;; PRINT
 352   (func $PRINT (param $ast i32) (result i32)
 353     ($pr_str $ast 1)
 354   )
 355
 356   ;; REPL
 357   (func $RE (param $line i32 $env i32) (result i32)
 358     (LET $mv1 0 $res 0)
 359     (block $done
 360       (local.set $mv1 ($READ $line))
 361       (br_if $done (global.get $error_type))
 362
 363       (local.set $res ($EVAL $mv1 $env))
 364     )
 365
 366     ;; release memory from MAL_READ
 367     ($RELEASE $mv1)
 368     $res
 369   )
 370
 371   (func $REP (param $line i32 $env i32) (result i32)
 372     (LET $mv2 0 $ms 0)
 373     (block $done
 374       (local.set $mv2 ($RE $line $env))
 375       (br_if $done (global.get $error_type))
 376
 377 ;;      ($PR_MEMORY -1 -1)
 378       (local.set $ms ($PRINT $mv2))
 379     )
 380
 381     ;; release memory from RE
 382     ($RELEASE $mv2)
 383     $ms
 384   )
 385
 386   (func $main (param $argc i32 $argv i32) (result i32)
 387     (LET $line (STATIC_ARRAY 201)
 388          $res 0 $repl_env 0 $ms 0
 389          ;; argument processing
 390          $i 0 $ret 0 $empty 0 $current 0 $val2 0)
 391
 392     ;; DEBUG
 393 ;;    ($printf_1 "argc: 0x%x\n" $argc)
 394 ;;    ($printf_1 "memoryBase: 0x%x\n" (global.get $memoryBase))
 395 ;;    ($printf_1 "heap_start: 0x%x\n" (global.get $heap_start))
 396 ;;    ($printf_1 "heap_end: 0x%x\n" (global.get $heap_end))
 397 ;;    ($printf_1 "mem: 0x%x\n" (global.get $mem))
 398 ;;    ($printf_1 "string_mem: %d\n" (global.get $string_mem))
 399
 400     (global.set $repl_env ($ENV_NEW (global.get $NIL)))
 401     (local.set $repl_env (global.get $repl_env))
 402
 403     ;; core.EXT: defined in wasm
 404     ($add_core_ns $repl_env)
 405     (drop ($ENV_SET_S $repl_env "eval" ($FUNCTION 0)))
 406
 407     ($checkpoint_user_memory)
 408
 409     ;; core.mal: defined using the language itself
 410     ($RELEASE ($RE "(def! not (fn* (a) (if a false true)))" $repl_env))
 411     ($RELEASE ($RE "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" $repl_env))
 412
 413
 414     ;; Command line arguments
 415     (local.set $res ($MAP_LOOP_START (global.get $LIST_T)))
 416     ;; push MAP_LOP stack
 417     ;; empty = current = ret = res
 418     (local.set $ret $res)
 419     (local.set $current $res)
 420     (local.set $empty $res)
 421
 422     (local.set $i 2)
 423     (block $done
 424       (loop $loop
 425         (br_if $done (i32.ge_u $i $argc))
 426
 427         (local.set $val2 ($STRING (global.get $STRING_T)
 428                                   (i32.load (i32.add $argv (i32.mul $i 4)))))
 429
 430         ;; MAP_LOOP_UPDATE
 431         (local.set $res ($MAP_LOOP_UPDATE
 432                           (global.get $LIST_T) $empty $current $val2 0))
 433         (if (i32.le_u $current (global.get $EMPTY_HASHMAP))
 434           ;; if first element, set return to new element
 435           (local.set $ret $res))
 436         ;; update current to point to new element
 437         (local.set $current $res)
 438
 439         (local.set $i (i32.add $i 1))
 440         (br $loop)
 441       )
 442     )
 443     (drop ($ENV_SET_S $repl_env "*ARGV*" $ret))
 444
 445
 446     ;;($PR_MEMORY -1 -1)
 447
 448     (if (i32.gt_u $argc 1)
 449       (then
 450         (drop ($ENV_SET_S $repl_env
 451                           "*FILE*" ($STRING (global.get $STRING_T)
 452                                             (i32.load (i32.add $argv 4)))))
 453         ($RELEASE ($RE "(load-file *FILE*)" $repl_env))
 454         (if (global.get $error_type)
 455           (then
 456             ($printf_1 "Error: %s\n" (global.get $error_str))
 457             (return 1))
 458           (else
 459             (return 0)))))
 460
 461     ;; Start REPL
 462     (block $repl_done
 463       (loop $repl_loop
 464         (br_if $repl_done (i32.eqz ($readline "user> " $line)))
 465         (br_if $repl_loop (i32.eq (i32.load8_u $line) 0))
 466         (local.set $res ($REP $line $repl_env))
 467         (if (global.get $error_type)
 468           (then
 469             (if (i32.eq 2 (global.get $error_type))
 470               (then
 471                 (local.set $ms ($pr_str (global.get $error_val) 1))
 472                 ($printf_1 "Error: %s\n" ($to_String $ms))
 473                 ($RELEASE $ms)
 474                 ($RELEASE (global.get $error_val)))
 475               (else
 476                 ($printf_1 "Error: %s\n" (global.get $error_str))))
 477             (global.set $error_type 0))
 478           (else
 479             ($printf_1 "%s\n" ($to_String $res))))
 480         ($RELEASE $res)
 481         ;;($PR_MEMORY_SUMMARY_SMALL)
 482         (br $repl_loop)
 483       )
 484     )
 485
 486     ($print "\n")
 487     ;;($PR_MEMORY -1 -1)
 488     0
 489   )
 490
 491 )
 492