Ben / Nujel

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

[defun val->bytecode-op [v]
       [def i [val->index v]]
       [list [int->bytecode-op [logand [>> i 16] #xFF]]
             [int->bytecode-op [logand [>> i  8] #xFF]]
             [int->bytecode-op [logand     i     #xFF]]]]

[defun sym->bytecode-op [v]
       [def i [sym->index v]]
       [list [int->bytecode-op [logand [>> i 16] #xFF]]
             [int->bytecode-op [logand [>> i  8] #xFF]]
             [int->bytecode-op [logand     i     #xFF]]]]

[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"
       [list #$5 [val->bytecode-op v]]]

[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"
       [list #$8 [int->bytecode-op arg-count]
                 [val->bytecode-op fun]]]

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

[defun $jmp [target]
       [list #$9 [list :relocate target 8  0 [int->bytecode-op 0]]
                 [list :relocate target 0 -1 [int->bytecode-op 0]]]]

[defun $jt [target]
       [list #$A [list :relocate target 8  0 [int->bytecode-op 0]]
                 [list :relocate target 0 -1 [int->bytecode-op 0]]]]

[defun $jf [target]
       [list #$F [list :relocate target 8  0 [int->bytecode-op 0]]
                 [list :relocate target 0 -1 [int->bytecode-op 0]]]]

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

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

[defun $def [v]
       "form - | Print out the stack for the current closure"
       [list #$D [sym->bytecode-op v]]]

[defun $set [v]
       "form - | Print out the stack for the current closure"
       [list #$E [sym->bytecode-op v]]]

[defun $lambda [name args docs body]
       [list #$10
             [val->bytecode-op name]
             [val->bytecode-op args]
             [val->bytecode-op docs]
             [val->bytecode-op body]]]

[defun $macro [name args docs body]
       [list #$11
             [val->bytecode-op name]
             [val->bytecode-op args]
             [val->bytecode-op docs]
             [val->bytecode-op body]]]

[defun assemble/build-sym-map [code sym-map pos]
       [while code
              [case [type-of [car code]]
                    [:bytecode-op [tree/set! sym-map :last-op [++ pos]]]
                    [:symbol      [tree/set! sym-map [car code] pos]]
                    [:pair        [set! pos [assemble/build-sym-map [car code] sym-map pos]]]]
              [cdr! code]]
       pos]

[defun assemble/relocate-op [code sym-map pos out]
       [def off [- [+ [sym-map [cadr code]] [cadddr code]] pos]]
       [array/set! out [++ pos] [int->bytecode-op [logand [>> off [caddr code]] #xFF]]]
       pos]

[defun assemble/emit-relocated-ops [code sym-map pos out]
       [if [== [car code] :relocate]
           [set! pos [assemble/relocate-op code sym-map pos out]]
           [while code
                  [case [type-of [car code]]
                        [:bytecode-op [array/set! out [++ pos] [car code]]]
                        [:pair        [set! pos [assemble/emit-relocated-ops [car code] sym-map pos out]]]]
                  [cdr! code]]]
       pos]

[def assemble/verbose #f]
[defun assemble* [code]
       "Assemble all arguments into a single :bytecode-array"
       [def sym-map @[]]

       [and assemble/verbose [println [cat [ansi-blue "Input:\n" [str/write code]]]]]
       [assemble/build-sym-map code sym-map 0]
       [and assemble/verbose [println [cat [ansi-yellow "Symbol Map:\n" [str/write sym-map]]]]]
       [def out [array/allocate [sym-map :last-op]]]
       [assemble/emit-relocated-ops code sym-map -1 out]
       [and assemble/verbose [println [cat [ansi-green "Output:\n" [str/write out]]]]]

       [arr->bytecode-arr out]]

[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]]]