aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source
diff options
context:
space:
mode:
authorEduardo Julian2017-10-26 19:21:17 -0400
committerEduardo Julian2017-10-26 19:21:17 -0400
commit64ac2f552ec9e19131fc9671f14d14b0651cd988 (patch)
tree2fb9bc0a82f2d8e8ffc9036f9cb304394ea7d579 /new-luxc/source
parentcb54d53f06cb8d047e1460f0a9db63a594c5baf9 (diff)
- Fixed some compiler tests.
Diffstat (limited to 'new-luxc/source')
-rw-r--r--new-luxc/source/luxc/analyser/procedure/host.jvm.lux2
-rw-r--r--new-luxc/source/luxc/generator/procedure/host.jvm.lux12
-rw-r--r--new-luxc/source/luxc/generator/runtime.jvm.lux60
3 files changed, 53 insertions, 21 deletions
diff --git a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
index e45e7d807..84592d4ee 100644
--- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
@@ -866,7 +866,7 @@
[valueT unboxed valueA] (analyse-input analyse fieldT valueC)
_ (&;with-type-env
(tc;check fieldT valueT))
- _ (&;infer Unit)]
+ _ (&;infer objectT)]
(wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed) valueA objectA))))
_
diff --git a/new-luxc/source/luxc/generator/procedure/host.jvm.lux b/new-luxc/source/luxc/generator/procedure/host.jvm.lux
index a25c67feb..f908c6c6e 100644
--- a/new-luxc/source/luxc/generator/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/generator/procedure/host.jvm.lux
@@ -531,7 +531,7 @@
#;None
(wrap (|>. objectI
($i;CHECKCAST class)
- ($i;GETFIELD class field ($t;class class (list)))))))
+ ($i;GETFIELD class field ($t;class unboxed (list)))))))
_
(&;fail (format "Wrong syntax for '" proc "'."))))
@@ -557,18 +557,18 @@
_ (undefined))]
(wrap (|>. objectI
($i;CHECKCAST class)
+ $i;DUP
valueI
($i;unwrap primitive)
- ($i;PUTFIELD class field (#$;Primitive primitive))
- ($i;string &runtime;unit))))
+ ($i;PUTFIELD class field (#$;Primitive primitive)))))
#;None
(wrap (|>. objectI
($i;CHECKCAST class)
+ $i;DUP
valueI
- ($i;CHECKCAST class)
- ($i;PUTFIELD class field ($t;class class (list)))
- ($i;string &runtime;unit)))))
+ ($i;CHECKCAST unboxed)
+ ($i;PUTFIELD class field ($t;class unboxed (list)))))))
_
(&;fail (format "Wrong syntax for '" proc "'."))))
diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux
index 66dd43019..ce138ca48 100644
--- a/new-luxc/source/luxc/generator/runtime.jvm.lux
+++ b/new-luxc/source/luxc/generator/runtime.jvm.lux
@@ -54,6 +54,7 @@
(def: #export $Tag $;Type $t;int)
(def: #export $Flag $;Type $Object)
(def: #export $Datum $;Type $Object)
+(def: #export $Function $;Type ($t;class function-class (list)))
(def: #export logI
$;Inst
@@ -66,24 +67,42 @@
$;Method
($t;method (list $t;int $Object $Object) (#;Some $Object-Array) (list)))
-(def: variant-makeI
+(def: variantI
$;Inst
($i;INVOKESTATIC runtime-class "variant_make" variant-method false))
-(def: #export someI
+(def: #export leftI
+ $;Inst
+ (|>. ($i;int 0)
+ $i;NULL
+ $i;DUP2_X1
+ $i;POP2
+ variantI))
+
+(def: #export rightI
$;Inst
(|>. ($i;int 1)
($i;string "")
$i;DUP2_X1
$i;POP2
- variant-makeI))
+ variantI))
+
+(def: #export someI $;Inst rightI)
(def: #export noneI
$;Inst
(|>. ($i;int 0)
$i;NULL
($i;string unit)
- variant-makeI))
+ variantI))
+
+(def: #export partials-field Text "partials")
+(def: #export apply-method Text "apply")
+(def: #export num-apply-variants Nat +8)
+
+(def: #export (apply-signature arity)
+ (-> ls;Arity $;Method)
+ ($t;method (list;repeat arity $Object) (#;Some $Object) (list)))
(def: adt-methods
$;Def
@@ -372,7 +391,7 @@
($i;ILOAD +1) $i;ISUB ## Shorten tag
($i;ALOAD +0) flagI ## Get flag
($i;ALOAD +0) datumI ## Get value
- variant-makeI ## Build sum
+ variantI ## Build sum
$i;ARETURN)
update-tagI (|>. $i;ISUB ($i;ISTORE +1))
update-variantI (|>. ($i;ALOAD +0) datumI ($i;CHECKCAST ($t;descriptor $Variant)) ($i;ASTORE +0))
@@ -447,6 +466,26 @@
$i;ARETURN)))
)))
+(def: io-methods
+ $;Def
+ (|>. ($d;method #$;Public $;staticM "try" ($t;method (list $Function) (#;Some $Variant) (list))
+ (<| $i;with-label (function [@from])
+ $i;with-label (function [@to])
+ $i;with-label (function [@handler])
+ (|>. ($i;try @from @to @handler "java.lang.Throwable")
+ ($i;label @from)
+ ($i;ALOAD +0)
+ $i;NULL
+ ($i;INVOKEVIRTUAL function-class apply-method (apply-signature +1) false)
+ rightI
+ $i;ARETURN
+ ($i;label @to)
+ ($i;label @handler)
+ ($i;INVOKEVIRTUAL "java.lang.Throwable" "getMessage" ($t;method (list) (#;Some $String) (list)) false)
+ leftI
+ $i;ARETURN)))
+ ))
+
(def: generate-runtime
(Meta &common;Bytecode)
(do Monad<Meta>
@@ -456,18 +495,11 @@
nat-methods
frac-methods
deg-methods
- pm-methods))]
+ pm-methods
+ io-methods))]
_ (&common;store-class runtime-class bytecode)]
(wrap bytecode)))
-(def: #export partials-field Text "partials")
-(def: #export apply-method Text "apply")
-(def: #export num-apply-variants Nat +8)
-
-(def: #export (apply-signature arity)
- (-> ls;Arity $;Method)
- ($t;method (list;repeat arity $Object) (#;Some $Object) (list)))
-
(def: generate-function
(Meta &common;Bytecode)
(do Monad<Meta>