Ben / Nujel

; Contains the low levelNujel -> Bytecode compiler

[defun bytecompile/int [source]
       [$push/int source]]

[defun bytecompile/literal [source]
       [case [type-of source]
             [:int      [bytecompile/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]
                  sym-else
                  [bytecompile* [cadddr source] env]
                  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]
             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]
       "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]]
                    [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]]

                    [let*   [bytecompile/let*   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 ~form [current-closure]]]]]