application/octet-stream
•
8.57 KB
•
227 lines
;; Nujel - Copyright (C) 2020-2021 - Benjamin Vincent Schulenburg
;; This project uses the MIT license, a copy should be included under /LICENSE
;;
;; Contains the Bytecode compiler that takes macroexpanded Nujel code and emits
;; Bytecode assembly
[def bytecompile/gen-label/counter 0]
[defn bytecompile/gen-label [prefix]
[++ bytecompile/gen-label/counter]
[string->symbol [cat prefix "label-" bytecompile/gen-label/counter]]]
[def *bytecompile-push* #f]
[defn $push/v [v]
[if *bytecompile-push*
[$push/val v]
[$push/lval v]]]
[defn bytecompile/literal [source]
[case [type-of source]
[[:symbol :keyword] [if [keyword? source]
[$push/v source]
[$get source]]]
[:int [$push/int source]]
[:nil [$push/nil]]
[otherwise [$push/v source]]]]
[defn bytecompile/quote [source]
[case [type-of source]
[:int [$push/int source]]
[:symbol [$push/symbol source]]
[otherwise [$push/v 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/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/inline? [op]
[case [type-of op]
[:lambda [meta op :inline]]
[#t #f]]]
[defn bytecompile/procedure/inline [op args env]
[def arg-count [length args]]
[when [> arg-count 1]
[throw [list :compiler-error "For now only monadic functions can be inlined" op [current-lambda]]]]
[def form [macroexpand/do [meta op :source] env]]
[def arg-name [car [closure/arguments op]]]
[if args
[bytecompile* [list/replace form arg-name [car args]] env]
[bytecompile* form env]]]
[defn bytecompile/procedure [op args env]
[if [bytecompile/procedure/inline? op]
[bytecompile/procedure/inline op args env]
[bytecompile/procedure/default op args env]]]
[defn bytecompile/procedure/default [op args env]
[def arg-count [length args]]
[if [$apply/optimize? op]
[list [when args [bytecompile/procedure/arg args]]
[$apply arg-count op]]
[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/fn* [source env]
[def arg-count [length [cdr source]]]
[when [!= arg-count 5] [exception :arity-error "[fn*] needs exactly 4 arguments" source]]
[cdr! source]
[list [bytecompile* [car source] env]
[bytecompile* [cadr source] env]
[bytecompile* [caddr source] env]
[bytecompile* [cadddr source] env]
[$fn/dynamic]]]
[defn bytecompile/macro* [source env]
[def arg-count [length [cdr source]]]
[when [!= arg-count 5] [exception :arity-error "[macro*] needs exactly 4 arguments" source]]
[cdr! source]
[list [bytecompile* [car source] env]
[bytecompile* [cadr source] env]
[bytecompile* [caddr source] env]
[bytecompile* [cadddr source] env]
[$macro/dynamic]]]
[defn bytecompile/ω* [source env]
[list [$let]
[bytecompile/do/form [cdr source] env]
[$drop]
[$closure/push]
[$closure/pop]]]
[defn bytecompile/let* [source env]
[list [$let]
[bytecompile/do [cadr source] env]
[$closure/pop]]]
[defn bytecompile/return [source env]
[list [bytecompile* [cadr source] env]
[$ret]]]
[defn bytecompile/try [source env]
[def end-sym [bytecompile/gen-label]]
[list [bytecompile* [cadr source] env]
[$try end-sym]
[bytecompile/do/form [cddr source] env]
[$closure/pop]
[list :label end-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]
[[:lambda :native-function]
[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]]
[try [bytecompile/try source env]]
[return [bytecompile/return source env]]
[quote [bytecompile/quote [cadr source]]]
[otherwise [bytecompile/procedure op [cdr source] env]]]]
[[:pair :symbol] [bytecompile/procedure 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]]]
