From e2621632653ad1252744eecff6da143faaf90787 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 26 Oct 2017 20:30:17 -0400 Subject: - Fixed remaining tests in compiler. - Now showing stack-traces for errors on JVM. --- new-luxc/source/luxc/generator/runtime.jvm.lux | 93 ++++++----- new-luxc/test/test/luxc/generator/case.lux | 87 +++++----- .../test/luxc/generator/procedure/common.jvm.lux | 180 +++++++++++---------- .../test/luxc/generator/procedure/host.jvm.lux | 2 +- 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])) + (data text/format + (coll [list "list/" Functor])) [math] - [meta #+ Monad "Meta/" Monad] - [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" "" ($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" "" ($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 + (do meta;Monad [_ (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 + (do meta;Monad [_ (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 + (do meta;Monad [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] - [text "T/" Eq] - (coll ["a" array] - [list "L/" Functor] - ["S" set])) + (data ["e" error] + (coll [list])) ["r" math/random "r/" Monad] - [meta #+ Monad] - (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 [ (do-template [ ] - [(do r;Monad - [value ] - (wrap [( value) ( value)]))] + (`` ($_ r;either + (r/wrap [#ls;Unit #ls;UnitP]) + (~~ (do-template [ ] + [(do r;Monad + [value ] + (wrap [( value) ( 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]) - - (do r;Monad - [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 - [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 + [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 + [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 + (|> (do meta;Monad [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 + (|> (do meta;Monad [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] [text "text/" Eq] - [number "n/" Interval "i/" Interval "r/" Interval "d/" Interval] + [number "nat/" Interval "int/" Interval "real/" Interval "deg/" Interval] (coll ["a" array] [list])) - ["r" math/random "r/" Monad] + ["r" math/random] [meta #+ Monad] [host] test) @@ -94,8 +94,8 @@ _ false)))] - ["nat min" n/bottom] - ["nat max" n/top] + ["nat min" nat/bottom] + ["nat max" nat/top] ) (do-template [ ] [(test @@ -158,8 +158,8 @@ _ false)))] - ["int min" i/bottom] - ["int max" i/top] + ["int min" int/bottom] + ["int max" int/top] ) (do-template [ ] [(test @@ -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 [ (do-template [ ] - [(test - (|> (do meta;Monad - [sampleI (@;generate (#ls;Procedure (list)))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (d.= (:! Deg valueG)) - - _ - false)))] - - ["deg min" d/bottom] - ["deg max" d/top] - ) - (do-template [ ] - [(test - (|> (do Monad - [runtime-bytecode @runtime;generate - sampleI (@;generate (#ls;Procedure (list (#ls;Deg subject))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( ( subject) (:! valueG)) - - _ - false)))] - - ["deg to-frac" Frac deg-to-frac f.=] - ) - (do-template [ ] - [(test - (|> (do Monad - [runtime-bytecode @runtime;generate - sampleI (@;generate (#ls;Procedure - (list (#ls;Deg subject) - (#ls;Deg param))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( ( param subject) (:! 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 [ ] - [(test - (|> (do Monad - [runtime-bytecode @runtime;generate - sampleI (@;generate (#ls;Procedure - (list (#ls;Deg subject) - (#ls;Nat special))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - ( ( special subject) (:! valueG)) - - _ - false)))] - - ["deg scale" d.scale Deg d.=] - ["deg reciprocal" d.reciprocal Deg d.=] - )] - ($_ seq - - - - - ))))) + subject (|> r;deg (:: @ map above-threshold))] + (`` ($_ seq + (~~ (do-template [ ] + [(test + (|> (do meta;Monad + [sampleI (@;generate (#ls;Procedure (list)))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + (d.= (:! Deg valueG)) + + _ + false)))] + + ["deg min" deg/bottom] + ["deg max" deg/top] + )) + (~~ (do-template [ ] + [(test + (|> (do Monad + [runtime-bytecode @runtime;generate + sampleI (@;generate (#ls;Procedure (list (#ls;Deg subject))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + ( ( subject) (:! valueG)) + + _ + false)))] + + ["deg to-frac" Frac deg-to-frac f.=] + )) + (~~ (do-template [ ] + [(test + (|> (do Monad + [runtime-bytecode @runtime;generate + sampleI (@;generate (#ls;Procedure + (list (#ls;Deg subject) + (#ls;Deg param))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + ( ( param subject) (:! 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 [ ] + [(test + (|> (do Monad + [runtime-bytecode @runtime;generate + sampleI (@;generate (#ls;Procedure + (list (#ls;Deg subject) + (#ls;Nat special))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + ( ( special subject) (:! 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) -- cgit v1.2.3