diff options
Diffstat (limited to '')
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/common-lisp/function.jvm.lux | 82 |
1 files changed, 82 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/lang/translation/common-lisp/function.jvm.lux b/new-luxc/source/luxc/lang/translation/common-lisp/function.jvm.lux new file mode 100644 index 000000000..543cbe899 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/common-lisp/function.jvm.lux @@ -0,0 +1,82 @@ +(.module: + lux + (lux (control [monad #+ do] + pipe) + (data [product] + [text] + text/format + (coll [list "list/" Functor<List> Fold<List>])) + [macro]) + (luxc ["&" lang] + (lang ["ls" synthesis] + [".L" variable #+ Variable] + (host ["_" common-lisp #+ Expression @@]))) + [//] + (// [".T" reference] + [".T" runtime])) + +(def: #export (translate-apply translate functionS argsS+) + (-> (-> ls.Synthesis (Meta Expression)) ls.Synthesis (List ls.Synthesis) (Meta Expression)) + (do macro.Monad<Meta> + [functionO (translate functionS) + argsO+ (monad.map @ translate argsS+)] + (wrap (_.funcall argsO+ functionO)))) + +(def: $curried (_.var "curried")) +(def: $missing (_.var "missing")) + +(def: input-declaration + (|>> n/inc referenceT.variable)) + +(def: (with-closure function-name inits function-definition) + (-> Text (List Expression) Expression (Meta Expression)) + (let [$closure (_.var (format function-name "___CLOSURE"))] + (do macro.Monad<Meta> + [] + (case inits + #.Nil + (wrap function-definition) + + _ + (wrap (_.labels (list [$closure [(|> (list.enumerate inits) + (list/map (|>> product.left referenceT.closure)) + _.poly) + function-definition]]) + (_.funcall inits (_.function (@@ $closure))))))))) + +(def: #export (translate-function translate env arity bodyS) + (-> (-> ls.Synthesis (Meta Expression)) + (List Variable) ls.Arity ls.Synthesis + (Meta Expression)) + (do macro.Monad<Meta> + [[function-name bodyO] (//.with-sub-context + (do @ + [function-name //.context] + (//.with-anchor [function-name +1] + (translate bodyS)))) + closureO+ (monad.map @ referenceT.translate-variable env) + #let [arityO (|> arity nat-to-int _.int) + $num_args (_.var "num_args") + $function (_.var function-name)]] + (with-closure function-name closureO+ + (_.labels (list [$function [(_.poly+ (list) $curried) + (_.let (list [$num_args (_.length (@@ $curried))]) + (<| (_.if (|> (@@ $num_args) (_.= arityO)) + (_.let (list [(referenceT.variable +0) (_.function (@@ $function))]) + (_.destructuring-bind [(|> (list.n/range +0 (n/dec arity)) + (list/map input-declaration) + _.poly) + (@@ $curried)] + bodyO))) + (_.if (|> (@@ $num_args) (_.> arityO)) + (let [arity-args (_.subseq/3 (@@ $curried) (_.int 0) arityO) + output-func-args (_.subseq/3 (@@ $curried) arityO (@@ $num_args))] + (|> (_.function (@@ $function)) + (_.apply arity-args) + (_.apply output-func-args)))) + ## (|> (@@ $num_args) (_.< arityO)) + (_.lambda (_.poly+ (list) $missing) + (|> (_.function (@@ $function)) + (_.apply (_.append (@@ $curried) (@@ $missing)))))))]]) + (_.function (@@ $function)))) + )) |