aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/analyser
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/analyser')
-rw-r--r--new-luxc/source/luxc/analyser/procedure/host.jvm.lux41
1 files changed, 26 insertions, 15 deletions
diff --git a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
index a4cc20400..1592827db 100644
--- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
@@ -24,7 +24,7 @@
["@" ../common]
)
-(def: null-class Text "#Null")
+(def: #export null-class Text "#Null")
(do-template [<name> <class>]
[(def: #export <name> Type (#;Host <class> (list)))]
@@ -591,28 +591,38 @@
## else
(&;throw Cannot-Convert-To-Lux-Type (type-descriptor java-type))))
-(def: (cast to from)
- (-> Type Type (Lux [Text Type]))
+(type: Direction
+ #In
+ #Out)
+
+(def: (choose direction to from)
+ (-> Direction Text Text Text)
+ (case direction
+ #In to
+ #Out from))
+
+(def: (cast direction to from)
+ (-> Direction Type Type (Lux [Text Type]))
(do macro;Monad<Lux>
[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 [box (#;Host to-name (list))])
+ (wrap [(choose direction to-name from-name) (#;Host to-name (list))])
(&;throw Cannot-Cast-To-Primitive (format from-name " => " to-name))))
(dict;contains? from-name boxes)
(let [box (maybe;assume (dict;get from-name boxes))]
(do @
- [[_ castT] (cast to (#;Host box (list)))]
- (wrap [from-name castT])))
+ [[_ castT] (cast direction to (#;Host box (list)))]
+ (wrap [(choose direction to-name from-name) castT])))
(text/= to-name from-name)
- (wrap ["" from])
+ (wrap [(choose direction to-name from-name) from])
(text/= null-class from-name)
- (wrap ["" to])
+ (wrap [(choose direction to-name from-name) to])
## else
(do @
@@ -633,8 +643,9 @@
(list/map product;left))
(#;Cons parent _)
(do @
- [parentT (java-type-to-lux-type fresh-mappings parent)]
- (cast to parentT))
+ [parentT (java-type-to-lux-type fresh-mappings parent)
+ [_ castT] (cast direction to parentT)]
+ (wrap [(choose direction to-name from-name) castT]))
#;Nil
(&;fail (format "No valid path between " (%type from) "and " (%type to) ".")))))))
@@ -709,9 +720,9 @@
(analyse sourceC))
sourceT (&;with-type-env
(tc;read var-id))
- [unboxed castT] (cast targetT sourceT)
+ [unboxed castT] (cast #Out targetT sourceT)
_ (&;assert (format "Object cannot be a primitive: " unboxed)
- (text;empty? unboxed))]
+ (not (dict;contains? unboxed boxes)))]
(wrap [castT sourceA]))))
(def: (analyse-input analyse targetT sourceC)
@@ -722,7 +733,7 @@
(analyse sourceC))
sourceT (&;with-type-env
(tc;read var-id))
- [unboxed castT] (cast targetT sourceT)]
+ [unboxed castT] (cast #In targetT sourceT)]
(wrap [castT unboxed sourceA]))))
(def: (static-get proc)
@@ -735,7 +746,7 @@
(do macro;Monad<Lux>
[[fieldT final?] (static-field class field)
expectedT macro;expected-type
- [unboxed castT] (cast expectedT fieldT)
+ [unboxed castT] (cast #Out expectedT fieldT)
_ (&;with-type-env
(tc;check expectedT castT))]
(wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed)))))
@@ -780,7 +791,7 @@
[[objectT objectA] (analyse-object class analyse objectC)
[fieldT final?] (virtual-field class field objectT)
expectedT macro;expected-type
- [unboxed castT] (cast expectedT fieldT)
+ [unboxed castT] (cast #Out expectedT fieldT)
_ (&;with-type-env
(tc;check expectedT castT))]
(wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed) objectA))))