aboutsummaryrefslogtreecommitdiff
path: root/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux
diff options
context:
space:
mode:
Diffstat (limited to 'lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux')
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux222
1 files changed, 150 insertions, 72 deletions
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux
index e647bf71b..89c7053f9 100644
--- a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux
+++ b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux
@@ -7,21 +7,23 @@
[control
["." exception (#+ exception:)]
["." function]
- ["<>" parser ("#@." monad)
+ ["<>" parser ("#\." monad)
["<.>" text]
["<.>" synthesis (#+ Parser)]]]
[data
["." product]
- ["." maybe ("#@." functor)]
- ["." text ("#@." equivalence)
+ ["." maybe ("#\." functor)]
+ ["." text ("#\." equivalence)
["%" format (#+ format)]]
[collection
- ["." list ("#@." monad)]
+ ["." list ("#\." monad fold)]
["." dictionary (#+ Dictionary)]
["." set]]]
+ [macro
+ ["." template]]
[math
[number
- ["." nat]]]
+ ["n" nat]]]
[target
[jvm
["." type (#+ Type Typed Argument)
@@ -33,9 +35,9 @@
["." parser]]]]
[tool
[compiler
- ["." phase ("#@." monad)]
+ ["." phase ("#\." monad)]
[reference (#+)
- ["." variable (#+ Variable)]]
+ ["." variable (#+ Variable Register)]]
[meta
[archive (#+ Archive)]]
[language
@@ -568,15 +570,15 @@
(do phase.monad
[valueI (generate archive valueS)]
(`` (cond (~~ (template [<object> <primitive>]
- [(and (text@= (reflection.reflection (type.reflection <primitive>))
+ [(and (text\= (reflection.reflection (type.reflection <primitive>))
from)
- (text@= <object>
+ (text\= <object>
to))
(wrap (|>> valueI (_.wrap <primitive>)))
- (and (text@= <object>
+ (and (text\= <object>
from)
- (text@= (reflection.reflection (type.reflection <primitive>))
+ (text\= (reflection.reflection (type.reflection <primitive>))
to))
(wrap (|>> valueI (_.unwrap <primitive>)))]
@@ -731,10 +733,10 @@
(..custom
[($_ <>.and ..class <synthesis>.text ..return (<>.some ..input))
(function (_ extension_name generate archive [class method outputT inputsTS])
- (do {@ phase.monad}
- [inputsTI (monad.map @ (generate_input generate archive) inputsTS)]
- (wrap (|>> (_.fuse (list@map product.right inputsTI))
- (_.INVOKESTATIC class method (type.method [(list) (list@map product.left inputsTI) outputT (list)]))
+ (do {! phase.monad}
+ [inputsTI (monad.map ! (generate_input generate archive) inputsTS)]
+ (wrap (|>> (_.fuse (list\map product.right inputsTI))
+ (_.INVOKESTATIC class method (type.method [(list) (list\map product.left inputsTI) outputT (list)]))
(prepare_output outputT)))))]))
(template [<name> <invoke>]
@@ -743,15 +745,15 @@
(..custom
[($_ <>.and ..class <synthesis>.text ..return <synthesis>.any (<>.some ..input))
(function (_ extension_name generate archive [class method outputT objectS inputsTS])
- (do {@ phase.monad}
+ (do {! phase.monad}
[objectI (generate archive objectS)
- inputsTI (monad.map @ (generate_input generate archive) inputsTS)]
+ inputsTI (monad.map ! (generate_input generate archive) inputsTS)]
(wrap (|>> objectI
(_.CHECKCAST class)
- (_.fuse (list@map product.right inputsTI))
+ (_.fuse (list\map product.right inputsTI))
(<invoke> class method
(type.method [(list)
- (list@map product.left inputsTI)
+ (list\map product.left inputsTI)
outputT
(list)]))
(prepare_output outputT)))))]))]
@@ -766,12 +768,12 @@
(..custom
[($_ <>.and ..class (<>.some ..input))
(function (_ extension_name generate archive [class inputsTS])
- (do {@ phase.monad}
- [inputsTI (monad.map @ (generate_input generate archive) inputsTS)]
+ (do {! phase.monad}
+ [inputsTI (monad.map ! (generate_input generate archive) inputsTS)]
(wrap (|>> (_.NEW class)
_.DUP
- (_.fuse (list@map product.right inputsTI))
- (_.INVOKESPECIAL class "<init>" (type.method [(list) (list@map product.left inputsTI) type.void (list)]))))))]))
+ (_.fuse (list\map product.right inputsTI))
+ (_.INVOKESPECIAL class "<init>" (type.method [(list) (list\map product.left inputsTI) type.void (list)]))))))]))
(def: member_bundle
Bundle
@@ -806,6 +808,37 @@
(Parser Argument)
(<synthesis>.tuple (<>.and <synthesis>.text ..value)))
+(def: #export (hidden_method_body arity body)
+ (-> Nat Synthesis Synthesis)
+ (case [arity body]
+ [0 _] body
+ [1 _] body
+
+ [2 (#synthesis.Control (#synthesis.Branch (#synthesis.Let _ 2 hidden)))]
+ hidden
+
+ [_ (#synthesis.Control (#synthesis.Branch (#synthesis.Case _ path)))]
+ (loop [path path]
+ (case path
+ (^or #synthesis.Pop
+ (#synthesis.Access _)
+ (#synthesis.Bind _)
+ (#synthesis.Bit_Fork _)
+ (#synthesis.I64_Fork _)
+ (#synthesis.F64_Fork _)
+ (#synthesis.Text_Fork _)
+ (#synthesis.Alt _))
+ body
+
+ (#synthesis.Seq _ next)
+ (recur next)
+
+ (#synthesis.Then hidden)
+ hidden))
+
+ _
+ body))
+
(def: overriden_method_definition
(Parser [(Environment Synthesis) (/.Overriden_Method Synthesis)])
(<synthesis>.tuple
@@ -820,14 +853,16 @@
arguments (<synthesis>.tuple (<>.some ..argument))
returnT ..return
exceptionsT (<synthesis>.tuple (<>.some ..class))
- [environment _ _ body] (<synthesis>.function 1
- (<synthesis>.loop (<>.exactly 0 <synthesis>.any)
- (<synthesis>.tuple <synthesis>.any)))]
+ [environment _ _ body] (<| (<synthesis>.function 1)
+ (<synthesis>.loop (<>.exactly 0 <synthesis>.any))
+ <synthesis>.tuple
+ (<>.after <synthesis>.any)
+ <synthesis>.any)]
(wrap [environment
[ownerT name
strict_fp? annotations vars
self_name arguments returnT exceptionsT
- body]]))))
+ (..hidden_method_body (list.size arguments) body)]]))))
(def: (normalize_path normalize)
(-> (-> Synthesis Synthesis)
@@ -851,12 +886,12 @@
[#synthesis.Access])
(#synthesis.Bit_Fork when then else)
- (#synthesis.Bit_Fork when (recur then) (maybe@map recur else))
+ (#synthesis.Bit_Fork when (recur then) (maybe\map recur else))
(^template [<tag>]
[(<tag> [[test then] elses])
(<tag> [[test (recur then)]
- (list@map (function (_ [else_test else_then])
+ (list\map (function (_ [else_test else_then])
[else_test (recur else_then)])
elses)])])
([#synthesis.I64_Fork]
@@ -878,7 +913,7 @@
(synthesis.variant [lefts right? (recur sub)])
(^ (synthesis.tuple members))
- (synthesis.tuple (list@map recur members))
+ (synthesis.tuple (list\map recur members))
(^ (synthesis.variable var))
(|> mapping
@@ -899,13 +934,13 @@
(synthesis.branch/get [path (recur recordS)])
(^ (synthesis.loop/scope [offset initsS+ bodyS]))
- (synthesis.loop/scope [offset (list@map recur initsS+) (recur bodyS)])
+ (synthesis.loop/scope [offset (list\map recur initsS+) (recur bodyS)])
(^ (synthesis.loop/recur updatesS+))
- (synthesis.loop/recur (list@map recur updatesS+))
+ (synthesis.loop/recur (list\map recur updatesS+))
(^ (synthesis.function/abstraction [environment arity bodyS]))
- (synthesis.function/abstraction [(list@map (function (_ captured)
+ (synthesis.function/abstraction [(list\map (function (_ captured)
(case captured
(^ (synthesis.variable var))
(|> mapping
@@ -920,10 +955,10 @@
bodyS])
(^ (synthesis.function/apply [functionS inputsS+]))
- (synthesis.function/apply [(recur functionS) (list@map recur inputsS+)])
+ (synthesis.function/apply [(recur functionS) (list\map recur inputsS+)])
(#synthesis.Extension [name inputsS+])
- (#synthesis.Extension [name (list@map recur inputsS+)]))))
+ (#synthesis.Extension [name (list\map recur inputsS+)]))))
(def: $Object
(type.class "java.lang.Object" (list)))
@@ -940,27 +975,68 @@
(let [store_capturedI (|> env
list.size
list.indices
- (list@map (.function (_ register)
+ (list\map (.function (_ register)
(|>> (_.ALOAD 0)
(_.ALOAD (inc register))
(_.PUTFIELD class (///reference.foreign_name register) $Object))))
_.fuse)]
(_def.method #$.Public $.noneM "<init>" (anonymous_init_method env)
(|>> (_.ALOAD 0)
- ((_.fuse (list@map product.right inputsTI)))
- (_.INVOKESPECIAL super_class "<init>" (type.method [(list) (list@map product.left inputsTI) type.void (list)]))
+ ((_.fuse (list\map product.right inputsTI)))
+ (_.INVOKESPECIAL super_class "<init>" (type.method [(list) (list\map product.left inputsTI) type.void (list)]))
store_capturedI
_.RETURN))))
(def: (anonymous_instance generate archive class env)
(-> Phase Archive (Type Class) (Environment Synthesis) (Operation Inst))
- (do {@ phase.monad}
- [captureI+ (monad.map @ (generate archive) env)]
+ (do {! phase.monad}
+ [captureI+ (monad.map ! (generate archive) env)]
(wrap (|>> (_.NEW class)
_.DUP
(_.fuse captureI+)
(_.INVOKESPECIAL class "<init>" (anonymous_init_method env))))))
+(def: (prepare_argument lux_register argumentT jvm_register)
+ (-> Register (Type Value) Register [Register Inst])
+ (case (type.primitive? argumentT)
+ (#.Left argumentT)
+ [(n.+ 1 jvm_register)
+ (if (n.= lux_register jvm_register)
+ (|>>)
+ (|>> (_.ALOAD jvm_register)
+ (_.ASTORE lux_register)))]
+
+ (#.Right argumentT)
+ (template.let [(wrap_primitive <shift> <load> <type>)
+ [[(n.+ <shift> jvm_register)
+ (|>> (<load> jvm_register)
+ (_.wrap <type>)
+ (_.ASTORE lux_register))]]]
+ (`` (cond (~~ (template [<shift> <load> <type>]
+ [(\ type.equivalence = <type> argumentT)
+ (wrap_primitive <shift> <load> <type>)]
+
+ [1 _.ILOAD type.boolean]
+ [1 _.ILOAD type.byte]
+ [1 _.ILOAD type.short]
+ [1 _.ILOAD type.int]
+ [1 _.ILOAD type.char]
+ [1 _.FLOAD type.float]
+ [2 _.LLOAD type.long]))
+
+ ## (\ type.equivalence = type.double argumentT)
+ (wrap_primitive 2 _.DLOAD type.double))))))
+
+(def: #export (prepare_arguments offset types)
+ (-> Nat (List (Type Value)) Inst)
+ (|> types
+ list.enumeration
+ (list\fold (function (_ [lux_register type] [jvm_register before])
+ (let [[jvm_register' after] (prepare_argument (n.+ offset lux_register) type jvm_register)]
+ [jvm_register' (|>> before after)]))
+ (: [Register Inst] [offset (|>>)]))
+ product.right))
+
(def: #export (returnI returnT)
(-> (Type Return) Inst)
(case (type.void? returnT)
@@ -979,21 +1055,23 @@
_.ARETURN)
(#.Right returnT)
- (cond (or (\ type.equivalence = type.boolean returnT)
- (\ type.equivalence = type.byte returnT)
- (\ type.equivalence = type.short returnT)
- (\ type.equivalence = type.int returnT)
- (\ type.equivalence = type.char returnT))
- _.IRETURN
-
- (\ type.equivalence = type.long returnT)
- _.LRETURN
-
- (\ type.equivalence = type.float returnT)
- _.FRETURN
-
- ## (\ type.equivalence = type.double returnT)
- _.DRETURN))))
+ (template.let [(unwrap_primitive <return> <type>)
+ [(|>> (_.unwrap <type>)
+ <return>)]]
+ (`` (cond (~~ (template [<return> <type>]
+ [(\ type.equivalence = <type> returnT)
+ (unwrap_primitive <return> <type>)]
+
+ [_.IRETURN type.boolean]
+ [_.IRETURN type.byte]
+ [_.IRETURN type.short]
+ [_.IRETURN type.int]
+ [_.IRETURN type.char]
+ [_.FRETURN type.float]
+ [_.LRETURN type.long]))
+
+ ## (\ type.equivalence = type.double returnT)
+ (unwrap_primitive _.DRETURN type.double)))))))
(def: class::anonymous
Handler
@@ -1007,33 +1085,33 @@
super_interfaces
inputsTS
overriden_methods])
- (do {@ phase.monad}
+ (do {! phase.monad}
[[context _] (generation.with_new_context archive (wrap []))
#let [[module_id artifact_id] context
anonymous_class_name (///.class_name context)
class (type.class anonymous_class_name (list))
total_environment (|> overriden_methods
## Get all the environments.
- (list@map product.left)
+ (list\map product.left)
## Combine them.
- list@join
+ list\join
## Remove duplicates.
(set.from_list synthesis.hash)
set.to_list)
global_mapping (|> total_environment
## Give them names as "foreign" variables.
list.enumeration
- (list@map (function (_ [id capture])
+ (list\map (function (_ [id capture])
[capture (#variable.Foreign id)]))
(dictionary.from_list synthesis.hash))
- normalized_methods (list@map (function (_ [environment
+ normalized_methods (list\map (function (_ [environment
[ownerT name
strict_fp? annotations vars
self_name arguments returnT exceptionsT
body]])
(let [local_mapping (|> environment
list.enumeration
- (list@map (function (_ [foreign_id capture])
+ (list\map (function (_ [foreign_id capture])
[(synthesis.variable/foreign foreign_id)
(|> global_mapping
(dictionary.get capture)
@@ -1044,26 +1122,26 @@
self_name arguments returnT exceptionsT
(normalize_method_body local_mapping body)]))
overriden_methods)]
- inputsTI (monad.map @ (generate_input generate archive) inputsTS)
+ inputsTI (monad.map ! (generate_input generate archive) inputsTS)
method_definitions (|> normalized_methods
- (monad.map @ (function (_ [ownerT name
- strict_fp? annotations vars
+ (monad.map ! (function (_ [ownerT name
+ strict_fp? annotations varsT
self_name arguments returnT exceptionsT
bodyS])
- (do @
+ (do !
[bodyG (generation.with_context artifact_id
- (generate archive bodyS))]
+ (generate archive bodyS))
+ #let [argumentsT (list\map product.right arguments)]]
(wrap (_def.method #$.Public
(if strict_fp?
($_ $.++M $.finalM $.strictM)
$.finalM)
name
- (type.method [vars
- (list@map product.right arguments)
- returnT
- exceptionsT])
- (|>> bodyG (returnI returnT)))))))
- (\ @ map _def.fuse))
+ (type.method [varsT argumentsT returnT exceptionsT])
+ (|>> (prepare_arguments 1 argumentsT)
+ bodyG
+ (returnI returnT)))))))
+ (\ ! map _def.fuse))
#let [directive [anonymous_class_name
(_def.class #$.V1_6 #$.Public $.finalC
anonymous_class_name (list)
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-05 04:59:47 +0000