application/octet-stream
•
4.86 KB
•
1 line
[do [def bytecompile/literal [λ* bytecompile/literal [source] "" [let* [do [def ΓεnΣym-41 [type-of source]] [if [== ΓεnΣym-41 :symbol] [$get source] [if [== ΓεnΣym-41 :int] [$push/int source] [$push/lval source]]]]]]] [def bytecompile/do/form [λ* bytecompile/do/form [source env] "" [if source [cons [cons [bytecompile* [car source] env] [if [last? source] #nil [cons [$drop] #nil]]] [bytecompile/do/form [cdr source] env]] #nil]]] [def bytecompile/do [λ* bytecompile/do [source env] "" [list [bytecompile/do/form [cdr source] env]]]] [def bytecompile/procedure [λ* bytecompile/procedure [op source env] "" [do [def args [map [cdr source] bytecompile*]] [list args [$apply [length args] op]]]]] [def bytecompile/def [λ* bytecompile/def [source env] "" [list [bytecompile* [caddr source] env] [$def [cadr source]]]]] [def bytecompile/set! [λ* bytecompile/set! [source env] "" [list [bytecompile* [caddr source] env] [$set [cadr source]]]]] [def bytecompile/if [λ* bytecompile/if [source env] "" [let* [do [def sym-else [gensym]] [def sym-after [gensym]] [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]]]]]] [def bytecompile/while [λ* bytecompile/while [source env] "" [do [def sym-start [gensym]] [def sym-end [gensym]] [list sym-start [bytecompile* [cadr source] env] [$jf sym-end] [bytecompile* [caddr source] env] [$jmp sym-start] [list :label sym-end]]]]] [def bytecompile/procedure/arg [λ* bytecompile/procedure/arg [source env] "" [if [last? source] [bytecompile* [car source] env] [cons [bytecompile/procedure/arg [cdr source] env] [bytecompile* [car source] env]]]]] [def bytecompile/procedure [λ* bytecompile/procedure [op source env] "" [do [def args [cdr source]] [def arg-count [length args]] [if args [list [bytecompile/procedure/arg [cdr source]] [$apply arg-count op]] [$apply arg-count op]]]]] [def bytecompile/and/rec [λ* bytecompile/and/rec [source env sym-end] "" [do [def c [bytecompile* [car source] env]] [if [last? source] c [list c [$dup] [$jf sym-end] [$drop] [bytecompile/and/rec [cdr source] env sym-end]]]]]] [def bytecompile/and [λ* bytecompile/and [source env] "" [do [def sym-end [gensym]] [list [bytecompile/and/rec [cdr source] env sym-end] sym-end]]]] [def bytecompile/or/rec [λ* bytecompile/or/rec [source env sym-end] "" [do [def c [bytecompile* [car source] env]] [if [last? source] c [list c [$dup] [$jt sym-end] [$drop] [bytecompile/or/rec [cdr source] env sym-end]]]]]] [def bytecompile/or [λ* bytecompile/or [source env] "" [do [def sym-end [gensym]] [list [bytecompile/or/rec [cdr source] env sym-end] sym-end]]]] [def bytecompile/λ* [λ* bytecompile/λ* [source env] "" [apply $lambda [cdr source]]]] [def bytecompile/μ* [λ* bytecompile/μ* [source env] "" [apply $macro [cdr source]]]] [def bytecompile/ω* [λ* bytecompile/ω* [source env] "" [list [$let] [bytecompile/do [cdr source] env] [$push/closure] [$closure/pop]]]] [def bytecompile/let* [λ* bytecompile/let* [source env] "" [list [$let] [bytecompile/do [cdr source] env] [$closure/pop]]]] [def bytecompile/try [λ* bytecompile/try [source env] "" [do [def handler-sym [gensym]] [def end-sym [gensym]] [list [$try handler-sym] [bytecompile/do [cddr source] env] [$jmp end-sym] [:label handler-sym] [$apply 1 [cadr source]] [:label end-sym]]]]] [def bytecompile* [λ* bytecompile* [source env] "Compile the forms in source" [do [def op [if [resolves? [car source] env] [resolve [car source] env] [car source]]] [let* [do [def ΓεnΣym-42 [type-of op]] [if [== ΓεnΣym-42 :special-form] [let* [do [def ΓεnΣym-43 op] [if [== ΓεnΣym-43 do] [bytecompile/do source env] [if [== ΓεnΣym-43 let*] [bytecompile/let* source env] [if [== ΓεnΣym-43 def] [bytecompile/def source env] [if [== ΓεnΣym-43 set!] [bytecompile/set! source env] [if [== ΓεnΣym-43 if] [bytecompile/if source env] [if [== ΓεnΣym-43 while] [bytecompile/while source env] [if [== ΓεnΣym-43 and] [bytecompile/and source env] [if [== ΓεnΣym-43 or] [bytecompile/or source env] [if [== ΓεnΣym-43 λ*] [bytecompile/λ* source env] [if [== ΓεnΣym-43 μ*] [bytecompile/μ* source env] [if [== ΓεnΣym-43 ω*] [bytecompile/ω* source env] [if [== ΓεnΣym-43 try] [bytecompile/try source env] [if [== ΓεnΣym-43 quote] source [throw [list :unknown-special-form "The compiler does not know the current special form, please fix the compiler!" [car source]]]]]]]]]]]]]]]]]] [if [or [== ΓεnΣym-42 :lambda] [== ΓεnΣym-42 :native-function]] [bytecompile/procedure op source env] [bytecompile/literal source]]]]]]]] [def bytecompile [λ* bytecompile [form environment] "" [list [bytecompile* form environment] [$ret]]]] [def byterun [μ* byterun [form] "" [cons 'bytecode-eval [cons [cons 'assemble* [cons [cons 'bytecompile [cons [cons 'compile [cons form #nil]] [cons [cons 'current-closure #nil] #nil]]] #nil]] #nil]]]]]
