application/octet-stream
•
11.98 KB
•
214 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/lowered Nujel code
;;; and emits bytecode assembly
[def bytecompile* [let*
[def bytecompile/gen-label/counter 0]
[defn bytecompile/gen-label [prefix]
[inc! bytecompile/gen-label/counter]
[string->symbol [cat prefix "label-" bytecompile/gen-label/counter]]]
[defn bytecompile/literal [source]
[case [type-of source]
[:int [$push/int source]]
[:nil [$push/nil]]
[:bool [if source
[$push/true]
[$push/false]]]
[:symbol [list [$get/val source]]]
[[:native-function :lambda] [bytecompile/literal [closure/name source]]]
[otherwise [$push/val source]]]]
[defn bytecompile/quote [source]
[case [type-of source]
[:nil [$push/nil]]
[:int [$push/int source]]
[otherwise [$push/val 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/val [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/val [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/nil] ;; Return value if predicate is #f from the beginning
[$jmp sym-end]
[list :label sym-start]
[$drop]
[bytecompile/do/form [cddr source] env]
[list :label sym-end]
[bytecompile* [cadr source] env]
[$jt sym-start]]]
[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]
[meta op :inline]]
[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 op-raw]
[if [bytecompile/procedure/inline? op]
[bytecompile/procedure/inline op args env]
[bytecompile/procedure/default op args env op-raw]]]
[defn bytecompile/procedure/default [op args env op-raw]
[when [and [not [procedure? op]]
[not [symbol? op]]
[not [pair? op]]]
[exception :type-error "Can't apply to that" op]]
[def arg-count [length args]]
[if [$apply/optimize? op arg-count]
[list [when args [bytecompile/procedure/arg args]]
[$apply/optimized arg-count op]]
[list [bytecompile* op-raw env]
[when args [bytecompile/procedure/arg args]]
[$apply 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/val #f]
[list :label label-end]]]
[defn bytecompile/fn* [source env]
[def arg-count [length [cdr source]]]
[when [not= 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 [not= 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/environment* [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 :pair :symbol]
[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]]
[environment* [bytecompile/environment* source env]]
[try [bytecompile/try source env]]
[return [bytecompile/return source env]]
[quote [bytecompile/quote [cadr source]]]
[otherwise [bytecompile/procedure op [cdr source] env [car source]]]]]
[otherwise [if [pair? source]
[exception :type-error "Can't evaluate that" source]
[bytecompile/literal source]]]]]]]
[defn bytecompile [form environment]
[list [bytecompile* form environment]
[$ret]]]
