Ben / Nujel

[do [def val->bytecode-op [λ* val->bytecode-op [v] "" [do [def i [val->index v]] [list [int->bytecode-op [logand [>> i 16] 255]] [int->bytecode-op [logand [>> i 8] 255]] [int->bytecode-op [logand i 255]]]]]] [def sym->bytecode-op [λ* sym->bytecode-op [v] "" [do [def i [sym->index v]] [list [int->bytecode-op [logand [>> i 16] 255]] [int->bytecode-op [logand [>> i 8] 255]] [int->bytecode-op [logand i 255]]]]]] [def int-fit-in-byte? [λ* int-fit-in-byte? [a] "" [and [<= a 127] [>= a -128]]]] [def $nop [λ* $nop [] "- | Do nothing" '[#$0]]] [def $ret [λ* $ret [] "a - | Return top of value stack" '[#$1]]] [def $push/int/byte [λ* $push/int/byte [a] "- a | Return top of value stack" [do [if [int-fit-in-byte? a] #nil [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]]]]] [def $push/int [λ* $push/int [a] "- a | Return top of value stack" [if [int-fit-in-byte? a] [$push/int/byte a] [$push/lval a]]]] [def $add/int [λ* $add/int [] "a b - c | Adds the two topmost values and pushes the result" '[#$3]]] [def $debug/print-stack [λ* $debug/print-stack [] "- | Print out the stack for the current closure" '[#$4]]] [def $push/lval [λ* $push/lval [v] "form - | Print out the stack for the current closure" [list #$5 [val->bytecode-op v]]]] [def $make-list [λ* $make-list [item-count] "items ... - | Print out the stack for the current closure" [list #$6 [int->bytecode-op item-count]]]] [def $eval [λ* $eval [a] "form - | Print out the stack for the current closure" '[#$7]]] [def $apply [λ* $apply [arg-count fun] "form - | Print out the stack for the current closure" [list #$8 [int->bytecode-op arg-count] [val->bytecode-op fun]]]] [def $call [λ* $call [target] " - | Call a bytecode subroutine" [list #$17 [list :relocate target 8 0 [int->bytecode-op 0]] [list :relocate target 0 1 [int->bytecode-op 0]]]]] [def $try [λ* $try [target] " - | Try something, jumping to target if an exception occurs" [list #$18 [list :relocate target 8 0 [int->bytecode-op 0]] [list :relocate target 0 1 [int->bytecode-op 0]]]]] [def $throw [λ* $throw [] " - | Return to the closest exception handler" [list #$19]]] [def $jmp [λ* $jmp [target] "" [list #$9 [list :relocate target 8 0 [int->bytecode-op 0]] [list :relocate target 0 1 [int->bytecode-op 0]]]]] [def $jt [λ* $jt [target] "" [list #$A [list :relocate target 8 0 [int->bytecode-op 0]] [list :relocate target 0 1 [int->bytecode-op 0]]]]] [def $jf [λ* $jf [target] "" [list #$B [list :relocate target 8 0 [int->bytecode-op 0]] [list :relocate target 0 1 [int->bytecode-op 0]]]]] [def $dup [λ* $dup [] "" '[#$C]]] [def $drop [λ* $drop [] "" '[#$D]]] [def $def [λ* $def [v] "" [list #$E [sym->bytecode-op v]]]] [def $set [λ* $set [v] "" [list #$F [sym->bytecode-op v]]]] [def $get [λ* $get [v] "" [list #$10 [sym->bytecode-op v]]]] [def $lambda [λ* $lambda [name args docs body] "" [list #$11 [val->bytecode-op name] [val->bytecode-op args] [val->bytecode-op docs] [val->bytecode-op body]]]] [def $macro [λ* $macro [name args docs body] "" [list #$12 [val->bytecode-op name] [val->bytecode-op args] [val->bytecode-op docs] [val->bytecode-op body]]]] [def $closure/push [λ* $closure/push [] "" '[#$13]]] [def $closure/enter [λ* $closure/enter [] "" '[#$14]]] [def $let [λ* $let [] "" '[#$15]]] [def $closure/pop [λ* $closure/pop [] "" '[#$16]]] [def assemble/build-sym-map [λ* assemble/build-sym-map [code sym-map pos] "" [do [while code [do [let* [do [def ΓεnΣym-36 [type-of [car code]]] [if [== ΓεnΣym-36 :bytecode-op] [tree/set! sym-map :last-op [set! pos [+ 1 pos]]] [if [== ΓεnΣym-36 :symbol] [and [== [car code] :label] [tree/set! sym-map [cadr code] pos]] [if [== ΓεnΣym-36 :pair] [set! pos [assemble/build-sym-map [car code] sym-map pos]] #nil]]]]] [set! code [cdr code]]]] pos]]] [def assemble/relocate-op [λ* assemble/relocate-op [code sym-map pos out] "" [do [def target [sym-map [cadr code]]] [def off [- [+ target [cadddr code]] pos]] [array/set! out [set! pos [+ 1 pos]] [int->bytecode-op [logand [>> off [caddr code]] 255]]] pos]]] [def assemble/emit-relocated-ops [λ* assemble/emit-relocated-ops [code sym-map pos out] "" [do [if [== [car code] :relocate] [set! pos [assemble/relocate-op code sym-map pos out]] [while code [do [let* [do [def ΓεnΣym-37 [type-of [car code]]] [if [== ΓεnΣym-37 :bytecode-op] [array/set! out [set! pos [+ 1 pos]] [car code]] [if [== ΓεnΣym-37 :pair] [set! pos [assemble/emit-relocated-ops [car code] sym-map pos out]] #nil]]]] [set! code [cdr code]]]]] pos]]] [def assemble/verbose #f] [def assemble* [λ* assemble* [code] "Assemble all arguments into a single :bytecode-array" [do [def sym-map [tree/new #nil]] [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]]]] [def assemble [λ* assemble l "Assemble all arguments into a single :bytecode-array" [assemble* l]]] [def asmrun [μ* asmrun ops "Assemble and evaluate all bytecode arguments" [cons 'bytecode-eval [cons [cons 'assemble [append ops #nil]] #nil]]]]]