aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/lang/translation/common-lisp/function.jvm.lux
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/lang/translation/common-lisp/function.jvm.lux82
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))))
+ ))