Ben / Nujel

; Contains the bytecode assembler, so we don't have to write opcodes directly

[defun $nop []
  "- | Do nothing"
  '[#$0]]

[defun $ret []
  "a - | Return top of value stack"
  '[#$1]]

[defun $push/int/byte [a]
  "- a | Return top of value stack"
  [when [or [> a 127] [< a -128]]
        [throw [list :invalid-bc-op "$push/int/byte can only push a signed 8-bit value" a [current-lambda]]]]
  [list #$2 [int->bytecode-op a]]]

[defun $push/int [a]
  "- a | Return top of value stack"
  [$push/int/byte a]]

[defun $add/int []
  "a b - c | Adds the two topmost values and pushes the result"
  '[#$3]]

[defun $debug/print-stack []
  "- | Print out the stack for the current closure"
  '[#$4]]

[defun $push/lval [v]
  "form - | Print out the stack for the current closure"
  [def i [val->index v]]
  [def a [int->bytecode-op [logand [>> i 16] #xFF]]]
  [def b [int->bytecode-op [logand [>> i  8] #xFF]]]
  [def c [int->bytecode-op [logand     i     #xFF]]]
  [list #$5 a b c]]

[defun $make-list [item-count]
  "items ... - | Print out the stack for the current closure"
  [list #$6 [int->bytecode-op item-count]]]

[defun $eval [a]
  "form - | Print out the stack for the current closure"
  '[#$7]]

[defun $apply [arg-count fun]
  "form - | Print out the stack for the current closure"
  [def i [val->index fun]]
  [def a [int->bytecode-op [logand [>> i 16] #xFF]]]
  [def b [int->bytecode-op [logand [>> i  8] #xFF]]]
  [def c [int->bytecode-op [logand     i     #xFF]]]
  [list #$8 [int->bytecode-op arg-count] a b c]]

[defun $jmp* [off]
  [def a [int->bytecode-op [logand [>> [int off]  8] #xFF]]]
  [def b [int->bytecode-op [logand     [int off]     #xFF]]]
  [list #$9 a b]]

[defun $jmp [label]
  [list `[quote [$jmp* [- [tree/get labels ~label] [+ 1 oi]]]]]]

[defun $jt* [off]
  [def a [int->bytecode-op [logand [>> [int off]  8] #xFF]]]
  [def b [int->bytecode-op [logand     [int off]     #xFF]]]
  [list #$A a b]]

[defun $jt [label]
  [list `[quote [$jt* [- [tree/get labels ~label] [+ 1 oi]]]]]]

[defun $jf* [off]
  [def a [int->bytecode-op [logand [>> [int off]  8] #xFF]]]
  [def b [int->bytecode-op [logand     [int off]     #xFF]]]
  [list #$F a b]]

[defun $jf [label]
  [list `[quote [$jf* [- [tree/get labels ~label] [+ 1 oi]]]]]]

[defun $dup []
  '[#$B]]

[defun $drop []
  '[#$C]]

[defun $def [v]
  "form - | Print out the stack for the current closure"
  [def i [sym->index v]]
  [def a [int->bytecode-op [logand [>> i 16] #xFF]]]
  [def b [int->bytecode-op [logand [>> i  8] #xFF]]]
  [def c [int->bytecode-op [logand     i     #xFF]]]
  [list #$D a b c]]

[defun $set [v]
  "form - | Print out the stack for the current closure"
  [def i [sym->index v]]
  [def a [int->bytecode-op [logand [>> i 16] #xFF]]]
  [def b [int->bytecode-op [logand [>> i  8] #xFF]]]
  [def c [int->bytecode-op [logand     i     #xFF]]]
  [list #$E a b c]]

[defun assemble/find-and-remove-labels [code labels]
       [def out [array/allocate [array/length code]]]
       [def oi -1]
       [def li -1]
       [for [i 0 [array/length code]]
            [if-not [symbol? [array/ref code i]]
                    [++ li]
                    [when [pair? [array/ref code i]]
                          [+= li [list/length [eval [list [car [array/ref code]]]]]]]]
            [if [symbol? [array/ref code i]]
                [tree/set! labels [array/ref code i] li]
                [array/set! out [++ oi] [array/ref code i]]]]
       [array/length! out [+ oi 1]]]

[defun assemble/relocate-jumps [code labels]
       [def out [array/allocate [array/length code]]]
       [def oi -1]
       [for [i 0 [array/length code]]
            [def form [array/ref code i]]
            [if [pair? form]
                [do [def result [eval form]]
                    [array/length! out [+ [list/length result] -1 [array/length out]]]
                    [while result
                           [array/set! out [++ oi] [car result]]
                           [cdr! result]]]
                [array/set! out [++ oi] [array/ref code i]]]]
       out]

[def assemble/verbose #f]

[defun assemble* [l]
       "Assemble all arguments into a single :bytecode-array"
       [def labels @[]]
       [and assemble/verbose [println [cat [ansi-blue "Raw:\n" [str/write l]]]]]
       [def a [apply array/new [reduce [cdr l] append [car l]]]]
       [and assemble/verbose [println [cat [ansi-red "Stage 1:\n" [str/write a]]]]]
       [def b [assemble/find-and-remove-labels a labels]]
       [and assemble/verbose [println [cat [ansi-yellow "Stage 2:\n" [str/write b]]]]]
       [def c [assemble/relocate-jumps b labels]]
       [and assemble/verbose [println [cat [ansi-green "Final result:\n" [str/write c]]]]]
       [arr->bytecode-arr c]]

[defun assemble l
       "Assemble all arguments into a single :bytecode-array"
       [assemble* l]]

[defmacro asmrun ops
  "Assemble and evaluate all bytecode arguments"
  `[bytecode-eval [assemble ~@ops]]]