From 64ac2f552ec9e19131fc9671f14d14b0651cd988 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Thu, 26 Oct 2017 19:21:17 -0400
Subject: - Fixed some compiler tests.
---
.../source/luxc/analyser/procedure/host.jvm.lux | 2 +-
.../source/luxc/generator/procedure/host.jvm.lux | 12 +-
new-luxc/source/luxc/generator/runtime.jvm.lux | 60 +++++++---
new-luxc/test/test/luxc/analyser/function.lux | 5 -
.../test/test/luxc/analyser/procedure/host.jvm.lux | 8 +-
.../test/luxc/generator/procedure/host.jvm.lux | 132 ++++++++++++++++-----
6 files changed, 159 insertions(+), 60 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
@@ -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
diff --git a/new-luxc/test/test/luxc/analyser/function.lux b/new-luxc/test/test/luxc/analyser/function.lux
index baef5c42c..6fbafd1eb 100644
--- a/new-luxc/test/test/luxc/analyser/function.lux
+++ b/new-luxc/test/test/luxc/analyser/function.lux
@@ -100,11 +100,6 @@
(@;analyse-function analyse func-name arg-name (code;symbol ["" func-name])))
(meta;run (init-compiler []))
succeeds?))
- (test "Can infer recursive types for functions."
- (|> (@common;with-unknown-type
- (@;analyse-function analyse func-name arg-name (code;symbol ["" func-name])))
- (meta;run (init-compiler []))
- (check-type (type (Rec self (All [a] (-> a self)))))))
))))
(context: "Function application."
diff --git a/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux b/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux
index ad5670cbe..d1520e5b7 100644
--- a/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux
+++ b/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux
@@ -434,7 +434,7 @@
("jvm object null")))
(`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0))
("jvm object null"))))
- Unit))
+ (primitive org.omg.CORBA.ValueMember)))
(test "jvm member virtual put (final)"
(failure "jvm member virtual put"
(list (code;text "javax.swing.text.html.parser.DTD")
@@ -443,7 +443,7 @@
("jvm object null")))
(`' ("lux check" (+0 "javax.swing.text.html.parser.DTD" (+0))
("jvm object null"))))
- Unit))
+ (primitive javax.swing.text.html.parser.DTD)))
(test "jvm member virtual put (inheritance in)"
(success "jvm member virtual put"
(list (code;text "java.awt.GridBagConstraints")
@@ -452,7 +452,7 @@
("jvm object null")))
(`' ("lux check" (+0 "java.awt.GridBagConstraints" (+0))
("jvm object null"))))
- Unit))
+ (primitive java.awt.GridBagConstraints)))
))
(context: "Boxing/Unboxing."
@@ -477,7 +477,7 @@
("jvm object null")))
(`' ("lux check" (+0 "javax.accessibility.AccessibleAttributeSequence" (+0))
("jvm object null"))))
- Unit))
+ (primitive javax.accessibility.AccessibleAttributeSequence)))
))
(context: "Member [Method]."
diff --git a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux
index 5b22bc2a1..c5aad2cae 100644
--- a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux
+++ b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux
@@ -389,8 +389,11 @@
#let [num-instances (list;size instances)]
class-idx (|> r;nat (:: @ map (n.% num-classes)))
instance-idx (|> r;nat (:: @ map (n.% num-instances)))
+ exception-message (r;text +5)
#let [class (maybe;assume (list;nth class-idx classes))
- [instance-class instance-gen] (maybe;assume (list;nth instance-idx instances))]
+ [instance-class instance-gen] (maybe;assume (list;nth instance-idx instances))
+ exception-message$ (|> (#ls;Text exception-message)
+ (list (#ls;Text "java.lang.String")) #ls;Tuple)]
sample r;int
monitor r;int
instance instance-gen]
@@ -430,7 +433,25 @@
(#e;Error error)
false)))
(test "jvm object throw"
- false)
+ (|> (do meta;Monad
+ [_ @runtime;generate
+ sampleI (@;generate (|> (#ls;Procedure "jvm member invoke constructor" (list (#ls;Text "java.lang.Throwable")
+ exception-message$))
+ (list) (#ls;Procedure "jvm object throw")
+ (#ls;Function +1 (list))
+ (list) (#ls;Procedure "lux try")))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success outputG)
+ (case (:! (e;Error Top) outputG)
+ (#e;Error error)
+ (text/= exception-message error)
+
+ (#e;Success outputG)
+ false)
+
+ (#e;Error error)
+ false)))
(test "jvm object class"
(|> (do meta;Monad
[sampleI (@;generate (#ls;Procedure "jvm object class" (list (#ls;Text class))))]
@@ -458,34 +479,85 @@
(#static AD int))
(context: "Member [Field]"
- ($_ seq
- (test "jvm member static get"
- (|> (do meta;Monad
- [sampleI (@;generate (|> (#ls;Procedure "jvm member static get" (list (#ls;Text "java.util.GregorianCalendar") (#ls;Text "AD") (#ls;Text "int")))
- (list) (#ls;Procedure "jvm convert int-to-long")))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success outputG)
- (i.= GregorianCalendar.AD (:! Int outputG))
-
- (#e;Error error)
- false)))
- (test "jvm member static put"
- (|> (do meta;Monad
- [sampleI (@;generate (#ls;Procedure "jvm member static put" (list (#ls;Text "java.awt.datatransfer.DataFlavor") (#ls;Text "allHtmlFlavor") (#ls;Text "java.awt.datatransfer.DataFlavor")
- (#ls;Procedure "jvm member static get" (list (#ls;Text "java.awt.datatransfer.DataFlavor") (#ls;Text "allHtmlFlavor") (#ls;Text "java.awt.datatransfer.DataFlavor"))))))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success outputG)
- (is @runtime;unit (:! Text outputG))
-
- (#e;Error error)
- false)))
- (test "jvm member virtual get"
- false)
- (test "jvm member virtual put"
- false)
- ))
+ (<| (times +100)
+ (do @
+ [sample-short (|> r;int (:: @ map (|>. int/abs (i.% 100))))
+ sample-string (r;text +5)
+ other-sample-string (r;text +5)
+ #let [shortS (|> (#ls;Int sample-short)
+ (list) (#ls;Procedure "jvm convert long-to-short")
+ (list (#ls;Text "short")) #ls;Tuple)
+ stringS (|> (#ls;Text sample-string)
+ (list (#ls;Text "java.lang.String")) #ls;Tuple)
+ type-codeS (|> (#ls;Procedure "jvm object null" (list))
+ (list (#ls;Text "org.omg.CORBA.TypeCode")) #ls;Tuple)
+ idl-typeS (|> (#ls;Procedure "jvm object null" (list))
+ (list (#ls;Text "org.omg.CORBA.IDLType")) #ls;Tuple)
+ value-member$ (#ls;Procedure "jvm member invoke constructor" (list (#ls;Text "org.omg.CORBA.ValueMember")
+ stringS
+ stringS
+ stringS
+ stringS
+ type-codeS
+ idl-typeS
+ shortS))]]
+ ($_ seq
+ (test "jvm member static get"
+ (|> (do meta;Monad
+ [sampleI (@;generate (|> (#ls;Procedure "jvm member static get" (list (#ls;Text "java.util.GregorianCalendar") (#ls;Text "AD") (#ls;Text "int")))
+ (list) (#ls;Procedure "jvm convert int-to-long")))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success outputG)
+ (i.= GregorianCalendar.AD (:! Int outputG))
+
+ (#e;Error error)
+ false)))
+ (test "jvm member static put"
+ (|> (do meta;Monad
+ [sampleI (@;generate (#ls;Procedure "jvm member static put" (list (#ls;Text "java.awt.datatransfer.DataFlavor") (#ls;Text "allHtmlFlavor") (#ls;Text "java.awt.datatransfer.DataFlavor")
+ (#ls;Procedure "jvm member static get" (list (#ls;Text "java.awt.datatransfer.DataFlavor") (#ls;Text "allHtmlFlavor") (#ls;Text "java.awt.datatransfer.DataFlavor"))))))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success outputG)
+ (is @runtime;unit (:! Text outputG))
+
+ (#e;Error error)
+ false)))
+ (test "jvm member virtual get"
+ (|> (do meta;Monad
+ [sampleI (@;generate (|> value-member$
+ (list (#ls;Text "org.omg.CORBA.ValueMember")
+ (#ls;Text "name")
+ (#ls;Text "java.lang.String"))
+ (#ls;Procedure "jvm member virtual get")))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success outputG)
+ (text/= sample-string (:! Text outputG))
+
+ (#e;Error error)
+ false)))
+ (test "jvm member virtual put"
+ (|> (do meta;Monad
+ [sampleI (@;generate (|> value-member$
+ (list (#ls;Text "org.omg.CORBA.ValueMember")
+ (#ls;Text "name")
+ (#ls;Text "java.lang.String")
+ (#ls;Text other-sample-string))
+ (#ls;Procedure "jvm member virtual put")
+ (list (#ls;Text "org.omg.CORBA.ValueMember")
+ (#ls;Text "name")
+ (#ls;Text "java.lang.String"))
+ (#ls;Procedure "jvm member virtual get")))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success outputG)
+ (text/= other-sample-string (:! Text outputG))
+
+ (#e;Error error)
+ false)))
+ ))))
(host;import java.lang.Object)
--
cgit v1.2.3