Ben / Nujel

[do [def compile/environment [current-closure]] [def compile/verbose #f] [def compile/do/args [λ* compile/do/args [args] "" [if [last? args] [cons [compile* [car args]] #nil] [if [pair? [car args]] [let* [do [def ocar [compile* [car args]]] [if [pair? ocar] [cons ocar [compile/do/args [cdr args]]] [compile/do/args [cdr args]]]]] [compile/do/args [cdr args]]]]]] [def compile/do [λ* compile/do [source] "" [let* [do [def args [compile/do/args source]] [if [last? args] [car args] [cons 'do args]]]]]] [def compile/def [λ* compile/def [source] "" [list 'def [cadr source] [compile* [caddr source]]]]] [def compile/set! [λ* compile/set! [source] "" [list 'set! [cadr source] [compile* [caddr source]]]]] [def compile/λ* [λ* compile/λ* [source] "" [list 'λ* [cadr source] [caddr source] [cadddr source] [compile [caddddr source]]]]] [def compile/μ* [λ* compile/μ* [source] "" [list 'μ* [cadr source] [caddr source] [cadddr source] [compile [caddddr source]]]]] [def compile/ω* [λ* compile/ω* [source] "" [list 'ω* [compile/do [cdr source]]]]] [def compile/try [λ* compile/try [source] "" [list 'try [compile* [cadr source]] [compile/do [cddr source]]]]] [def compile/if [λ* compile/if [source] "" [list 'if [compile* [cadr source]] [compile* [caddr source]] [compile* [cadddr source]]]]] [def compile/let* [λ* compile/let* [source] "" [list 'let* [compile/do [cdr source]]]]] [def compile/and [λ* compile/and [source] "" [compile/procedure/arg source]]] [def compile/or [λ* compile/or [source] "" [compile/procedure/arg source]]] [def compile/while [λ* compile/while [source] "" [list 'while [compile* [cadr source]] [compile/do [cddr source]]]]] [def compile/macro [λ* compile/macro [macro source] "" [compile* [macro-apply macro [cdr source]]]]] [def compile/procedure/arg [λ* compile/procedure/arg [source] "" [if [pair? source] [cons [compile* [car source]] [compile/procedure/arg [cdr source]]] #nil]]] [def compile/procedure [λ* compile/procedure [proc source] "" [compile/procedure/arg source]]] [def compile* [λ* compile* [source] "Compile the forms in source" [let* [do [def op [if [apply compile/environment [cons 'do [cons [cons 'resolves? [cons [list 'quote [car source]] #nil]] #nil]]] [apply compile/environment [cons 'do [cons [cons 'resolve [cons [list 'quote [car source]] #nil]] #nil]]] [car source]]] [let* [do [def ΓεnΣym-47 [type-of op]] [if [== ΓεnΣym-47 :special-form] [let* [do [def ΓεnΣym-48 op] [if [== ΓεnΣym-48 do] [compile/do source] [if [== ΓεnΣym-48 def] [compile/def source] [if [== ΓεnΣym-48 set!] [compile/set! source] [if [== ΓεnΣym-48 let*] [compile/let* source] [if [== ΓεnΣym-48 λ*] [compile/λ* source] [if [== ΓεnΣym-48 μ*] [compile/μ* source] [if [== ΓεnΣym-48 ω*] [compile/ω* source] [if [== ΓεnΣym-48 if] [compile/if source] [if [== ΓεnΣym-48 try] [compile/try source] [if [== ΓεnΣym-48 and] [compile/and source] [if [== ΓεnΣym-48 or] [compile/or source] [if [== ΓεnΣym-48 while] [compile/while source] [if [== ΓεnΣym-48 quote] source [throw [list :unknown-special-form "The compiler does not know the current special form, please fix the compiler!" [car source]]]]]]]]]]]]]]]]]] [if [== ΓεnΣym-47 :macro] [compile/macro op source] [if [or [== ΓεnΣym-47 :lambda] [== ΓεnΣym-47 :native-function]] [compile/procedure op source] [if [== ΓεnΣym-47 :object] [compile/procedure/arg source] [if [== ΓεnΣym-47 :pair] [compile/procedure/arg source] [if [or [== ΓεnΣym-47 :int] [== ΓεnΣym-47 :float] [== ΓεnΣym-47 :vec]] [compile/procedure/arg source] [if [== ΓεnΣym-47 :array] [compile/procedure/arg source] [if [== ΓεnΣym-47 :string] [compile/procedure/arg source] [if [== ΓεnΣym-47 :tree] [compile/procedure/arg source] [if [last? source] source [compile/procedure/arg source]]]]]]]]]]]]]]]]] [def compile [λ* compile [source new-environment new-verbose] "Compile the forms in source" [do [if new-environment #nil [set! new-environment [current-closure]]] [if new-verbose #nil [set! new-verbose #f]] [set! compile/environment new-environment] [set! compile/verbose new-verbose] [compile* source]]]] [def compile/forms [λ* compile/forms [source-raw environment] "Compile multiple forms, evaluation the results in a temporary environment, so we can make use of macros we just defined" [do [if environment #nil [set! environment [ω* #nil]]] [def source #nil] [def source-next source-raw] [def forms-compiled 0] [def try-again [λ* try-again [source] "" [set! source-next [cons source source-next]]]] [while source-next [do [def forms-compiled-last forms-compiled] [set! source source-next] [set! source-next #nil] [def errors #nil] [while source [do [try [λ* #nil [err] "" [do [set! errors [cons err errors]] [let* [do [def ΓεnΣym-49 [car err]] [if [== ΓεnΣym-49 :unresolved-procedure] [try-again [car source]] [if [== ΓεnΣym-49 :runtime-macro] [try-again [car source]] [throw err]]]]]]] [do [def compiled-form [compile [car source] environment #t]] [if compiled-form [do [apply environment [cons 'eval* [cons compiled-form #nil]]] [set! forms-compiled [+ 1 forms-compiled]]] #nil]]] [set! source [cdr source]]]] [set! source-next [reverse source-next]] [if [<= forms-compiled forms-compiled-last] [do [for-each errors display/error] [throw [list :you-can-not-advance "The compiler got stuck trying to compile various forms, the final pass did not have a single form that compiled without errors"]]] #nil]]] [compile source-raw environment]]]] [def defmacro [μ* defmacro [name args . body] "Define a new macro" [do [def doc-string [if [string? [car body]] [car body] ""]] [list 'def name [compile [list 'μ* name args doc-string [cons 'do body]] [current-closure]]]]]] [def defun [μ* defun [name args . body] "Define a new function" [do [def doc-string [if [string? [car body]] [car body] ""]] [list 'def name [compile [list 'λ* name args doc-string [cons 'do body]] [current-closure]]]]]] [def μ [μ* μ [args . body] "Define a λ with the self-hosting Nujel compiler" [do [def doc-string [if [string? [car body]] [car body] ""]] [compile [list 'μ* #nil args doc-string [cons 'do body]] [current-closure]]]]] [def \ [μ* \ [args . body] "Define a λ with the self-hosting Nujel compiler" [do [def doc-string [if [string? [car body]] [car body] ""]] [compile [list 'λ* #nil args doc-string [cons 'do body]] [current-closure]]]]] [def λ \] [def ω [μ* ω body "Defines and returns new object after evaluating body within" [compile [cons 'ω* body]]]] [def defobj ω*] [def eval [μ* eval [expr] "Compile, Evaluate and then return the result of EXPR" [cons 'eval* [cons [cons 'compile [cons expr [cons [cons 'current-closure #nil] #nil]]] #nil]]]] [def eval-compile [λ* eval-compile [expr closure] "Compile and the immediatly evaluate the result, mostly used by lRun()" [try display/error [eval* [compile/forms expr closure]]]]] [def optimize/code/rest [λ* optimize/code/rest [code] "" [if [pair? code] [cons [optimize/code [car code]] [optimize/code/rest [cdr code]]] code]]] [def optimize/code [λ* optimize/code [code] "" [if [pair? code] [if [and [symbol? [car code]] [resolves? [car code]]] [cons [resolve [car code]] [optimize/code/rest [cdr code]]] [cons [optimize/code [car code]] [optimize/code/rest [cdr code]]]] code]]] [def optimize! [λ* optimize! [fun] "Optimize FUN via mutation" [if [lambda? fun] [closure! fun [tree/new :code [optimize/code [[closure fun] :code]]]] #f]]] [def optimize-all! [λ* optimize-all! [] "Return a list of all lambdas in CTX" [for-each [filter [map [symbol-table] resolve] lambda?] optimize!]]]]