diff options
Diffstat (limited to 'stdlib/source/lux/platform/compiler/phase/translation/scheme/function.jvm.lux')
-rw-r--r-- | stdlib/source/lux/platform/compiler/phase/translation/scheme/function.jvm.lux | 92 |
1 files changed, 92 insertions, 0 deletions
diff --git a/stdlib/source/lux/platform/compiler/phase/translation/scheme/function.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/function.jvm.lux new file mode 100644 index 000000000..7eeb5a8ed --- /dev/null +++ b/stdlib/source/lux/platform/compiler/phase/translation/scheme/function.jvm.lux @@ -0,0 +1,92 @@ +(.module: + [lux (#- function) + [control + ["." monad (#+ do)] + pipe] + [data + ["." product] + [text + format] + [collection + ["." list ("list/." Functor<List>)]]]] + [// + ["." runtime (#+ Operation Phase)] + ["." reference] + ["/." // + ["//." // ("operation/." Monad<Operation>) + [analysis (#+ Variant Tuple Environment Arity Abstraction Application Analysis)] + [synthesis (#+ Synthesis)] + [// + [reference (#+ Register Variable)] + ["." name] + [// + [host + ["_" scheme (#+ Expression Computation Var)]]]]]]]) + +(def: #export (apply translate [functionS argsS+]) + (-> Phase (Application Synthesis) (Operation Computation)) + (do ////.Monad<Operation> + [functionO (translate functionS) + argsO+ (monad.map @ translate argsS+)] + (wrap (_.apply/* functionO argsO+)))) + +(def: (with-closure function-name inits function-definition) + (-> Text (List Expression) Computation (Operation Computation)) + (let [@closure (_.var (format function-name "___CLOSURE"))] + (operation/wrap + (case inits + #.Nil + function-definition + + _ + (_.letrec (list [@closure + (_.lambda [(|> (list.enumerate inits) + (list/map (|>> product.left reference.foreign'))) + #.None] + function-definition)]) + (_.apply/* @closure inits)))))) + +(def: @curried (_.var "curried")) +(def: @missing (_.var "missing")) + +(def: input + (|>> inc reference.local')) + +(def: #export (function translate [environment arity bodyS]) + (-> Phase (Abstraction Synthesis) (Operation Computation)) + (do ////.Monad<Operation> + [[function-name bodyO] (///.with-context + (do @ + [function-name ///.context] + (///.with-anchor (_.var function-name) + (translate bodyS)))) + closureO+ (monad.map @ reference.variable environment) + #let [arityO (|> arity .int _.int) + @num-args (_.var "num_args") + @function (_.var function-name) + apply-poly (.function (_ args func) + (_.apply/2 (_.global "apply") func args))]] + (with-closure function-name closureO+ + (_.letrec (list [@function (_.lambda [(list) (#.Some @curried)] + (_.let (list [@num-args (_.length/1 @curried)]) + (<| (_.if (|> @num-args (_.=/2 arityO)) + (<| (_.let (list [(reference.local' 0) @function])) + (_.let-values (list [[(|> (list.indices arity) + (list/map ..input)) + #.None] + (_.apply/2 (_.global "apply") (_.global "values") @curried)])) + bodyO)) + (_.if (|> @num-args (_.>/2 arityO)) + (let [arity-args (runtime.slice (_.int +0) arityO @curried) + output-func-args (runtime.slice arityO + (|> @num-args (_.-/2 arityO)) + @curried)] + (|> @function + (apply-poly arity-args) + (apply-poly output-func-args)))) + ## (|> @num-args (_.</2 arityO)) + (_.lambda [(list) (#.Some @missing)] + (|> @function + (apply-poly (_.append/2 @curried @missing)))))))]) + @function)) + )) |