Ben / Nujel

; Contains the disassembler, which is probably not that important to most
; people, but invaluable when working on compiler internals

[defun disassemble/length [op]
       "Return the length in bytes of a bytecode operation and all its arguments"
       [case op
             [[#$2 #$6] 2]
             [[#$9 #$A #$B #$17 #$18] 3]
             [[#$5 #$E #$F #$10] 4]
             [[#$8] 5]
             [[#$11 #$12] 13]
             [otherwise 1]]]

[defun bytecode/nil-catcher [error] [if [== [car error] :argument-mismatch] #nil [throw error]]]

[defun bytecode-op->val [a b c]
       "Turn three bytecode ops representing an encoded value into an actual value"
       [index->val [logior [<< [bytecode-op->int a] 16]
                           [<< [bytecode-op->int b]  8]
                           [bytecode-op->int c]    ]]]

[defun bytecode-arr->val [a i]
       "Read a bytecode encoded value in A at I and return it"
       [try bytecode/nil-catcher [bytecode-op->val [a i] [a [+ 1 i]] [a [+ 2 i]]]]]

[defun bytecode-op->sym [a b c]
       "Turn three bytecode ops representing an encoded symbol into an actual symbol"
       [index->sym [logior [<< [bytecode-op->int a] 16]
                           [<< [bytecode-op->int b]  8]
                           [bytecode-op->int c]    ]]]

[defun bytecode-arr->sym [a i]
       "Read a bytecode encoded symbol in A at I and return it"
       [try bytecode/nil-catcher [bytecode-op->sym [a i] [a [+ 1 i]] [a [+ 2 i]]]]]

[defun bytecode-op->offset [a b]
       "Turn two bytecode ops encoding an offset into the integer representation"
       [def t [logior [<< [bytecode-op->int a] 8]
                      [bytecode-op->int b]   ]   ]
       [if-not [> t 32768] t
               [- [- 65536 t]]]]

[defun bytecode-arr->offset [a i]
       "Read a bytecode encoded offset in A at I and return it as a signed integer"
       [bytecode-op->offset [a i] [a [+ 1 i]]]]

[defun disassemble/op [a i]
       "Disassemble a single bytecode op in A at I and return it as an s-expression, that could be applied to eval"
       [case [a i]
             [#$0  '[$nop]]
             [#$1  '[$ret]]
             [#$2  `[$push/int/byte ~[bytecode-op->int [a [+ i 1]]]]]
             [#$3  '[$add/int]]
             [#$4  '[$debug/print-stack]]
             [#$5  `[$push/lval ~[bytecode-arr->val a [+ i 1]]]]
             [#$6  `[$make-list ~[bytecode-op->int [a [+ i 1]]]]]
             [#$7  '[$eval]]
             [#$8  `[$apply ~[bytecode-op->int [a [+ i 1]]]
                            ~[bytecode-arr->val a [+ i 2]]]]
             [#$9  `[$jmp*  ~[bytecode-arr->offset a [+ i 1]]]]
             [#$A  `[$jt*   ~[bytecode-arr->offset a [+ i 1]]]]
             [#$B  `[$jf*   ~[bytecode-arr->offset a [+ i 1]]]]
             [#$C  '[$dup]]
             [#$D  '[$drop]]
             [#$E  `[$def ~[bytecode-arr->sym a [+ i 1]]]]
             [#$F  `[$set ~[bytecode-arr->sym a [+ i 1]]]]
             [#$10 `[$get ~[bytecode-arr->sym a [+ i 1]]]]
             [#$11 `[$lambda ~[bytecode-arr->val a [+ i 1]]
                             ~[bytecode-arr->val a [+ i 4]]
                             ~[bytecode-arr->val a [+ i 7]]
                             ~[bytecode-arr->val a [+ i 10]]]]
             [#$12 `[$macro ~[bytecode-arr->val a [+ i 1]]
                            ~[bytecode-arr->val a [+ i 4]]
                            ~[bytecode-arr->val a [+ i 7]]
                            ~[bytecode-arr->val a [+ i 10]]]]
             [#$13 '[$closure/push]]
             [#$14 '[$closure/enter]]
             [#$15 '[$let]]
             [#$16 '[$closure/pop]]
             [#$17 `[$call ~[bytecode-arr->offset a [+ i 1]]]]
             [#$18 `[$try ~[bytecode-arr->offset a [+ i 1]]]]
             [#$19 '[$throw]]
             [#$1A '[$apply/dynamic ~[bytecode-op->int [a [+ i 1]]]]]
             [otherwise :unknown-op]]]

[defun disassemble/array [a i]
       "Disassemble all bytecode operations in the plain array A starting at I, turning it into an assembler S-Expression and return it as a dotted pair, with the car containing the offset and the cdr containing the S-Expression"
       [def ret #nil]
       [while [< i [array/length a]]
              [set! ret [cons [cons i [disassemble/op a i]] ret]]
              [set! i [+ i [disassemble/length [a i]]]]]
       [nreverse ret]]

[defun disassemble [code]
       "Disassemble the bytecode array CODE, turning it into a list of dotted pairs, with the car containing the offset and the cdr containing assembler S-Expressions,"
       [disassemble/array [bytecode-arr->arr code] 0]]

[defun disassemble/raw [bc]
       "Disassemble the bytecode array CODE, turning it into a list of dotted pairs, with the car containing the offset and the cdr containing assembler S-Expressions,"
       [for-each [disassemble bc] [\ [a]
                                   [println [cat [ansi-blue [string/pad-start [string [car a]] 6]]
                                                 " - "
                                                 [cdr a]]]]]]

[defun disassemble/test [asm]
       "Verbose way of testing the disassembler"
       [println [ansi-blue "--------- Assembly -----------"]]
       [def cur-line 0]
       [for-each asm [\ [a] [println [cat [ansi-yellow [string/pad-start [++ cur-line] 6]]
                                          " - "
                                          a]]]]
       [println [ansi-yellow "--------- Raw Bytecode -----------"]]
       [def bc [apply assemble asm]]
       [println [str/write bc]]
       [println [ansi-green "--------- Now for the disassembly -----------"]]
       [for-each [disassemble bc] [\ [a]
                                   [println [cat [ansi-blue [string/pad-start [string [car a]] 6]]
                                                 " - "
                                                 [cdr a]]]]]
       [println [ansi-red "--------- Fin -----------\n"]]
       [try display/error [println [str/write [bytecode-eval bc]]]]]