Ben / Nujel

; Contains the low level Nujel -> Bytecode compiler

[defun bytecompile/literal [source]
       [case [type-of source]
             [:symbol   [$get source]]
             [:int      [$push/int source]]
             [otherwise [$push/lval source]]]]

[defun bytecompile/do/form [source env]
       [when source [cons [cons [bytecompile* [car source] env]
                                [if [last? source] #nil
                                    [cons [$drop] #nil]]]
                          [bytecompile/do/form [cdr source] env]]]]

[defun bytecompile/do [source env]
       [list [bytecompile/do/form [cdr source] env]]]

[defun bytecompile/procedure [op source env]
      [def args [map [cdr source] bytecompile*]]
       [list args
             [$apply [length args] op]]]

[defun bytecompile/def [source env]
       [list [bytecompile* [caddr source] env]
             [$def [cadr source]]]]

[defun bytecompile/set! [source env]
       [list [bytecompile* [caddr source] env]
             [$set [cadr source]]]]

[defun bytecompile/if [source env]
       [let [[sym-else [gensym]]
             [sym-after [gensym]]]
            [list [bytecompile* [cadr source] env]
                  [$jf sym-else]
                  [bytecompile* [caddr source] env]
                  [$jmp sym-after]
                  [list :label sym-else]
                  [bytecompile* [cadddr source] env]
                  [list :label sym-after]]]]


[defun bytecompile/while [source env]
       [def sym-start [gensym]]
       [def sym-end [gensym]]
       [list sym-start
             [bytecompile* [cadr source] env]
             [$jf sym-end]
             [bytecompile* [caddr source] env]
             [$jmp sym-start]
             [list :label sym-end]]]

[defun bytecompile/procedure/arg [source env]
       [if [last? source]
           [bytecompile* [car source] env]
           [cons [bytecompile/procedure/arg [cdr source] env]
                 [bytecompile* [car source] env]]]]

[defun bytecompile/procedure [op source env]
       [def args [cdr source]]
       [def arg-count [length args]]
       [if args
           [list [bytecompile/procedure/arg [cdr source]]
                 [$apply arg-count op]]
           [$apply arg-count op]]]

[defun bytecompile/and/rec [source env sym-end]
       [def c [bytecompile* [car source] env]]
       [if [last? source]
           c
           [list c
                 [$dup]
                 [$jf sym-end]
                 [$drop]
                 [bytecompile/and/rec [cdr source] env sym-end]]]]

[defun bytecompile/and [source env]
       [def sym-end [gensym]]
            [list [bytecompile/and/rec [cdr source] env sym-end]
                  sym-end]]

[defun bytecompile/or/rec [source env sym-end]
       [def c [bytecompile* [car source] env]]
       [if [last? source]
           c
           [list c
                 [$dup]
                 [$jt sym-end]
                 [$drop]
                 [bytecompile/or/rec [cdr source] env sym-end]]]]

[defun bytecompile/or [source env]
       [def sym-end [gensym]]
            [list [bytecompile/or/rec [cdr source] env sym-end]
                  sym-end]]

[defun bytecompile/λ* [source env]
       [apply $lambda [cdr source]]]

[defun bytecompile/μ* [source env]
       [apply $macro [cdr source]]]

[defun bytecompile/ω*  [source env]
       [list [$let]
             [bytecompile/do [cdr source] env]
             [$push/closure]
             [$closure/pop]]]

[defun bytecompile/let*  [source env]
       [list [$let]
             [bytecompile/do [cdr source] env]
             [$closure/pop]]]

[defun bytecompile/try  [source env]
       [def handler-sym [gensym]]
       [def end-sym [gensym]]
       [list [$try handler-sym]
             [bytecompile/do [cddr source] env]
             [$jmp end-sym]
             [:label handler-sym]
             [$apply 1 [cadr source]]
             [:label end-sym]]]

[defun bytecompile* [source env]
       "Compile the forms in source"
       [def op [if [resolves? [car source] env]
                   [resolve [car source] env]
                   [car source]]]
       [case [type-of op]
             [:special-form [case op
                    [do    [bytecompile/do    source env]]
                    [let*  [bytecompile/let*  source env]]
                    [def   [bytecompile/def   source env]]
                    [set!  [bytecompile/set!  source env]]
                    [if    [bytecompile/if    source env]]
                    [while [bytecompile/while source env]]
                    [and   [bytecompile/and   source env]]
                    [or    [bytecompile/or    source env]]
                    [λ*   [bytecompile/λ*   source env]]
                    [μ*   [bytecompile/μ*   source env]]
                    [ω*   [bytecompile/ω*   source env]]
                    [try   [bytecompile/try   source env]]
                    [quote                    source]
                    [otherwise [throw [list :unknown-special-form "The compiler does not know the current special form, please fix the compiler!" [car source]]]]]]
             [[:lambda :native-function] [bytecompile/procedure op source env]]
             [otherwise [bytecompile/literal source]]]]

[defun bytecompile [form environment]
       [list [bytecompile* form environment] [$ret]]]

[defmacro byterun [form]
          `[bytecode-eval [assemble* [bytecompile [compile ~form] [current-closure]]]]]