application/octet-stream
•
7.05 KB
•
182 lines
; Contains the low level Nujel -> Bytecode compiler
[def bytecompile/gen-label/counter 0]
[defun bytecompile/gen-label [prefix]
[++ bytecompile/gen-label/counter]
[str->sym [cat prefix ":label-" bytecompile/gen-label/counter]]]
[defun bytecompile/literal [source]
[case [type-of source]
[:symbol [if [keyword? source]
[$push/lval source]
[$get source]]]
[:int [$push/int source]]
[otherwise [$push/lval source]]]]
[defun bytecompile/quote [source]
[case [type-of 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]
[when [or [not [cadr source]] [not [symbol? [cadr source]]] [not [caddr source]]] [throw [list :syntax-error "[def] needs a symbol name and a value as arguments" #nil env]]]
[list [bytecompile* [caddr source] env]
[$def [cadr source]]]]
[defun bytecompile/set! [source env]
[when [or [not [cadr source]] [not [symbol? [cadr source]]] [not [caddr source]]] [throw [list :syntax-error "[set!] needs a symbol name and a value as arguments" #nil env]]]
[list [bytecompile* [caddr source] env]
[$set [cadr source]]]]
[defun 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]]]]
[defun bytecompile/while [source env]
[def sym-start [bytecompile/gen-label]]
[def sym-end [bytecompile/gen-label]]
[list [list :label 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* [car source] env]
[bytecompile/procedure/arg [cdr source] env]]]]
[defun bytecompile/procedure [op args env]
[def arg-count [length args]]
[if args
[list [bytecompile/procedure/arg args]
[$apply arg-count op]]
[$apply 0 op]]]
[defun bytecompile/procedure/dynamic [op args env]
[def arg-count [length args]]
[if args
[list [bytecompile/procedure/arg args]
[bytecompile* op env]
[$apply/dynamic arg-count]]
[list [bytecompile* op env]
[$apply/dynamic 0]]]]
[defun 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]]]]]
[defun bytecompile/and [source env]
[def label-end [bytecompile/gen-label]]
[list [bytecompile/and/rec [cdr source] env label-end]
[list :label label-end]]]
[defun 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]]]]
[defun 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]]]
[defun bytecompile/string [source env]
[bytecompile/procedure cat source env]]
[defun bytecompile/array [source env]
[bytecompile/procedure array/ref source env]]
[defun bytecompile/tree [source env]
[bytecompile/procedure tree/ref source env]]
[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]
[$closure/push]
[$closure/pop]]]
[defun bytecompile/let* [source env]
[list [$let]
[bytecompile/do [cadr source] env]
[$closure/pop]]]
[defun bytecompile/try [source env]
[def handler-sym [bytecompile/gen-label]]
[def end-sym [bytecompile/gen-label]]
[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 [bytecompile/quote [cadr 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 [cdr source] env]]
[:pair [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]]]]
[defun bytecompile [form environment]
[list [bytecompile* form environment] [$ret]]]
[defmacro byterun [form]
`[-> [compile ~form] bytecompile assemble* bytecode-eval]]
