aboutsummaryrefslogtreecommitdiff
path: root/new-luxc
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc')
-rw-r--r--new-luxc/source/luxc/lang/extension/analysis/host.jvm.lux295
-rw-r--r--new-luxc/source/luxc/lang/init.lux10
-rw-r--r--new-luxc/source/luxc/lang/translation.lux64
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux112
-rw-r--r--new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux100
-rw-r--r--new-luxc/test/test/luxc/lang/translation/jvm/procedure/host.jvm.lux20
-rw-r--r--new-luxc/test/test/luxc/lang/translation/jvm/reference.lux24
7 files changed, 300 insertions, 325 deletions
diff --git a/new-luxc/source/luxc/lang/extension/analysis/host.jvm.lux b/new-luxc/source/luxc/lang/extension/analysis/host.jvm.lux
index dba0e3e66..5acc0cd46 100644
--- a/new-luxc/source/luxc/lang/extension/analysis/host.jvm.lux
+++ b/new-luxc/source/luxc/lang/extension/analysis/host.jvm.lux
@@ -58,10 +58,6 @@
(exception: #export Too-Many-Candidates)
(exception: #export Cannot-Cast)
-(def: (cannot-cast to from)
- (-> Type Type Text)
- (format "From: " (%type from) "\n"
- " To: " (%type to)))
(exception: #export Cannot-Possibly-Be-Instance)
@@ -72,8 +68,6 @@
(exception: #export Type-Parameter-Mismatch)
(exception: #export Cannot-Correspond-Type-With-Class)
-(def: #export null-class Text "#Null")
-
(do-template [<name> <class>]
[(def: #export <name> Type (#.Primitive <class> (list)))]
@@ -348,7 +342,7 @@
(@.install "write" array-write)
)))
-(def: (object-null proc)
+(def: (object//null proc)
(-> Text ///.Analysis)
(function [analyse eval args]
(case args
@@ -361,7 +355,7 @@
_
(&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +0 (list.size args))))))
-(def: (object-null? proc)
+(def: (object//null? proc)
(-> Text ///.Analysis)
(function [analyse eval args]
(case args
@@ -376,7 +370,7 @@
_
(&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args))))))
-(def: (object-synchronized proc)
+(def: (object//synchronized proc)
(-> Text ///.Analysis)
(function [analyse eval args]
(case args
@@ -471,7 +465,7 @@
sub (load-class sub)]
(wrap (Class::isAssignableFrom [sub] super))))
-(def: (object-throw proc)
+(def: (object//throw proc)
(-> Text ///.Analysis)
(function [analyse eval args]
(case args
@@ -491,7 +485,7 @@
_
(&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args))))))
-(def: (object-class proc)
+(def: (object//class proc)
(-> Text ///.Analysis)
(function [analyse eval args]
(case args
@@ -509,7 +503,7 @@
_
(&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +1 (list.size args))))))
-(def: (object-instance? proc)
+(def: (object//instance? proc)
(-> Text ///.Analysis)
(function [analyse eval args]
(case args
@@ -532,18 +526,6 @@
_
(&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args))))))
-(def: object-procs
- @.Bundle
- (<| (@.prefix "object")
- (|> (dict.new text.Hash<Text>)
- (@.install "null" object-null)
- (@.install "null?" object-null?)
- (@.install "synchronized" object-synchronized)
- (@.install "throw" object-throw)
- (@.install "class" object-class)
- (@.install "instance?" object-instance?)
- )))
-
(def: type-descriptor
(-> java/lang/reflect/Type Text)
(java/lang/reflect/Type::getTypeName []))
@@ -622,16 +604,6 @@
## else
(&.throw Cannot-Convert-To-Lux-Type (type-descriptor java-type))))
-(type: Direction
- #In
- #Out)
-
-(def: (choose direction to from)
- (-> Direction Text Text Text)
- (case direction
- #In to
- #Out from))
-
(def: (correspond-type-params class type)
(-> (Class Object) Type (Meta Mappings))
(case type
@@ -661,64 +633,97 @@
_
(&.throw Non-JVM-Type (%type type))))
-(def: (cast direction to from)
- (-> Direction Type Type (Meta [Text Type]))
- (do macro.Monad<Meta>
- [to-name (check-jvm to)
- from-name (check-jvm from)]
- (cond (dict.contains? to-name boxes)
- (let [box (maybe.assume (dict.get to-name boxes))]
- (if (text/= box from-name)
- (wrap [(choose direction to-name from-name) (#.Primitive to-name (list))])
- (&.throw Cannot-Cast (cannot-cast to from))))
-
- (dict.contains? from-name boxes)
- (let [box (maybe.assume (dict.get from-name boxes))]
- (do @
- [[_ castT] (cast direction to (#.Primitive box (list)))]
- (wrap [(choose direction to-name from-name) castT])))
-
- (text/= to-name from-name)
- (wrap [(choose direction to-name from-name) from])
-
- (text/= null-class from-name)
- (wrap [(choose direction to-name from-name) to])
-
- ## else
- (do @
- [to-class (load-class to-name)
- from-class (load-class from-name)
- _ (&.assert Cannot-Cast (cannot-cast to from)
- (Class::isAssignableFrom [from-class] to-class))
- candiate-parents (monad.map @
- (function [java-type]
- (do @
- [class-name (java-type-to-class java-type)
- class (load-class class-name)]
- (wrap [java-type (Class::isAssignableFrom [class] to-class)])))
- (list& (Class::getGenericSuperclass [] from-class)
- (array.to-list (Class::getGenericInterfaces [] from-class))))]
- (case (|> candiate-parents
- (list.filter product.right)
- (list/map product.left))
- (#.Cons parent _)
- (do @
- [mapping (correspond-type-params from-class from)
- parentT (java-type-to-lux-type mapping parent)
- [_ castT] (cast direction to parentT)]
- (wrap [(choose direction to-name from-name) castT]))
-
- #.Nil
- (&.throw Cannot-Cast (cannot-cast to from)))))))
-
-(def: (infer-out outputT)
- (-> Type (Meta [Text Type]))
- (do macro.Monad<Meta>
- [expectedT macro.expected-type
- [unboxed castT] (cast #Out expectedT outputT)
- _ (&.with-type-env
- (tc.check expectedT castT))]
- (wrap [unboxed castT])))
+(def: (object//cast proc)
+ (-> Text ///.Analysis)
+ (function [analyse eval args]
+ (case args
+ (^ (list valueC))
+ (do macro.Monad<Meta>
+ [toT macro.expected-type
+ to-name (check-jvm toT)
+ [valueT valueA] (&common.with-unknown-type
+ (analyse valueC))
+ from-name (check-jvm valueT)
+ can-cast? (: (Meta Bool)
+ (case [from-name to-name]
+ (^template [<primitive> <object>]
+ (^or [<primitive> <object>]
+ [<object> <primitive>])
+ (do @
+ [_ (&.infer (#.Primitive to-name (list)))]
+ (wrap true)))
+ (["boolean" "java.lang.Boolean"]
+ ["byte" "java.lang.Byte"]
+ ["short" "java.lang.Short"]
+ ["int" "java.lang.Integer"]
+ ["long" "java.lang.Long"]
+ ["float" "java.lang.Float"]
+ ["double" "java.lang.Double"]
+ ["char" "java.lang.Character"])
+
+ _
+ (do @
+ [_ (&.assert Primitives-Are-Not-Objects from-name
+ (not (dict.contains? from-name boxes)))
+ _ (&.assert Primitives-Are-Not-Objects to-name
+ (not (dict.contains? to-name boxes)))
+ to-class (load-class to-name)]
+ (loop [[current-name currentT] [from-name valueT]]
+ (if (text/= to-name current-name)
+ (do @
+ [_ (&.infer toT)]
+ (wrap true))
+ (do @
+ [current-class (load-class current-name)
+ _ (&.assert Cannot-Cast (format "From class/primitive: " current-name "\n"
+ " To class/primitive: " to-name "\n"
+ " For value: " (%code valueC) "\n")
+ (Class::isAssignableFrom [current-class] to-class))
+ candiate-parents (monad.map @
+ (function [java-type]
+ (do @
+ [class-name (java-type-to-class java-type)
+ class (load-class class-name)]
+ (wrap [[class-name java-type] (Class::isAssignableFrom [class] to-class)])))
+ (list& (Class::getGenericSuperclass [] current-class)
+ (array.to-list (Class::getGenericInterfaces [] current-class))))]
+ (case (|> candiate-parents
+ (list.filter product.right)
+ (list/map product.left))
+ (#.Cons [next-name nextJT] _)
+ (do @
+ [mapping (correspond-type-params current-class currentT)
+ nextT (java-type-to-lux-type mapping nextJT)]
+ (recur [next-name nextT]))
+
+ #.Nil
+ (&.throw Cannot-Cast (format "From class/primitive: " from-name "\n"
+ " To class/primitive: " to-name "\n"
+ " For value: " (%code valueC) "\n")))
+ ))))))]
+ (if can-cast?
+ (wrap (la.procedure proc (list (code.text from-name)
+ (code.text to-name)
+ valueA)))
+ (&.throw Cannot-Cast (format "From class/primitive: " from-name "\n"
+ " To class/primitive: " to-name "\n"
+ " For value: " (%code valueC) "\n"))))
+
+ _
+ (&.throw Wrong-Syntax (wrong-syntax proc args)))))
+
+(def: object-procs
+ @.Bundle
+ (<| (@.prefix "object")
+ (|> (dict.new text.Hash<Text>)
+ (@.install "null" object//null)
+ (@.install "null?" object//null?)
+ (@.install "synchronized" object//synchronized)
+ (@.install "throw" object//throw)
+ (@.install "class" object//class)
+ (@.install "instance?" object//instance?)
+ (@.install "cast" object//cast)
+ )))
(def: (find-field class-name field-name)
(-> Text Text (Meta [(Class Object) Field]))
@@ -782,29 +787,7 @@
(wrap [fieldT (Modifier::isFinal [modifiers])]))
(&.throw Not-Virtual-Field (format class-name "#" field-name)))))
-(def: (analyse-object class analyse sourceC)
- (-> Text &.Analyser Code (Meta [Type la.Analysis]))
- (do macro.Monad<Meta>
- [target-class (load-class class)
- targetT (java-type-to-lux-type fresh-mappings
- (:! java/lang/reflect/Type
- target-class))
- [sourceT sourceA] (&common.with-unknown-type
- (analyse sourceC))
- [unboxed castT] (cast #Out targetT sourceT)
- _ (&.assert Cannot-Cast (cannot-cast targetT sourceT)
- (not (dict.contains? unboxed boxes)))]
- (wrap [castT sourceA])))
-
-(def: (analyse-input analyse targetT sourceC)
- (-> &.Analyser Type Code (Meta [Type Text la.Analysis]))
- (do macro.Monad<Meta>
- [[sourceT sourceA] (&common.with-unknown-type
- (analyse sourceC))
- [unboxed castT] (cast #In targetT sourceT)]
- (wrap [castT unboxed sourceA])))
-
-(def: (static-get proc)
+(def: (static//get proc)
(-> Text ///.Analysis)
(function [analyse eval args]
(case args
@@ -812,10 +795,8 @@
(case [classC fieldC]
[[_ (#.Text class)] [_ (#.Text field)]]
(do macro.Monad<Meta>
- [[fieldT final?] (static-field class field)
- [unboxed castT] (infer-out fieldT)]
- (wrap (la.procedure proc (list (code.text class) (code.text field)
- (code.text unboxed)))))
+ [[fieldT final?] (static-field class field)]
+ (wrap (la.procedure proc (list (code.text class) (code.text field)))))
_
(&.throw Wrong-Syntax (wrong-syntax proc args)))
@@ -823,7 +804,7 @@
_
(&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +2 (list.size args))))))
-(def: (static-put proc)
+(def: (static//put proc)
(-> Text ///.Analysis)
(function [analyse eval args]
(case args
@@ -835,11 +816,9 @@
[fieldT final?] (static-field class field)
_ (&.assert Cannot-Set-Final-Field (format class "#" field)
(not final?))
- [valueT unboxed valueA] (analyse-input analyse fieldT valueC)
- _ (&.with-type-env
- (tc.check fieldT valueT))]
- (wrap (la.procedure proc (list (code.text class) (code.text field)
- (code.text unboxed) valueA))))
+ valueA (&.with-type fieldT
+ (analyse valueC))]
+ (wrap (la.procedure proc (list (code.text class) (code.text field) valueA))))
_
(&.throw Wrong-Syntax (wrong-syntax proc args)))
@@ -847,7 +826,7 @@
_
(&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +3 (list.size args))))))
-(def: (virtual-get proc)
+(def: (virtual//get proc)
(-> Text ///.Analysis)
(function [analyse eval args]
(case args
@@ -855,11 +834,10 @@
(case [classC fieldC]
[[_ (#.Text class)] [_ (#.Text field)]]
(do macro.Monad<Meta>
- [[objectT objectA] (analyse-object class analyse objectC)
- [fieldT final?] (virtual-field class field objectT)
- [unboxed castT] (infer-out fieldT)]
- (wrap (la.procedure proc (list (code.text class) (code.text field)
- (code.text unboxed) objectA))))
+ [[objectT objectA] (&common.with-unknown-type
+ (analyse objectC))
+ [fieldT final?] (virtual-field class field objectT)]
+ (wrap (la.procedure proc (list (code.text class) (code.text field) objectA))))
_
(&.throw Wrong-Syntax (wrong-syntax proc args)))
@@ -867,7 +845,7 @@
_
(&.throw @.Incorrect-Procedure-Arity (@.wrong-arity proc +3 (list.size args))))))
-(def: (virtual-put proc)
+(def: (virtual//put proc)
(-> Text ///.Analysis)
(function [analyse eval args]
(case args
@@ -875,13 +853,15 @@
(case [classC fieldC]
[[_ (#.Text class)] [_ (#.Text field)]]
(do macro.Monad<Meta>
- [[objectT objectA] (analyse-object class analyse objectC)
+ [[objectT objectA] (&common.with-unknown-type
+ (analyse objectC))
_ (&.infer objectT)
[fieldT final?] (virtual-field class field objectT)
_ (&.assert Cannot-Set-Final-Field (format class "#" field)
(not final?))
- [valueT unboxed valueA] (analyse-input analyse fieldT valueC)]
- (wrap (la.procedure proc (list (code.text class) (code.text field) (code.text unboxed) valueA objectA))))
+ valueA (&.with-type fieldT
+ (analyse valueC))]
+ (wrap (la.procedure proc (list (code.text class) (code.text field) valueA objectA))))
_
(&.throw Wrong-Syntax (wrong-syntax proc args)))
@@ -1101,16 +1081,6 @@
(list/map (function [[type value]]
(la.product (list type value))))))
-(def: (sub-type-analyser analyse)
- (-> &.Analyser &.Analyser)
- (function [argC]
- (do macro.Monad<Meta>
- [[argT argA] (&common.with-unknown-type
- (analyse argC))
- expectedT macro.expected-type
- [unboxed castT] (cast #In expectedT argT)]
- (wrap argA))))
-
(def: (invoke//static proc)
(-> Text ///.Analysis)
(function [analyse eval args]
@@ -1120,10 +1090,10 @@
(do macro.Monad<Meta>
[#let [argsT (list/map product.left argsTC)]
[methodT exceptionsT] (methods class method #Static argsT)
- [outputT argsA] (inferenceA.general (sub-type-analyser analyse) methodT (list/map product.right argsTC))
- [unboxed castT] (infer-out outputT)]
+ [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC))
+ outputJC (check-jvm outputT)]
(wrap (la.procedure proc (list& (code.text class) (code.text method)
- (code.text unboxed) (decorate-inputs argsT argsA)))))
+ (code.text outputJC) (decorate-inputs argsT argsA)))))
_
(&.throw Wrong-Syntax (wrong-syntax proc args)))))
@@ -1137,16 +1107,16 @@
(do macro.Monad<Meta>
[#let [argsT (list/map product.left argsTC)]
[methodT exceptionsT] (methods class method #Virtual argsT)
- [outputT allA] (inferenceA.general (sub-type-analyser analyse) methodT (list& objectC (list/map product.right argsTC)))
+ [outputT allA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC)))
#let [[objectA argsA] (case allA
(#.Cons objectA argsA)
[objectA argsA]
_
(undefined))]
- [unboxed castT] (infer-out outputT)]
+ outputJC (check-jvm outputT)]
(wrap (la.procedure proc (list& (code.text class) (code.text method)
- (code.text unboxed) objectA (decorate-inputs argsT argsA)))))
+ (code.text outputJC) objectA (decorate-inputs argsT argsA)))))
_
(&.throw Wrong-Syntax (wrong-syntax proc args)))))
@@ -1160,10 +1130,10 @@
(do macro.Monad<Meta>
[#let [argsT (list/map product.left argsTC)]
[methodT exceptionsT] (methods class method #Special argsT)
- [outputT argsA] (inferenceA.general (sub-type-analyser analyse) methodT (list& objectC (list/map product.right argsTC)))
- [unboxed castT] (infer-out outputT)]
+ [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC)))
+ outputJC (check-jvm outputT)]
(wrap (la.procedure proc (list& (code.text class) (code.text method)
- (code.text unboxed) (decorate-inputs argsT argsA)))))
+ (code.text outputJC) (decorate-inputs argsT argsA)))))
_
(&.throw Wrong-Syntax (wrong-syntax proc args)))))
@@ -1180,10 +1150,10 @@
_ (&.assert Non-Interface class-name
(Modifier::isInterface [(Class::getModifiers [] class)]))
[methodT exceptionsT] (methods class-name method #Interface argsT)
- [outputT argsA] (inferenceA.general (sub-type-analyser analyse) methodT (list& objectC (list/map product.right argsTC)))
- [unboxed castT] (infer-out outputT)]
+ [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC)))
+ outputJC (check-jvm outputT)]
(wrap (la.procedure proc
- (list& (code.text class-name) (code.text method) (code.text unboxed)
+ (list& (code.text class-name) (code.text method) (code.text outputJC)
(decorate-inputs argsT argsA)))))
_
@@ -1198,8 +1168,7 @@
(do macro.Monad<Meta>
[#let [argsT (list/map product.left argsTC)]
[methodT exceptionsT] (constructor-methods class argsT)
- [outputT argsA] (inferenceA.general (sub-type-analyser analyse) methodT (list/map product.right argsTC))
- [unboxed castT] (infer-out outputT)]
+ [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC))]
(wrap (la.procedure proc (list& (code.text class) (decorate-inputs argsT argsA)))))
_
@@ -1211,12 +1180,12 @@
(|> (dict.new text.Hash<Text>)
(dict.merge (<| (@.prefix "static")
(|> (dict.new text.Hash<Text>)
- (@.install "get" static-get)
- (@.install "put" static-put))))
+ (@.install "get" static//get)
+ (@.install "put" static//put))))
(dict.merge (<| (@.prefix "virtual")
(|> (dict.new text.Hash<Text>)
- (@.install "get" virtual-get)
- (@.install "put" virtual-put))))
+ (@.install "get" virtual//get)
+ (@.install "put" virtual//put))))
(dict.merge (<| (@.prefix "invoke")
(|> (dict.new text.Hash<Text>)
(@.install "static" invoke//static)
diff --git a/new-luxc/source/luxc/lang/init.lux b/new-luxc/source/luxc/lang/init.lux
index 55e02d0b6..a34399cc8 100644
--- a/new-luxc/source/luxc/lang/init.lux
+++ b/new-luxc/source/luxc/lang/init.lux
@@ -2,6 +2,10 @@
lux
[//]
(// [".L" extension]
+ (extension [".E" analysis]
+ [".E" synthesis]
+ [".E" translation]
+ [".E" statement])
(translation (jvm [".T" common]))))
(def: #export (cursor file)
@@ -41,5 +45,9 @@
#.expected #.None
#.seed +0
#.scope-type-vars (list)
- #.extensions (:! Void extensionL.fresh)
+ #.extensions (:! Void
+ {#extensionL.analysis analysisE.defaults
+ #extensionL.synthesis synthesisE.defaults
+ #extensionL.translation translationE.defaults
+ #extensionL.statement statementE.defaults})
#.host (:! Void host)})
diff --git a/new-luxc/source/luxc/lang/translation.lux b/new-luxc/source/luxc/lang/translation.lux
index 30c4ec33c..8c42c2a71 100644
--- a/new-luxc/source/luxc/lang/translation.lux
+++ b/new-luxc/source/luxc/lang/translation.lux
@@ -27,22 +27,18 @@
[".L" macro]
[".L" extension]
[".L" init]
- (extension [".E" analysis]
- [".E" synthesis]
- [".E" translation]
- [".E" statement])
(host ["$" jvm])
(analysis [".A" expression]
[".A" common])
(synthesis [".S" expression])
["&." eval]))
- (/ [js]
- (js [".T" runtime]
- [".T" statement]
- ## [".T" common #+ Artifacts]
- [".T" expression]
- [".T" eval]
- [".T" imports])))
+ (/ ## [js]
+ (jvm [".T" runtime]
+ [".T" statement]
+ [".T" common #+ Artifacts]
+ [".T" expression]
+ [".T" eval]
+ [".T" imports])))
(def: analyse
(&.Analyser)
@@ -53,8 +49,8 @@
(exception: #export Invalid-Macro)
(def: (process-annotations annsC)
- (-> Code (Meta [js.Expression
- ## $.Inst
+ (-> Code (Meta [## js.Expression
+ $.Inst
Code]))
(do macro.Monad<Meta>
[[_ annsA] (&.with-scope
@@ -242,39 +238,27 @@
(def: (initialize sources target)
(-> (List File) File (Process Compiler))
(do io.Monad<Process>
- [compiler (case (runtimeT.translate (initL.compiler (io.run js.init))
- ## (initL.compiler (io.run hostL.init-host))
+ [compiler (case (runtimeT.translate ## (initL.compiler (io.run js.init))
+ (initL.compiler (io.run hostL.init-host))
)
- (#e.Success [compiler disk-write])
- (do @
- [_ (&io.prepare-target target)
- _ disk-write
- ## _ (cache/io.pre-load sources target (commonT.load-definition compiler))
- ]
- (wrap (|> compiler
- (set@ [#.info #.mode] #.Build)
- (set@ #.extensions
- (:! Void
- {#extensionL.analysis analysisE.defaults
- #extensionL.synthesis synthesisE.defaults
- #extensionL.translation translationE.defaults
- #extensionL.statement statementE.defaults})))))
-
- ## (#e.Success [compiler [runtime-bc function-bc]])
+ ## (#e.Success [compiler disk-write])
## (do @
## [_ (&io.prepare-target target)
- ## ## _ (&io.write target (format hostL.runtime-class ".class") runtime-bc)
- ## ## _ (&io.write target (format hostL.function-class ".class") function-bc)
+ ## _ disk-write
## ## _ (cache/io.pre-load sources target (commonT.load-definition compiler))
## ]
## (wrap (|> compiler
- ## (set@ [#.info #.mode] #.Build)
- ## (set@ #.extensions
- ## (:! Void
- ## {#extensionL.analysis analysisE.defaults
- ## #extensionL.synthesis synthesisE.defaults
- ## #extensionL.translation translationE.defaults
- ## #extensionL.statement statementE.defaults})))))
+ ## (set@ [#.info #.mode] #.Build))))
+
+ (#e.Success [compiler [runtime-bc function-bc]])
+ (do @
+ [_ (&io.prepare-target target)
+ ## _ (&io.write target (format hostL.runtime-class ".class") runtime-bc)
+ ## _ (&io.write target (format hostL.function-class ".class") function-bc)
+ ## _ (cache/io.pre-load sources target (commonT.load-definition compiler))
+ ]
+ (wrap (|> compiler
+ (set@ [#.info #.mode] #.Build))))
(#e.Error error)
(io.fail error))]
diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux
index f585fb10c..609a0833c 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux
@@ -424,6 +424,35 @@
_
(&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))
+(def: (object//cast proc translate inputs)
+ (-> Text @.Proc)
+ (case inputs
+ (^ (list [_ (#.Text from)] [_ (#.Text to)] valueS))
+ (do macro.Monad<Meta>
+ [valueI (translate valueS)]
+ (case [from to]
+ ## Wrap
+ (^template [<primitive> <object> <type>]
+ [<primitive> <object>]
+ (wrap (|>> valueI ($i.wrap <type>)))
+
+ [<object> <primitive>]
+ (wrap (|>> valueI ($i.unwrap <type>))))
+ (["boolean" "java.lang.Boolean" #$.Boolean]
+ ["byte" "java.lang.Byte" #$.Byte]
+ ["short" "java.lang.Short" #$.Short]
+ ["int" "java.lang.Integer" #$.Int]
+ ["long" "java.lang.Long" #$.Long]
+ ["float" "java.lang.Float" #$.Float]
+ ["double" "java.lang.Double" #$.Double]
+ ["char" "java.lang.Character" #$.Char])
+
+ _
+ (wrap valueI)))
+
+ _
+ (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))
+
(def: object-procs
@.Bundle
(<| (@.prefix "object")
@@ -434,6 +463,7 @@
(@.install "throw" (@.unary object//throw))
(@.install "class" object//class)
(@.install "instance?" object//instance?)
+ (@.install "cast" object//cast)
)))
(def: primitives
@@ -607,36 +637,15 @@
(#e.Success type)
(macro/wrap type)))
-(def: (prepare-input inputT inputI)
- (-> $.Type $.Inst $.Inst)
- (case inputT
- (#$.Primitive primitive)
- (|>> inputI ($i.unwrap primitive))
-
- (#$.Generic generic)
- (case generic
- (^or (#$.Var _) (#$.Wildcard _))
- (|>> inputI ($i.CHECKCAST "java.lang.Object"))
-
- (#$.Class class-name _)
- (|>> inputI ($i.CHECKCAST class-name)))
-
- _
- (|>> inputI ($i.CHECKCAST ($t.descriptor inputT)))))
-
-(def: (translate-args translate argsS)
- (-> (-> ls.Synthesis (Meta $.Inst)) (List ls.Synthesis)
- (Meta (List [$.Type $.Inst])))
- (case argsS
- #.Nil
- (macro/wrap #.Nil)
-
- (^ (list& [_ (#.Tuple (list [_ (#.Text argD)] argS))] tail))
+(def: (translate-arg translate argS)
+ (-> (-> ls.Synthesis (Meta $.Inst)) ls.Synthesis
+ (Meta [$.Type $.Inst]))
+ (case argS
+ (^ [_ (#.Tuple (list [_ (#.Text argD)] argS))])
(do macro.Monad<Meta>
[argT (translate-type argD)
- argI (:: @ map (prepare-input argT) (translate argS))
- =tail (translate-args translate tail)]
- (wrap (list& [argT argI] =tail)))
+ argI (translate argS)]
+ (wrap [argT argI]))
_
(&.throw Invalid-Syntax-For-Argument-Generation "")))
@@ -650,34 +659,18 @@
_
(macro/map (|>> #.Some) (translate-type description))))
-(def: (prepare-return returnT returnI)
- (-> (Maybe $.Type) $.Inst $.Inst)
- (case returnT
- #.None
- (|>> returnI
- ($i.string hostL.unit))
-
- (#.Some type)
- (case type
- (#$.Primitive primitive)
- (|>> returnI ($i.wrap primitive))
-
- _
- returnI)))
-
(def: (invoke//static proc translate inputs)
(-> Text @.Proc)
(case inputs
(^ (list& [_ (#.Text class)] [_ (#.Text method)]
[_ (#.Text unboxed)] argsS))
(do macro.Monad<Meta>
- [argsTI (translate-args translate argsS)
- returnT (method-return-type unboxed)
- #let [callI (|>> ($i.fuse (list/map product.right argsTI))
- ($i.INVOKESTATIC class method
- ($t.method (list/map product.left argsTI) returnT (list))
- false))]]
- (wrap (prepare-return returnT callI)))
+ [argsTI (monad.map @ (translate-arg translate) argsS)
+ returnT (method-return-type unboxed)]
+ (wrap (|>> ($i.fuse (list/map product.right argsTI))
+ ($i.INVOKESTATIC class method
+ ($t.method (list/map product.left argsTI) returnT (list))
+ false))))
_
(&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))
@@ -690,15 +683,14 @@
[_ (#.Text unboxed)] objectS argsS))
(do macro.Monad<Meta>
[objectI (translate objectS)
- argsTI (translate-args translate argsS)
- returnT (method-return-type unboxed)
- #let [callI (|>> objectI
- ($i.CHECKCAST class)
- ($i.fuse (list/map product.right argsTI))
- (<invoke> class method
- ($t.method (list/map product.left argsTI) returnT (list))
- <interface?>))]]
- (wrap (prepare-return returnT callI)))
+ argsTI (monad.map @ (translate-arg translate) argsS)
+ returnT (method-return-type unboxed)]
+ (wrap (|>> objectI
+ ($i.CHECKCAST class)
+ ($i.fuse (list/map product.right argsTI))
+ (<invoke> class method
+ ($t.method (list/map product.left argsTI) returnT (list))
+ <interface?>))))
_
(&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))]
@@ -713,7 +705,7 @@
(case inputs
(^ (list& [_ (#.Text class)] argsS))
(do macro.Monad<Meta>
- [argsTI (translate-args translate argsS)]
+ [argsTI (monad.map @ (translate-arg translate) argsS)]
(wrap (|>> ($i.NEW class)
$i.DUP
($i.fuse (list/map product.right argsTI))
diff --git a/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux b/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux
index 382ad87e2..7b2b993d2 100644
--- a/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux
+++ b/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux
@@ -50,6 +50,26 @@
[failure false true]
)
+(do-template [<name> <success> <failure>]
+ [(def: (<name> syntax output-type)
+ (-> Code Type Bool)
+ (|> (do Monad<Meta>
+ [runtime-bytecode @runtime.translate]
+ (&.with-scope
+ (&.with-type output-type
+ (expressionA.analyser evalL.eval syntax))))
+ (&.with-current-module "")
+ (macro.run (init-compiler []))
+ (case> (#e.Success _)
+ <success>
+
+ (#e.Error error)
+ <failure>)))]
+
+ [success' true false]
+ [failure' false true]
+ )
+
(context: "Conversions [double + float]."
(with-expansions [<conversions> (do-template [<procedure> <from> <to>]
[(test (format <procedure> " SUCCESS")
@@ -286,9 +306,9 @@
(list arrayC)
Nat))
(test "jvm array read"
- (success "jvm array read"
- (list arrayC (code.nat idx))
- boxedT))
+ (success' (` ("jvm object cast"
+ ("jvm array read" (~ arrayC) (~ (code.nat idx)))))
+ boxedT))
(test "jvm array write"
(success "jvm array write"
(list arrayC (code.nat idx) (`' ("lux coerce" (~ boxedTC) [])))
@@ -407,8 +427,9 @@
(success "jvm member static put"
(list (code.text "java.awt.datatransfer.DataFlavor")
(code.text "allHtmlFlavor")
- (`' ("lux check" (+0 "javax.activation.ActivationDataFlavor" (+0))
- ("jvm object null"))))
+ (`' ("jvm object cast"
+ ("lux check" (+0 "javax.activation.ActivationDataFlavor" (+0))
+ ("jvm object null")))))
Unit))
))
@@ -450,8 +471,9 @@
(success "jvm member virtual put"
(list (code.text "java.awt.GridBagConstraints")
(code.text "insets")
- (`' ("lux check" (+0 "javax.swing.plaf.InsetsUIResource" (+0))
- ("jvm object null")))
+ (`' ("jvm object cast"
+ ("lux check" (+0 "javax.swing.plaf.InsetsUIResource" (+0))
+ ("jvm object null"))))
(`' ("lux check" (+0 "java.awt.GridBagConstraints" (+0))
("jvm object null"))))
(primitive "java.awt.GridBagConstraints")))
@@ -475,8 +497,9 @@
(success "jvm member virtual put"
(list (code.text "javax.accessibility.AccessibleAttributeSequence")
(code.text "startIndex")
- (`' ("lux check" (+0 "java.lang.Integer" (+0))
- ("jvm object null")))
+ (`' ("jvm object cast"
+ ("lux check" (+0 "java.lang.Integer" (+0))
+ ("jvm object null"))))
(`' ("lux check" (+0 "javax.accessibility.AccessibleAttributeSequence" (+0))
("jvm object null"))))
(primitive "javax.accessibility.AccessibleAttributeSequence")))
@@ -486,45 +509,38 @@
(let [longC (' ("lux coerce" (+0 "java.lang.Long" (+0))
+123))
intC (`' ("jvm convert long-to-int" (~ longC)))
+ stringC (' ("lux coerce" (+0 "java.lang.String" (+0))
+ "YOLO"))
objectC (`' ("lux check" (+0 "java.util.ArrayList" (+1 (+0 "java.lang.Long" (+0)) (+0)))
("jvm member invoke constructor" "java.util.ArrayList"
- ["int" (~ intC)])))]
+ ["int" ("jvm object cast" (~ intC))])))]
($_ seq
(test "jvm member invoke static"
- (success "jvm member invoke static"
- (list (code.text "java.lang.Long")
- (code.text "decode")
- (code.tuple (list (' "java.lang.String")
- (' ("lux coerce" (+0 "java.lang.String" (+0))
- "YOLO")))))
- (#.Primitive "java.lang.Long" (list))))
+ (success' (` ("jvm member invoke static"
+ "java.lang.Long" "decode"
+ ["java.lang.String" (~ stringC)]))
+ (#.Primitive "java.lang.Long" (list))))
(test "jvm member invoke virtual"
- (success "jvm member invoke virtual"
- (list (code.text "java.lang.Object")
- (code.text "equals")
- longC
- (code.tuple (list (' "java.lang.Object")
- longC)))
- (#.Primitive "java.lang.Boolean" (list))))
+ (success' (` ("jvm object cast"
+ ("jvm member invoke virtual"
+ "java.lang.Object" "equals"
+ ("jvm object cast" (~ longC)) ["java.lang.Object" ("jvm object cast" (~ longC))])))
+ (#.Primitive "java.lang.Boolean" (list))))
(test "jvm member invoke special"
- (success "jvm member invoke special"
- (list (code.text "java.lang.Long")
- (code.text "equals")
- longC
- (code.tuple (list (' "java.lang.Object")
- longC)))
- (#.Primitive "java.lang.Boolean" (list))))
+ (success' (` ("jvm object cast"
+ ("jvm member invoke special"
+ "java.lang.Long" "equals"
+ ("jvm object cast" (~ longC)) ["java.lang.Object" ("jvm object cast" (~ longC))])))
+ (#.Primitive "java.lang.Boolean" (list))))
(test "jvm member invoke interface"
- (success "jvm member invoke interface"
- (list (code.text "java.util.Collection")
- (code.text "add")
- objectC
- (code.tuple (list (' "java.lang.Object")
- longC)))
- (#.Primitive "java.lang.Boolean" (list))))
+ (success' (` ("jvm object cast"
+ ("jvm member invoke interface"
+ "java.util.Collection" "add"
+ ("jvm object cast" (~ objectC)) ["java.lang.Object" ("jvm object cast" (~ longC))])))
+ (#.Primitive "java.lang.Boolean" (list))))
(test "jvm member invoke constructor"
- (success "jvm member invoke constructor"
- (list (code.text "java.util.ArrayList")
- (code.tuple (list (' "int") intC)))
- (All [a] (#.Primitive "java.util.ArrayList" (list a)))))
+ (success' (` ("jvm member invoke constructor"
+ "java.util.ArrayList"
+ ["int" ("jvm object cast" (~ intC))]))
+ (All [a] (#.Primitive "java.util.ArrayList" (list a)))))
)))
diff --git a/new-luxc/test/test/luxc/lang/translation/jvm/procedure/host.jvm.lux b/new-luxc/test/test/luxc/lang/translation/jvm/procedure/host.jvm.lux
index a8e53e79e..0db10f82a 100644
--- a/new-luxc/test/test/luxc/lang/translation/jvm/procedure/host.jvm.lux
+++ b/new-luxc/test/test/luxc/lang/translation/jvm/procedure/host.jvm.lux
@@ -520,7 +520,8 @@
[sample-short (|> r.int (:: @ map (|>> int/abs (i/% 100))))
sample-string (r.text +5)
other-sample-string (r.text +5)
- #let [shortS (` ["short" ("jvm convert long-to-short" (~ (code.int sample-short)))])
+ #let [shortS (` ["short" ("jvm object cast" "java.lang.Short" "short"
+ ("jvm convert long-to-short" (~ (code.int sample-short))))])
stringS (` ["java.lang.String" (~ (code.text sample-string))])
type-codeS (` ["org.omg.CORBA.TypeCode" ("jvm object null")])
idl-typeS (` ["org.omg.CORBA.IDLType" ("jvm object null")])
@@ -587,13 +588,16 @@
(do @
[sample (|> r.int (:: @ map (|>> int/abs (i/% 100))))
#let [object-longS (` ["java.lang.Object" (~ (code.int sample))])
- intS (` ["int" ("jvm convert long-to-int" (~ (code.int sample)))])
+ intS (` ["int" ("jvm object cast" "java.lang.Integer" "int"
+ ("jvm convert long-to-int" (~ (code.int sample))))])
coded-intS (` ["java.lang.String" (~ (code.text (int/encode sample)))])
array-listS (` ("jvm member invoke constructor" "java.util.ArrayList" (~ intS)))]]
($_ seq
(test "jvm member invoke static"
(|> (do macro.Monad<Meta>
- [sampleI (expressionT.translate (` ("jvm member invoke static" "java.lang.Long" "decode" "java.lang.Long" (~ coded-intS))))]
+ [sampleI (expressionT.translate (` ("jvm member invoke static" "java.lang.Long"
+ "decode" "java.lang.Long"
+ (~ coded-intS))))]
(@eval.eval sampleI))
(lang.with-current-module "")
(macro.run (init-compiler []))
@@ -604,8 +608,9 @@
false)))
(test "jvm member invoke virtual"
(|> (do macro.Monad<Meta>
- [sampleI (expressionT.translate (` ("jvm member invoke virtual" "java.lang.Object" "equals" "boolean"
- (~ (code.int sample)) (~ object-longS))))]
+ [sampleI (expressionT.translate (` ("jvm object cast" "boolean" "java.lang.Boolean"
+ ("jvm member invoke virtual" "java.lang.Object" "equals" "boolean"
+ (~ (code.int sample)) (~ object-longS)))))]
(@eval.eval sampleI))
(lang.with-current-module "")
(macro.run (init-compiler []))
@@ -616,8 +621,9 @@
false)))
(test "jvm member invoke interface"
(|> (do macro.Monad<Meta>
- [sampleI (expressionT.translate (` ("jvm member invoke interface" "java.util.Collection" "add" "boolean"
- (~ array-listS) (~ object-longS))))]
+ [sampleI (expressionT.translate (` ("jvm object cast" "boolean" "java.lang.Boolean"
+ ("jvm member invoke interface" "java.util.Collection" "add" "boolean"
+ (~ array-listS) (~ object-longS)))))]
(@eval.eval sampleI))
(lang.with-current-module "")
(macro.run (init-compiler []))
diff --git a/new-luxc/test/test/luxc/lang/translation/jvm/reference.lux b/new-luxc/test/test/luxc/lang/translation/jvm/reference.lux
index ddbefd8d9..8de6c4fa5 100644
--- a/new-luxc/test/test/luxc/lang/translation/jvm/reference.lux
+++ b/new-luxc/test/test/luxc/lang/translation/jvm/reference.lux
@@ -21,21 +21,19 @@
[".T" runtime]))))
(test/luxc common))
-(def: nilI $.Inst runtimeT.noneI)
-
-(def: cursorI
- $.Inst
- (|>> ($i.int 3)
- ($i.array runtimeT.$Tuple)
- $i.DUP ($i.int 0) ($i.string "") $i.AASTORE
- $i.DUP ($i.int 1) ($i.long 0) ($i.wrap #$.Long) $i.AASTORE
- $i.DUP ($i.int 2) ($i.long 0) ($i.wrap #$.Long) $i.AASTORE))
+(def: ident-part
+ (r.Random Text)
+ (|> (r.text +5)
+ (r.filter (function [sample]
+ (not (or (text.contains? "/" sample)
+ (text.contains? "[" sample)
+ (text.contains? "]" sample)))))))
(context: "Definitions."
(<| (times +100)
(do @
- [module-name (|> (r.text +5) (r.filter (|>> (text.contains? "/") not)))
- def-name (r.text +5)
+ [module-name ident-part
+ def-name ident-part
def-value r.int
#let [valueI (|>> ($i.long def-value) ($i.wrap #$.Long))]]
($_ seq
@@ -57,7 +55,8 @@
(context: "Variables."
(<| (times +100)
(do @
- [register (|> r.nat (:: @ map (n/% +100)))
+ [module-name (|> (r.text +5) (r.filter (|>> (text.contains? "/") not)))
+ register (|> r.nat (:: @ map (n/% +100)))
value r.int]
($_ seq
(test "Can refer to local variables/registers."
@@ -67,6 +66,7 @@
(code.int value)
(` ((~ (code.int (nat-to-int register))))))]
(evalT.eval sampleI))
+ (lang.with-current-module "")
(macro.run (init-compiler []))
(case> (#e.Success outputT)
(i/= value (:! Int outputT))