application/octet-stream
•
8.18 KB
•
208 lines
; Contains the low level Nujel -> Bytecode compiler
[def bytecompile/gen-label/counter 0]
[defn bytecompile/gen-label [prefix]
[++ bytecompile/gen-label/counter]
[str->sym [cat prefix "label-" bytecompile/gen-label/counter]]]
[defn bytecompile/literal [source]
[case [type-of source]
[[:symbol :keyword] [if [keyword? source]
[$push/lval source]
[$get source]]]
[:int [$push/int source]]
[:nil [$push/nil]]
[otherwise [$push/lval source]]]]
[defn bytecompile/quote [source]
[case [type-of source]
[:int [$push/int source]]
[:symbol [$push/symbol source]]
[otherwise [$push/lval source]]]]
[defn 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]]]]
[defn bytecompile/do [source env]
[list [bytecompile/do/form [cdr source] env]]]
[defn bytecompile/procedure [op source env]
[def args [map [cdr source] bytecompile*]]
[list args
[$apply [length args] op]]]
[defn bytecompile/def [source env]
[when [or [not [symbol? [cadr source]]]
[not [cddr source]]]
[throw [list :type-error
"[def] needs a symbol name and a value as arguments" #nil env]]]
[list [bytecompile* [caddr source] env]
[$def [cadr source]]]]
[defn bytecompile/set! [source env]
[when [or [not [symbol? [cadr source]]]
[not [cddr source]]]
[throw [list :type-error
"[set!] needs a symbol name and a value as arguments" #nil env]]]
[list [bytecompile* [caddr source] env]
[$set [cadr source]]]]
[defn bytecompile/if [source env]
[let [[sym-else [bytecompile/gen-label]]
[sym-after [bytecompile/gen-label]]]
[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]]]]
[defn bytecompile/while [source env]
[def sym-start [bytecompile/gen-label]]
[def sym-end [bytecompile/gen-label]]
[list [$push/int 0]
[$roots/save]
[list :label sym-start]
[$roots/restore]
[bytecompile* [cadr source] env]
[$jf sym-end]
[$drop]
[bytecompile/do/form [cddr source] env]
[$jmp sym-start]
[list :label sym-end]]]
[defn bytecompile/procedure/arg [source env]
[if [last? source]
[bytecompile* [car source] env]
[cons [bytecompile* [car source] env]
[bytecompile/procedure/arg [cdr source] env]]]]
[defn bytecompile/procedure [op args env]
[def arg-count [length args]]
[if args
[list [bytecompile/procedure/arg args]
[$apply arg-count op]]
[$apply 0 op]]]
[defn bytecompile/procedure/dynamic [op args env]
[def arg-count [length args]]
[list [bytecompile* op env]
[when args [bytecompile/procedure/arg args]]
[$apply/dynamic arg-count]]]
[defn bytecompile/and/rec [source env label-end]
[list [bytecompile* [car source] env]
[when [cdr source]
[list [$dup]
[$jf label-end]
[$drop]
[bytecompile/and/rec [cdr source] env label-end]]]]]
[defn bytecompile/and [source env]
[def label-end [bytecompile/gen-label]]
[list [bytecompile/and/rec [cdr source] env label-end]
[list :label label-end]]]
[defn bytecompile/or/rec [source env label-end]
[when source[list [bytecompile* [car source] env]
[$dup]
[$jt label-end]
[$drop]
[bytecompile/or/rec [cdr source] env label-end]]]]
[defn bytecompile/or [source env]
[def label-end [bytecompile/gen-label]]
[list [bytecompile/or/rec [cdr source] env label-end]
[$push/lval #f]
[list :label label-end]]]
[defn bytecompile/string [source env]
[bytecompile/procedure cat source env]]
[defn bytecompile/array [source env]
[bytecompile/procedure array/ref source env]]
[defn bytecompile/tree [source env]
[bytecompile/procedure tree/ref source env]]
[defn bytecompile/λ* [source env]
[apply $lambda [cdr source]]]
[defn bytecompile/μ* [source env]
[apply $macro [cdr source]]]
[defn bytecompile/fn* [source env]
[apply $fn [cdr source]]]
[defn bytecompile/macro* [source env]
[apply $macro* [cdr source]]]
[defn bytecompile/ω* [source env]
[list [$let]
[bytecompile/do [cdr source] env]
[$closure/push]
[$closure/pop]]]
[defn bytecompile/let* [source env]
[list [$let]
[bytecompile/do [cadr source] env]
[$closure/pop]]]
[defn bytecompile/try [source env]
[def handler-sym [bytecompile/gen-label]]
[def end-sym [bytecompile/gen-label]]
[def final-sym [bytecompile/gen-label]]
[list [bytecompile* [cadr source] env]
[$try handler-sym]
[bytecompile/do/form [cddr source] env]
[$jmp end-sym]
[list :label handler-sym]
[$apply/dynamic 1]
[$jmp final-sym]
[list :label end-sym]
[$swap]
[$drop]
[list :label final-sym]]]
[defn 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]]
[fn* [bytecompile/fn* source env]]
[macro* [bytecompile/macro* source env]]
[λ* [bytecompile/λ* source env]]
[μ* [bytecompile/μ* source env]]
[ω* [bytecompile/ω* source env]]
[try [bytecompile/try source env]]
[quote [bytecompile/quote [cadr source]]]
[otherwise [throw [list :panic
"Found unknown special form in the bytecode compiler"
[car source]
[current-lambda]]]]]]
[[:lambda :native-function] [bytecompile/procedure op [cdr source] env]]
[[:pair :symbol] [bytecompile/procedure/dynamic op [cdr source] env]]
[:string [bytecompile/string source env]]
[:array [bytecompile/array source env]]
[:tree [bytecompile/tree source env]]
[otherwise [bytecompile/literal source]]]]
[defn bytecompile [form environment]
[list [bytecompile* form environment] [$ret]]]
[defmacro byterun [form]
`[-> [compile ~form] bytecompile assemble* bytecode-eval]]
