application/octet-stream
•
7.62 KB
•
226 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-apply-new* #t]
[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
[if *bytecompile-apply-new*
[$apply/new [length args] op]
[$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/default [op args env]
[def arg-count [length args]]
[if args
[list [bytecompile/procedure/arg args]
[if *bytecompile-apply-new*
[$apply/new arg-count op]
[$apply arg-count op]]]
[if *bytecompile-apply-new*
[$apply/new 0 op]
[$apply 0 op]]]]
[defn bytecompile/procedure/inline? [op]
[case [type-of op]
[:lambda [closure/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 [closure/meta op :source] env]]
[def arg-name [car [tree/ref [closure op] :arguments]]]
[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/dynamic [op args env]
[def arg-count [length args]]
[list [bytecompile* op env]
[when args [bytecompile/procedure/arg args]]
[if *bytecompile-apply-new*
[$apply/dynamic/new arg-count]
[$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]
[apply $fn [cdr source]]]
[defn bytecompile/macro* [source env]
[apply $macro* [cdr source]]]
[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/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]]]
