aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--new-luxc/source/luxc/generator/runtime.jvm.lux93
-rw-r--r--new-luxc/test/test/luxc/generator/case.lux87
-rw-r--r--new-luxc/test/test/luxc/generator/procedure/common.jvm.lux180
-rw-r--r--new-luxc/test/test/luxc/generator/procedure/host.jvm.lux2
4 files changed, 182 insertions, 180 deletions
diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux
index ce138ca48..d2ad42a2c 100644
--- a/new-luxc/source/luxc/generator/runtime.jvm.lux
+++ b/new-luxc/source/luxc/generator/runtime.jvm.lux
@@ -1,12 +1,11 @@
(;module:
lux
(lux (control monad)
- (data ["R" error]
- text/format
- (coll [list "L/" Functor<List>]))
+ (data text/format
+ (coll [list "list/" Functor<List>]))
[math]
- [meta #+ Monad<Meta> "Meta/" Monad<Meta>]
- [host #+ do-to])
+ [meta]
+ [host])
(luxc ["&" base]
(lang ["la" analysis]
["ls" synthesis])
@@ -55,6 +54,7 @@
(def: #export $Flag $;Type $Object)
(def: #export $Datum $;Type $Object)
(def: #export $Function $;Type ($t;class function-class (list)))
+(def: $Throwable $;Type ($t;class "java.lang.Throwable" (list)))
(def: #export logI
$;Inst
@@ -468,27 +468,42 @@
(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)))
- ))
+ (let [string-writerI (|>. ($i;NEW "java.io.StringWriter")
+ $i;DUP
+ ($i;INVOKESPECIAL "java.io.StringWriter" "<init>" ($t;method (list) #;None (list)) false))
+ print-writerI (|>. ($i;NEW "java.io.PrintWriter")
+ $i;SWAP
+ $i;DUP2
+ $i;POP
+ $i;SWAP
+ ($i;boolean true)
+ ($i;INVOKESPECIAL "java.io.PrintWriter" "<init>" ($t;method (list ($t;class "java.io.Writer" (list)) $t;boolean) #;None (list)) false)
+ )]
+ (|>. ($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)
+ string-writerI ## TW
+ $i;DUP2 ## TWTW
+ print-writerI ## TWTP
+ ($i;INVOKEVIRTUAL "java.lang.Throwable" "printStackTrace" ($t;method (list ($t;class "java.io.PrintWriter" (list))) #;None (list)) false) ## TW
+ ($i;INVOKEVIRTUAL "java.io.StringWriter" "toString" ($t;method (list) (#;Some $String) (list)) false) ## TS
+ $i;SWAP $i;POP leftI
+ $i;ARETURN)))
+ )))
(def: generate-runtime
(Meta &common;Bytecode)
- (do Monad<Meta>
+ (do meta;Monad<Meta>
[_ (wrap [])
#let [bytecode ($d;class #$;V1.6 #$;Public $;finalC runtime-class (list) ["java.lang.Object" (list)] (list)
(|>. adt-methods
@@ -502,25 +517,21 @@
(def: generate-function
(Meta &common;Bytecode)
- (do Monad<Meta>
+ (do meta;Monad<Meta>
[_ (wrap [])
#let [applyI (|> (list;n.range +2 num-apply-variants)
- (L/map (function [arity]
- ($d;method #$;Public $;noneM apply-method (apply-signature arity)
- (let [preI (|> (list;n.range +0 (n.dec arity))
- (L/map $i;ALOAD)
- $i;fuse)]
- (|>. preI
- ($i;INVOKEVIRTUAL function-class apply-method (apply-signature (n.dec arity)) false)
- ($i;CHECKCAST function-class)
- ($i;ALOAD arity)
- ($i;INVOKEVIRTUAL function-class apply-method (apply-signature +1) false)
- $i;ARETURN)))))
- (list& ($d;abstract-method #$;Public $;noneM apply-method (apply-signature +1))
- ## ($d;method #$;Public $;noneM apply-method (apply-signature +1)
- ## (|>. $i;NULL
- ## $i;ARETURN))
- )
+ (list/map (function [arity]
+ ($d;method #$;Public $;noneM apply-method (apply-signature arity)
+ (let [preI (|> (list;n.range +0 (n.dec arity))
+ (list/map $i;ALOAD)
+ $i;fuse)]
+ (|>. preI
+ ($i;INVOKEVIRTUAL function-class apply-method (apply-signature (n.dec arity)) false)
+ ($i;CHECKCAST function-class)
+ ($i;ALOAD arity)
+ ($i;INVOKEVIRTUAL function-class apply-method (apply-signature +1) false)
+ $i;ARETURN)))))
+ (list& ($d;abstract-method #$;Public $;noneM apply-method (apply-signature +1)))
$d;fuse)
bytecode ($d;abstract #$;V1.6 #$;Public $;noneC function-class (list) ["java.lang.Object" (list)] (list)
(|>. ($d;field #$;Public $;finalF partials-field $t;int)
@@ -537,7 +548,7 @@
(def: #export generate
(Meta [&common;Bytecode &common;Bytecode])
- (do Monad<Meta>
+ (do meta;Monad<Meta>
[runtime-bc generate-runtime
function-bc generate-function]
(wrap [runtime-bc function-bc])))
diff --git a/new-luxc/test/test/luxc/generator/case.lux b/new-luxc/test/test/luxc/generator/case.lux
index 86319259c..34846a988 100644
--- a/new-luxc/test/test/luxc/generator/case.lux
+++ b/new-luxc/test/test/luxc/generator/case.lux
@@ -3,18 +3,10 @@
(lux [io]
(control [monad #+ do]
pipe)
- (data text/format
- [product]
- ["e" error]
- [bool "B/" Eq<Bool>]
- [text "T/" Eq<Text>]
- (coll ["a" array]
- [list "L/" Functor<List>]
- ["S" set]))
+ (data ["e" error]
+ (coll [list]))
["r" math/random "r/" Monad<Random>]
- [meta #+ Monad<Meta>]
- (meta [code])
- [host]
+ [meta]
test)
(luxc (lang ["ls" synthesis])
[analyser]
@@ -34,54 +26,51 @@
(def: gen-case
(r;Random [ls;Synthesis ls;Path])
(<| r;rec (function [gen-case])
- (with-expansions [<simple> (do-template [<gen> <synth> <path>]
- [(do r;Monad<Random>
- [value <gen>]
- (wrap [(<synth> value) (<path> value)]))]
+ (`` ($_ r;either
+ (r/wrap [#ls;Unit #ls;UnitP])
+ (~~ (do-template [<gen> <synth> <path>]
+ [(do r;Monad<Random>
+ [value <gen>]
+ (wrap [(<synth> value) (<path> value)]))]
- [r;bool #ls;Bool #ls;BoolP]
- [r;nat #ls;Nat #ls;NatP]
- [r;int #ls;Int #ls;IntP]
- [r;deg #ls;Deg #ls;DegP]
- [r;frac #ls;Frac #ls;FracP]
- [(r;text +5) #ls;Text #ls;TextP])]
- ($_ r;either
- (r/wrap [#ls;Unit #ls;UnitP])
- <simple>
- (do r;Monad<Random>
- [size (|> r;nat (:: @ map (|>. (n.% struct-limit) (n.max +2))))
- idx (|> r;nat (:: @ map (n.% size)))
- [subS subP] gen-case
- #let [dummyS (list;repeat (n.dec size) #ls;Unit)
- caseS (#ls;Tuple (list;concat (list (list;take idx dummyS)
- (list subS)
- (list;drop idx dummyS))))
- caseP (#ls;TupleP (if (tail? idx idx)
- (#;Right idx)
- (#;Left idx))
- subP)]]
- (wrap [caseS caseP]))
- (do r;Monad<Random>
- [size (|> r;nat (:: @ map (|>. (n.% struct-limit) (n.max +2))))
- idx (|> r;nat (:: @ map (n.% size)))
- [subS subP] gen-case
- #let [caseS (#ls;Variant idx (tail? idx idx) subS)
- caseP (#ls;VariantP (if (tail? idx idx)
+ [r;bool #ls;Bool #ls;BoolP]
+ [r;nat #ls;Nat #ls;NatP]
+ [r;int #ls;Int #ls;IntP]
+ [r;deg #ls;Deg #ls;DegP]
+ [r;frac #ls;Frac #ls;FracP]
+ [(r;text +5) #ls;Text #ls;TextP]))
+ (do r;Monad<Random>
+ [size (|> r;nat (:: @ map (|>. (n.% struct-limit) (n.max +2))))
+ idx (|> r;nat (:: @ map (n.% size)))
+ [subS subP] gen-case
+ #let [caseS (#ls;Tuple (list;concat (list (list;repeat idx #ls;Unit)
+ (list subS)
+ (list;repeat (|> size n.dec (n.- idx)) #ls;Unit))))
+ caseP (#ls;TupleP (if (tail? size idx)
(#;Right idx)
(#;Left idx))
subP)]]
- (wrap [caseS caseP]))
- ))))
+ (wrap [caseS caseP]))
+ (do r;Monad<Random>
+ [size (|> r;nat (:: @ map (|>. (n.% struct-limit) (n.max +2))))
+ idx (|> r;nat (:: @ map (n.% size)))
+ [subS subP] gen-case
+ #let [caseS (#ls;Variant idx (tail? idx idx) subS)
+ caseP (#ls;VariantP (if (tail? idx idx)
+ (#;Right idx)
+ (#;Left idx))
+ subP)]]
+ (wrap [caseS caseP]))
+ ))))
(context: "Pattern-matching."
- (<| (seed +17952275935008918762)
- ## (times +100)
+ (<| (times +100)
(do @
[[valueS path] gen-case
to-bind r;nat]
($_ seq
(test "Can generate pattern-matching."
- (|> (do Monad<Meta>
+ (|> (do meta;Monad<Meta>
[runtime-bytecode @runtime;generate
sampleI (@;generate valueS
(#ls;AltP (#ls;SeqP path (#ls;ExecP (#ls;Bool true)))
@@ -94,7 +83,7 @@
_
false)))
(test "Can bind values."
- (|> (do Monad<Meta>
+ (|> (do meta;Monad<Meta>
[runtime-bytecode @runtime;generate
sampleI (@;generate (#ls;Nat to-bind)
(#ls;SeqP (#ls;BindP +1) (#ls;ExecP (#ls;Variable 1))))]
diff --git a/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux b/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux
index 00cfd601b..dde15b19b 100644
--- a/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux
+++ b/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux
@@ -8,10 +8,10 @@
["e" error]
[bool "bool/" Eq<Bool>]
[text "text/" Eq<Text>]
- [number "n/" Interval<Nat> "i/" Interval<Int> "r/" Interval<Frac> "d/" Interval<Deg>]
+ [number "nat/" Interval<Nat> "int/" Interval<Int> "real/" Interval<Frac> "deg/" Interval<Deg>]
(coll ["a" array]
[list]))
- ["r" math/random "r/" Monad<Random>]
+ ["r" math/random]
[meta #+ Monad<Meta>]
[host]
test)
@@ -94,8 +94,8 @@
_
false)))]
- ["nat min" n/bottom]
- ["nat max" n/top]
+ ["nat min" nat/bottom]
+ ["nat max" nat/top]
)
<unary> (do-template [<name> <type> <prepare> <comp>]
[(test <name>
@@ -158,8 +158,8 @@
_
false)))]
- ["int min" i/bottom]
- ["int max" i/top]
+ ["int min" int/bottom]
+ ["int max" int/top]
)
<unary> (do-template [<name> <type> <prepare> <comp>]
[(test <name>
@@ -254,8 +254,8 @@
_
false)))]
- ["frac min" (f.= r/bottom)]
- ["frac max" (f.= r/top)]
+ ["frac min" (f.= real/bottom)]
+ ["frac max" (f.= real/top)]
["frac not-a-number" number;not-a-number?]
["frac positive-infinity" (f.= number;positive-infinity)]
["frac negative-infinity" (f.= number;negative-infinity)]
@@ -296,87 +296,89 @@
false)))
)))))
+(def: (above-threshold value)
+ (-> Deg Deg)
+ (let [threshold .000000001 #( 1/(2^30) )#]
+ (if (d.< threshold value)
+ (d.+ threshold value)
+ value)))
+
(context: "Deg procedures"
- (<| (seed +1021167468900)
- ## (times +100)
+ (<| (times +100)
(do @
- [param (|> r;deg (r;filter (|>. (d.= .0) not)))
+ [param (|> r;deg (:: @ map above-threshold))
special r;nat
- subject r;deg]
- (with-expansions [<nullary> (do-template [<name> <reference>]
- [(test <name>
- (|> (do meta;Monad<Meta>
- [sampleI (@;generate (#ls;Procedure <name> (list)))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (d.= <reference> (:! Deg valueG))
-
- _
- false)))]
-
- ["deg min" d/bottom]
- ["deg max" d/top]
- )
- <unary> (do-template [<name> <type> <prepare> <comp>]
- [(test <name>
- (|> (do Monad<Meta>
- [runtime-bytecode @runtime;generate
- sampleI (@;generate (#ls;Procedure <name> (list (#ls;Deg subject))))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (<comp> (<prepare> subject) (:! <type> valueG))
-
- _
- false)))]
-
- ["deg to-frac" Frac deg-to-frac f.=]
- )
- <binary> (do-template [<name> <reference> <outputT> <comp>]
- [(test <name>
- (|> (do Monad<Meta>
- [runtime-bytecode @runtime;generate
- sampleI (@;generate (#ls;Procedure <name>
- (list (#ls;Deg subject)
- (#ls;Deg param))))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (<comp> (<reference> param subject) (:! <outputT> valueG))
-
- _
- false)))]
-
- ["deg +" d.+ Deg d.=]
- ["deg -" d.- Deg d.=]
- ["deg *" d.* Deg d.=]
- ["deg /" d./ Deg d.=]
- ["deg %" d.% Deg d.=]
- ["deg =" d.= Bool bool/=]
- ["deg <" d.< Bool bool/=]
- )
- <special> (do-template [<name> <reference> <outputT> <comp>]
- [(test <name>
- (|> (do Monad<Meta>
- [runtime-bytecode @runtime;generate
- sampleI (@;generate (#ls;Procedure <name>
- (list (#ls;Deg subject)
- (#ls;Nat special))))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (<comp> (<reference> special subject) (:! <outputT> valueG))
-
- _
- false)))]
-
- ["deg scale" d.scale Deg d.=]
- ["deg reciprocal" d.reciprocal Deg d.=]
- )]
- ($_ seq
- <nullary>
- <unary>
- <binary>
- <special>
- )))))
+ subject (|> r;deg (:: @ map above-threshold))]
+ (`` ($_ seq
+ (~~ (do-template [<name> <reference>]
+ [(test <name>
+ (|> (do meta;Monad<Meta>
+ [sampleI (@;generate (#ls;Procedure <name> (list)))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (d.= <reference> (:! Deg valueG))
+
+ _
+ false)))]
+
+ ["deg min" deg/bottom]
+ ["deg max" deg/top]
+ ))
+ (~~ (do-template [<name> <type> <prepare> <comp>]
+ [(test <name>
+ (|> (do Monad<Meta>
+ [runtime-bytecode @runtime;generate
+ sampleI (@;generate (#ls;Procedure <name> (list (#ls;Deg subject))))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (<comp> (<prepare> subject) (:! <type> valueG))
+
+ _
+ false)))]
+
+ ["deg to-frac" Frac deg-to-frac f.=]
+ ))
+ (~~ (do-template [<name> <reference> <outputT> <comp>]
+ [(test <name>
+ (|> (do Monad<Meta>
+ [runtime-bytecode @runtime;generate
+ sampleI (@;generate (#ls;Procedure <name>
+ (list (#ls;Deg subject)
+ (#ls;Deg param))))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (<comp> (<reference> param subject) (:! <outputT> valueG))
+
+ _
+ false)))]
+
+ ["deg +" d.+ Deg d.=]
+ ["deg -" d.- Deg d.=]
+ ["deg *" d.* Deg d.=]
+ ["deg /" d./ Deg d.=]
+ ["deg %" d.% Deg d.=]
+ ["deg =" d.= Bool bool/=]
+ ["deg <" d.< Bool bool/=]
+ ))
+ (~~ (do-template [<name> <reference> <outputT> <comp>]
+ [(test <name>
+ (|> (do Monad<Meta>
+ [runtime-bytecode @runtime;generate
+ sampleI (@;generate (#ls;Procedure <name>
+ (list (#ls;Deg subject)
+ (#ls;Nat special))))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (<comp> (<reference> special subject) (:! <outputT> valueG))
+
+ _
+ false)))]
+
+ ["deg scale" d.scale Deg d.=]
+ ["deg reciprocal" d.reciprocal Deg d.=]
+ ))
+ )))))
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 c5aad2cae..097c2b802 100644
--- a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux
+++ b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux
@@ -445,7 +445,7 @@
(case> (#e;Success outputG)
(case (:! (e;Error Top) outputG)
(#e;Error error)
- (text/= exception-message error)
+ (text;contains? exception-message error)
(#e;Success outputG)
false)
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-23 17:38:15 +0000