From 453ab9f67873bb022acadf4c0f5c1e635c7d5794 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 11 Aug 2018 23:27:32 -0400 Subject: - Fixed common translation tests for JVM. - Fixed a bug in "lux text <". - Small optimizations to old LuxC. --- luxc/src/lux/compiler/jvm/case.clj | 4 +- luxc/src/lux/compiler/jvm/proc/common.clj | 67 ++++---- luxc/src/lux/compiler/jvm/rt.clj | 10 +- new-luxc/source/luxc/lang/translation/jvm.lux | 7 +- .../source/luxc/lang/translation/jvm/case.jvm.lux | 13 +- .../lang/translation/jvm/procedure/common.jvm.lux | 86 ++++++----- .../luxc/lang/translation/jvm/runtime.jvm.lux | 8 +- .../luxc/lang/translation/jvm/structure.jvm.lux | 12 +- new-luxc/test/test/luxc/lang/translation/case.lux | 97 +++++++----- .../test/test/luxc/lang/translation/common.lux | 172 ++++++++++----------- .../test/test/luxc/lang/translation/function.lux | 103 ++++++------ .../test/test/luxc/lang/translation/reference.lux | 15 +- .../lux/compiler/default/phase/synthesis.lux | 34 +++- stdlib/source/lux/math/random.lux | 3 +- stdlib/test/tests.lux | 9 +- 15 files changed, 344 insertions(+), 296 deletions(-) diff --git a/luxc/src/lux/compiler/jvm/case.clj b/luxc/src/lux/compiler/jvm/case.clj index 4c195ba36..32ca72ae3 100644 --- a/luxc/src/lux/compiler/jvm/case.clj +++ b/luxc/src/lux/compiler/jvm/case.clj @@ -196,10 +196,10 @@ (|do [^MethodVisitor *writer* &/get-writer :let [$end (new Label) bodies-labels (&/|map (fn [_] (new Label)) ?bodies)] + :let [_ (doto *writer* + (.visitInsn Opcodes/ACONST_NULL))] _ (compile ?value) :let [_ (doto *writer* - (.visitInsn Opcodes/ACONST_NULL) - (.visitInsn Opcodes/SWAP) (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")) _ (compile-pattern *writer* bodies-labels ?pm $end)] _ (compile-bodies *writer* compile bodies-labels ?bodies $end) diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj index 444db63e3..36f23263d 100644 --- a/luxc/src/lux/compiler/jvm/proc/common.clj +++ b/luxc/src/lux/compiler/jvm/proc/common.clj @@ -227,8 +227,7 @@ $end (new Label) _ (doto *writer* (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "compareTo" "(Ljava/lang/String;)I") - (.visitLdcInsn (int -1)) - (.visitJumpInsn Opcodes/IF_ICMPEQ $then) + (.visitJumpInsn Opcodes/IFLT $then) (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) (.visitJumpInsn Opcodes/GOTO $end) (.visitLabel $then) @@ -267,40 +266,36 @@ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "text_clip" "(Ljava/lang/String;II)[Ljava/lang/Object;"))]] (return nil))) -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Cons ?start (&/$Nil)))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?text) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] - _ (compile ?part) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] - _ (compile ?start) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "(Ljava/lang/String;I)I"))] - :let [$not-found (new Label) - $end (new Label) - _ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int -1)) - (.visitJumpInsn Opcodes/IF_ICMPEQ $not-found) - (.visitInsn Opcodes/I2L) - &&/wrap-long - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)[Ljava/lang/Object;") - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $not-found) - (.visitInsn Opcodes/POP) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()[Ljava/lang/Object;") - (.visitLabel $end))]] - (return nil))) - - ^:private compile-text-index "indexOf" - ) +(defn ^:private compile-text-index [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Cons ?start (&/$Nil)))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?text) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?part) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?start) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "indexOf" "(Ljava/lang/String;I)I"))] + :let [$not-found (new Label) + $end (new Label) + _ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int -1)) + (.visitJumpInsn Opcodes/IF_ICMPEQ $not-found) + (.visitInsn Opcodes/I2L) + &&/wrap-long + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)[Ljava/lang/Object;") + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $not-found) + (.visitInsn Opcodes/POP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()[Ljava/lang/Object;") + (.visitLabel $end))]] + (return nil))) (do-template [ ] (defn [compile ?values special-args] diff --git a/luxc/src/lux/compiler/jvm/rt.clj b/luxc/src/lux/compiler/jvm/rt.clj index 7dd08dc62..6b9aeb680 100644 --- a/luxc/src/lux/compiler/jvm/rt.clj +++ b/luxc/src/lux/compiler/jvm/rt.clj @@ -93,7 +93,7 @@ (.visitVarInsn Opcodes/ISTORE 1) ;; (.visitJumpInsn Opcodes/GOTO $begin) (.visitLabel $not-rec) ;; tuple-size, index-last-elem - (.visitInsn Opcodes/POP2) ;; + ;; (.visitInsn Opcodes/POP2) ;; (.visitVarInsn Opcodes/ALOAD 0) ;; tuple (.visitVarInsn Opcodes/ILOAD 1) ;; tuple, index (.visitInsn Opcodes/AALOAD) ;; elem @@ -139,7 +139,7 @@ (.visitMethodInsn Opcodes/INVOKESTATIC "java/util/Arrays" "copyOfRange" "([Ljava/lang/Object;II)[Ljava/lang/Object;") (.visitInsn Opcodes/ARETURN) (.visitLabel $is-last) ;; tuple-size, index-last-elem - (.visitInsn Opcodes/POP2) ;; + ;; (.visitInsn Opcodes/POP2) ;; (.visitVarInsn Opcodes/ALOAD 0) ;; tuple (.visitVarInsn Opcodes/ILOAD 1) ;; tuple, index (.visitInsn Opcodes/AALOAD) ;; elem @@ -154,7 +154,7 @@ $not-right (new Label) failure (fn [^MethodVisitor writer] (doto writer - (.visitInsn Opcodes/POP2) + ;; (.visitInsn Opcodes/POP2) (.visitInsn Opcodes/ACONST_NULL) (.visitInsn Opcodes/ARETURN))) shortened (fn [^MethodVisitor writer] @@ -192,7 +192,7 @@ (.visitJumpInsn Opcodes/IF_ACMPEQ $just-return) (.visitJumpInsn Opcodes/GOTO $further) (.visitLabel $just-return) - (.visitInsn Opcodes/POP2) + ;; (.visitInsn Opcodes/POP2) (.visitVarInsn Opcodes/ALOAD 0) (.visitLdcInsn (int 2)) (.visitInsn Opcodes/AALOAD) @@ -200,7 +200,7 @@ (.visitLabel $shorten) (.visitVarInsn Opcodes/ALOAD 2) (.visitJumpInsn Opcodes/IFNULL $not-right) - (.visitInsn Opcodes/POP2) + ;; (.visitInsn Opcodes/POP2) shortened (.visitInsn Opcodes/ARETURN) (.visitLabel $further) ;; tag, sum-tag diff --git a/new-luxc/source/luxc/lang/translation/jvm.lux b/new-luxc/source/luxc/lang/translation/jvm.lux index f9b081972..b8c00c8a4 100644 --- a/new-luxc/source/luxc/lang/translation/jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm.lux @@ -133,9 +133,10 @@ (ex.report ["Class" class] ["Error" error])) -(exception: #export (invalid-field {class Text} {field Text}) +(exception: #export (invalid-field {class Text} {field Text} {error Text}) (ex.report ["Class" class] - ["Field" field])) + ["Field" field] + ["Error" error])) (exception: #export (invalid-value {class Text}) (ex.report ["Class" class])) @@ -157,7 +158,7 @@ (ex.throw cannot-load [class-name error])) (#error.Error error) - (ex.throw invalid-field [class-name ..value-field]))) + (ex.throw invalid-field [class-name ..value-field error]))) (def: module-separator "/") (def: class-path-separator ".") diff --git a/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux index 4f3193bbf..e11187787 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux @@ -107,9 +107,9 @@ (_.GOTO @end)))) - (^template [ ] + (^template [ ] (^ ( idx)) - (operation/wrap (.case ( idx) + (operation/wrap (.case idx 0 (|>> peekI (_.CHECKCAST ($t.descriptor runtime.$Tuple)) @@ -128,8 +128,8 @@ (list)) #0) pushI)))) - ([synthesis.member/left "pm_left" .id] - [synthesis.member/right "pm_right" .inc]) + ([synthesis.member/left "pm_left"] + [synthesis.member/right "pm_right"]) (^template [ ] (^ ( idx)) @@ -222,9 +222,8 @@ [@end _.make-label valueI (translate valueS) pathI (..path translate path @end)] - (wrap (|>> valueI - _.NULL - _.SWAP + (wrap (|>> _.NULL + valueI pushI pathI (_.label @end))))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux index 7ce1d6fda..efccb25f6 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux @@ -84,6 +84,7 @@ ## [Instructions] (def: lux-intI Inst (|>> _.I2L (_.wrap #$.Long))) (def: jvm-intI Inst (|>> (_.unwrap #$.Long) _.L2I)) +(def: check-stringI Inst (_.CHECKCAST "java.lang.String")) (def: (predicateI tester) (-> (-> Label Inst) @@ -161,17 +162,17 @@ (_.wrap )))] - [i64::add #$.Long _.LADD] - [i64::sub #$.Long _.LSUB] - [i64::mul #$.Long _.LMUL] - [i64::div #$.Long _.LDIV] - [i64::rem #$.Long _.LREM] + [i64::+ #$.Long _.LADD] + [i64::- #$.Long _.LSUB] + [i64::* #$.Long _.LMUL] + [i64::/ #$.Long _.LDIV] + [i64::% #$.Long _.LREM] - [f64::add #$.Double _.DADD] - [f64::sub #$.Double _.DSUB] - [f64::mul #$.Double _.DMUL] - [f64::div #$.Double _.DDIV] - [f64::rem #$.Double _.DREM] + [f64::+ #$.Double _.DADD] + [f64::- #$.Double _.DSUB] + [f64::* #$.Double _.DMUL] + [f64::/ #$.Double _.DDIV] + [f64::% #$.Double _.DREM] ) (do-template [ ] @@ -183,11 +184,12 @@ (_.int ) (predicateI _.IF_ICMPEQ)))] + [ +0] [ -1])] - [i64::eq i64::lt (_.unwrap #$.Long) _.LCMP] - [f64::eq f64::lt (_.unwrap #$.Double) _.DCMPG] + [i64::= i64::< (_.unwrap #$.Long) _.LCMP] + [f64::= f64::< (_.unwrap #$.Double) _.DCMPG] ) (do-template [ ] @@ -202,7 +204,7 @@ [f64::to-i64 (_.unwrap #$.Double) (<| (_.wrap #$.Long) _.D2L)] [f64::encode (_.unwrap #$.Double) (_.INVOKESTATIC "java.lang.Double" "toString" (_t.method (list _t.double) (#.Some $String) (list)) #0)] - [f64::decode (_.CHECKCAST "java.lang.String") + [f64::decode ..check-stringI (_.INVOKESTATIC ///.runtime-class "decode_frac" (_t.method (list $String) (#.Some $Object-Array) (list)) #0)] ) @@ -210,7 +212,7 @@ (def: (text::size inputI) Unary (|>> inputI - (_.CHECKCAST "java.lang.String") + ..check-stringI (_.INVOKEVIRTUAL "java.lang.String" "length" (_t.method (list) (#.Some _t.int) (list)) #0) lux-intI)) @@ -221,16 +223,16 @@ paramI ))] - [text::eq id id + [text::= id id (_.INVOKEVIRTUAL "java.lang.Object" "equals" (_t.method (list ///.$Object) (#.Some _t.boolean) (list)) #0) (_.wrap #$.Boolean)] - [text::lt (_.CHECKCAST "java.lang.String") (_.CHECKCAST "java.lang.String") + [text::< ..check-stringI ..check-stringI (_.INVOKEVIRTUAL "java.lang.String" "compareTo" (_t.method (list $String) (#.Some _t.int) (list)) #0) - (<| (predicateI _.IF_ICMPEQ) (_.int -1))] - [text::concat (_.CHECKCAST "java.lang.String") (_.CHECKCAST "java.lang.String") + (predicateI _.IFLT)] + [text::concat ..check-stringI ..check-stringI (_.INVOKEVIRTUAL "java.lang.String" "concat" (_t.method (list $String) (#.Some $String) (list)) #0) id] - [text::char (_.CHECKCAST "java.lang.String") jvm-intI + [text::char ..check-stringI jvm-intI (_.INVOKESTATIC ///.runtime-class "text_char" (_t.method (list $String _t.int) (#.Some ///.$Variant) (list)) #0) id] ) @@ -243,7 +245,7 @@ extraI ))] - [text::clip (_.CHECKCAST "java.lang.String") jvm-intI jvm-intI + [text::clip ..check-stringI jvm-intI jvm-intI (_.INVOKESTATIC ///.runtime-class "text_clip" (_t.method (list $String _t.int _t.int) (#.Some ///.$Variant) (list)) #0)] ) @@ -253,8 +255,8 @@ Trinary (<| _.with-label (function (_ @not-found)) _.with-label (function (_ @end)) - (|>> textI (_.CHECKCAST "java.lang.String") - partI (_.CHECKCAST "java.lang.String") + (|>> textI ..check-stringI + partI ..check-stringI startI jvm-intI (_.INVOKEVIRTUAL "java.lang.String" "indexOf" index-method #0) _.DUP @@ -264,7 +266,7 @@ runtime.someI (_.GOTO @end) (_.label @not-found) - ## _.POP + _.POP runtime.noneI (_.label @end)))) @@ -274,7 +276,7 @@ Unary (|>> (_.GETSTATIC "java.lang.System" "out" (_t.class "java.io.PrintStream" (list))) messageI - (_.CHECKCAST "java.lang.String") + ..check-stringI (_.INVOKEVIRTUAL "java.io.PrintStream" "println" string-method #0) unitI)) @@ -283,7 +285,7 @@ (|>> (_.NEW "java.lang.Error") _.DUP messageI - (_.CHECKCAST "java.lang.String") + ..check-stringI (_.INVOKESPECIAL "java.lang.Error" "" string-method #0) _.ATHROW)) @@ -293,7 +295,7 @@ (_.INVOKESTATIC "java.lang.System" "exit" (_t.method (list _t.int) #.None (list)) #0) _.NULL)) -(def: (io::current-time []) +(def: (io::current-time _) Nullary (|>> (_.INVOKESTATIC "java.lang.System" "currentTimeMillis" (_t.method (list) (#.Some _t.long) (list)) #0) (_.wrap #$.Long))) @@ -320,13 +322,13 @@ Bundle (<| (bundle.prefix "i64") (|> (: Bundle bundle.empty) - (bundle.install "+" (binary i64::add)) - (bundle.install "-" (binary i64::sub)) - (bundle.install "*" (binary i64::mul)) - (bundle.install "/" (binary i64::div)) - (bundle.install "%" (binary i64::rem)) - (bundle.install "=" (binary i64::eq)) - (bundle.install "<" (binary i64::lt)) + (bundle.install "+" (binary i64::+)) + (bundle.install "-" (binary i64::-)) + (bundle.install "*" (binary i64::*)) + (bundle.install "/" (binary i64::/)) + (bundle.install "%" (binary i64::%)) + (bundle.install "=" (binary i64::=)) + (bundle.install "<" (binary i64::<)) (bundle.install "to-f64" (unary i64::to-f64)) (bundle.install "char" (unary i64::char))))) @@ -334,13 +336,13 @@ Bundle (<| (bundle.prefix "f64") (|> (: Bundle bundle.empty) - (bundle.install "+" (binary f64::add)) - (bundle.install "-" (binary f64::sub)) - (bundle.install "*" (binary f64::mul)) - (bundle.install "/" (binary f64::div)) - (bundle.install "%" (binary f64::rem)) - (bundle.install "=" (binary f64::eq)) - (bundle.install "<" (binary f64::lt)) + (bundle.install "+" (binary f64::+)) + (bundle.install "-" (binary f64::-)) + (bundle.install "*" (binary f64::*)) + (bundle.install "/" (binary f64::/)) + (bundle.install "%" (binary f64::%)) + (bundle.install "=" (binary f64::=)) + (bundle.install "<" (binary f64::<)) (bundle.install "smallest" (nullary f64::smallest)) (bundle.install "min" (nullary f64::min)) (bundle.install "max" (nullary f64::max)) @@ -352,8 +354,8 @@ Bundle (<| (bundle.prefix "text") (|> (: Bundle bundle.empty) - (bundle.install "=" (binary text::eq)) - (bundle.install "<" (binary text::lt)) + (bundle.install "=" (binary text::=)) + (bundle.install "<" (binary text::<)) (bundle.install "concat" (binary text::concat)) (bundle.install "index" (trinary text::index)) (bundle.install "size" (unary text::size)) diff --git a/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux index 3c687f822..c92ab1026 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux @@ -316,9 +316,13 @@ (<| _.with-label (function (_ @begin)) _.with-label (function (_ @tail)) _.with-label (function (_ @slice)) - (let [updated-idxI (|>> (_.ILOAD 1) (_.int +1) _.IADD tuple-sizeI _.ISUB) + (let [updated-idxI (|>> (_.ILOAD 1) (_.int +1) _.ISUB tuple-sizeI _.ISUB) sliceI (|>> (_.ALOAD 0) (_.ILOAD 1) tuple-sizeI - (_.INVOKESTATIC "java.util.Arrays" "copyOfRange" ($t.method (list $Object-Array $t.int $t.int) (#.Some $Object-Array) (list)) #0))]) + (_.INVOKESTATIC "java.util.Arrays" "copyOfRange" + ($t.method (list $Object-Array $t.int $t.int) + (#.Some $Object-Array) + (list)) + #0))]) (|>> (_.label @begin) tuple-sizeI expected-last-sizeI diff --git a/new-luxc/source/luxc/lang/translation/jvm/structure.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/structure.jvm.lux index 040c4dd59..f937d5bdb 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/structure.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/structure.jvm.lux @@ -46,18 +46,20 @@ (_.array $Object) membersI)))) -(def: (flagI tail?) +(def: (flagI right?) (-> Bit Inst) - (if tail? + (if right? (_.string "") _.NULL)) -(def: #export (variant translate tag tail? member) +(def: #export (variant translate lefts right? member) (-> Phase Nat Bit Synthesis (Operation Inst)) (do phase.Monad [memberI (translate member)] - (wrap (|>> (_.int (.int tag)) - (flagI tail?) + (wrap (|>> (_.int (.int (if right? + (.inc lefts) + lefts))) + (flagI right?) memberI (_.INVOKESTATIC //.runtime-class "variant_make" diff --git a/new-luxc/test/test/luxc/lang/translation/case.lux b/new-luxc/test/test/luxc/lang/translation/case.lux index ed8529429..801d9f1d7 100644 --- a/new-luxc/test/test/luxc/lang/translation/case.lux +++ b/new-luxc/test/test/luxc/lang/translation/case.lux @@ -1,16 +1,13 @@ (.module: - [lux #* + [lux (#- case) [control [monad (#+ do)] pipe] [data - ["e" error] - [text - format] [collection ["." list]]] [math - ["r" random]] + ["r" random (#+ Random)]] [compiler [default ["." reference] @@ -24,15 +21,19 @@ [// ["&" function]]) -(def: struct-limit Nat 10) +(def: limit Nat 10) + +(def: size + (Random Nat) + (|> r.nat (:: r.Monad map (|>> (n/% ..limit) (n/max 2))))) (def: (tail? size idx) (-> Nat Nat Bit) (n/= (dec size) idx)) -(def: gen-case - (r.Random [Synthesis Path]) - (<| r.rec (function (_ gen-case)) +(def: case + (Random [Synthesis Path]) + (<| r.rec (function (_ case)) (`` ($_ r.either (do r.Monad [value r.i64] @@ -49,9 +50,9 @@ [r.frac synthesis.f64 synthesis.path/f64] [(r.unicode 5) synthesis.text synthesis.path/text])) (do r.Monad - [size (|> r.nat (:: @ map (|>> (n/% struct-limit) (n/max 2)))) + [size ..size idx (|> r.nat (:: @ map (n/% size))) - [subS subP] gen-case + [subS subP] case #let [unitS (synthesis.text synthesis.unit) caseS (synthesis.tuple (list.concat (list (list.repeat idx unitS) @@ -63,42 +64,64 @@ subP])]] (wrap [caseS caseP])) (do r.Monad - [size (|> r.nat (:: @ map (|>> (n/% struct-limit) (n/max 2)))) + [size ..size idx (|> r.nat (:: @ map (n/% size))) - [subS subP] gen-case - #let [caseS (let [right? (tail? size idx)] - (synthesis.variant - {#analysis.lefts idx - #analysis.right? right? - #analysis.value subS})) + [subS subP] case + #let [right? (tail? size idx) + caseS (synthesis.variant + {#analysis.lefts idx + #analysis.right? right? + #analysis.value subS}) caseP (synthesis.path/seq - [(if (tail? size idx) + [(if right? (synthesis.side/right idx) (synthesis.side/left idx)) subP])]] (wrap [caseS caseP])) )))) -(def: (pattern-matching-spec run) +(def: (let-spec run) + (-> Runner Test) + (do r.Monad + [value &.safe-frac] + (test "Specialized \"let\"." + (|> (run (synthesis.branch/let [(synthesis.f64 value) + 0 + (synthesis.variable/local 0)])) + (&.check value))))) + +(def: (if-spec run) (-> Runner Test) (do r.Monad - [[valueS pathS] gen-case - to-bind r.frac] - ($_ seq - (test "Can translate pattern-matching." - (|> (run (synthesis.branch/case - [valueS - (synthesis.path/alt [(synthesis.path/seq [pathS - (synthesis.path/then (synthesis.f64 to-bind))]) - (synthesis.path/then (synthesis.f64 +0.0))])])) - (&.check to-bind))) - (test "Can bind values." - (|> (run (synthesis.branch/case - [(synthesis.f64 to-bind) - (synthesis.path/seq [(synthesis.path/bind 0) - (synthesis.path/then (synthesis.variable/local 0))])])) - (&.check to-bind))) - ))) + [on-true &.safe-frac + on-false (|> &.safe-frac (r.filter (|>> (f/= on-true) not))) + verdict r.bit] + (test "Specialized \"if\"." + (|> (run (synthesis.branch/if [(synthesis.bit verdict) + (synthesis.f64 on-true) + (synthesis.f64 on-false)])) + (&.check (if verdict on-true on-false)))))) + +(def: (case-spec run) + (-> Runner Test) + (do r.Monad + [[inputS pathS] ..case + on-success &.safe-frac + on-failure (|> &.safe-frac (r.filter (|>> (f/= on-success) not)))] + (test "Case." + (|> (run (synthesis.branch/case + [inputS + (synthesis.path/alt [(synthesis.path/seq [pathS + (synthesis.path/then (synthesis.f64 on-success))]) + (synthesis.path/then (synthesis.f64 on-failure))])])) + (&.check on-success))))) + +(def: (pattern-matching-spec run) + (-> Runner Test) + ($_ seq + (let-spec run) + (if-spec run) + (case-spec run))) (context: "[JVM] Pattern-matching." (<| (times 100) diff --git a/new-luxc/test/test/luxc/lang/translation/common.lux b/new-luxc/test/test/luxc/lang/translation/common.lux index 246598072..3005a7588 100644 --- a/new-luxc/test/test/luxc/lang/translation/common.lux +++ b/new-luxc/test/test/luxc/lang/translation/common.lux @@ -13,7 +13,7 @@ [collection ["." list]]] [math - ["r" random]] + ["r" random (#+ Random)]] [compiler [default ["." reference] @@ -22,7 +22,9 @@ test] [test [luxc - ["." common (#+ Runner)]]]) + ["." common (#+ Runner)]]] + [// + ["&" function]]) (def: (bit-spec run) (-> Runner Test) @@ -37,8 +39,7 @@ (n/= ( param subject) (:coerce Nat valueT)) (#error.Error error) - (exec (log! error) - #0)) + #0) (let [param ])))] ["lux bit and" i64.and param] @@ -59,8 +60,7 @@ (:coerce I64 valueT)) (#error.Error error) - (exec (log! error) - #0)) + #0) (let [param (n/% 64 param)]))) )))) @@ -77,8 +77,7 @@ ( ( subject) (:coerce valueT)) (#error.Error error) - (exec (log! error) - #0)) + #0) (let [subject ])))] ["lux i64 to-f64" Frac int-to-frac f/= subject] @@ -95,8 +94,7 @@ ( ( param subject) (:coerce valueT)) (#error.Error error) - (exec (log! error) - #0))))] + #0)))] ["lux i64 +" i/+ Int i/=] ["lux i64 -" i/- Int i/=] @@ -108,110 +106,98 @@ )) )))) -(def: (f64-spec/0 run) - (-> Runner Test) - (do r.Monad - [param (|> r.frac (r.filter (|>> (f/= +0.0) not))) - subject r.frac] - (with-expansions [ (do-template [ ] - [(test - (|> (run (#synthesis.Extension (list (synthesis.f64 subject) - (synthesis.f64 param)))) - (case> (#error.Success valueT) - ( ( param subject) (:coerce valueT)) - - _ - #0)))] - - ["lux f64 +" f/+ Frac f/=] - ["lux f64 -" f/- Frac f/=] - ["lux f64 *" f/* Frac f/=] - ["lux f64 /" f// Frac f/=] - ["lux f64 %" f/% Frac f/=] - ["lux f64 =" f/= Bit bit/=] - ["lux f64 <" f/< Bit bit/=] - )] - ($_ seq - - )))) +(def: simple-frac + (Random Frac) + (|> r.nat (:: r.Monad map (|>> (n/% 1000) .int int-to-frac)))) -(def: (f64-spec/1 run) +(def: (f64-spec run) (-> Runner Test) (do r.Monad - [subject (|> r.nat (:: @ map (|>> (n/% 1000) .int int-to-frac)))] + [param (|> ..simple-frac (r.filter (|>> (f/= +0.0) not))) + subject ..simple-frac] (`` ($_ seq - (~~ (do-template [ ] + (~~ (do-template [ ] [(test - (|> (run (#synthesis.Extension (list))) - (case> (#error.Success valueT) - ( (:coerce Frac valueT)) + (|> (run (#synthesis.Extension (list (synthesis.f64 subject) + (synthesis.f64 param)))) + (&.check ( param subject))))] + + ["lux f64 +" f/+ f/=] + ["lux f64 -" f/- f/=] + ["lux f64 *" f/* f/=] + ["lux f64 /" f// f/=] + ["lux f64 %" f/% f/=] + )) + (~~ (do-template [ ] + [(test + (|> (run (#synthesis.Extension (list (synthesis.f64 subject) + (synthesis.f64 param)))) + (case> (#error.Success valueV) + (bit/= ( param subject) + (:coerce Bit valueV)) _ #0)))] - ["lux f64 min" (f/= frac/bottom)] - ["lux f64 max" (f/= frac/top)] - ["lux f64 smallest" (f/= ("lux frac smallest"))] + ["lux f64 =" f/=] + ["lux f64 <" f/<] + )) + (~~ (do-template [ ] + [(test + (|> (run (#synthesis.Extension (list))) + (&.check )))] + + ["lux f64 min" frac/bottom] + ["lux f64 max" frac/top] + ["lux f64 smallest" ("lux frac smallest")] )) (test "\"lux f64 to-i64\" && \"lux i64 to-f64\"" (|> (run (|> subject synthesis.f64 (list) (#synthesis.Extension "lux f64 to-i64") (list) (#synthesis.Extension "lux i64 to-f64"))) - (case> (#error.Success valueT) - (f/= subject (:coerce Frac valueT)) - - (#error.Error error) - (exec (log! error) - #0)))) + (&.check subject))) )))) -(def: (f64-spec run) - (-> Runner Test) - ($_ seq - (f64-spec/0 run) - (f64-spec/1 run))) - (def: (text-spec run) (-> Runner Test) (do r.Monad [sample-size (|> r.nat (:: @ map (|>> (n/% 10) (n/max 1)))) - sample0 (r.ascii/lower-alpha sample-size) - sample1 (r.ascii/upper-alpha sample-size) - sample2 (|> (r.ascii/alpha sample-size) - (r.filter (|>> (text/= sample1) not))) + sample-lower (r.ascii/lower-alpha sample-size) + sample-upper (r.ascii/upper-alpha sample-size) + sample-alpha (|> (r.ascii/alpha sample-size) + (r.filter (|>> (text/= sample-upper) not))) char-idx (|> r.nat (:: @ map (n/% sample-size))) - #let [sample0S (synthesis.text sample0) - sample1S (synthesis.text sample1) - sample2S (synthesis.text sample2) - concatenatedS (#synthesis.Extension "lux text concat" (list sample0S sample1S)) - pre-rep-once (format sample0 sample1) - post-rep-once (format sample0 sample2) - pre-rep-all (|> (list.repeat sample-size sample0) (text.join-with sample1)) - post-rep-all (|> (list.repeat sample-size sample0) (text.join-with sample2))]] + #let [sample-lowerS (synthesis.text sample-lower) + sample-upperS (synthesis.text sample-upper) + sample-alphaS (synthesis.text sample-alpha) + concatenatedS (#synthesis.Extension "lux text concat" (list sample-lowerS sample-upperS)) + pre-rep-once (format sample-lower sample-upper) + post-rep-once (format sample-lower sample-alpha) + pre-rep-all (|> (list.repeat sample-size sample-lower) (text.join-with sample-upper)) + post-rep-all (|> (list.repeat sample-size sample-lower) (text.join-with sample-alpha))]] ($_ seq (test "Can compare texts for equality." - (and (|> (run (#synthesis.Extension "lux text =" (list sample0S sample0S))) + (and (|> (run (#synthesis.Extension "lux text =" (list sample-lowerS sample-lowerS))) (case> (#error.Success valueV) (:coerce Bit valueV) _ #0)) - (|> (run (#synthesis.Extension "lux text =" (list sample0S sample1S))) + (|> (run (#synthesis.Extension "lux text =" (list sample-lowerS sample-upperS))) (case> (#error.Success valueV) (not (:coerce Bit valueV)) _ #0)))) (test "Can compare texts for order." - (|> (run (#synthesis.Extension "lux text <" (list sample1S sample0S))) + (|> (run (#synthesis.Extension "lux text <" (list sample-upperS sample-lowerS))) (case> (#error.Success valueV) (:coerce Bit valueV) (#error.Error error) - (exec (log! error) - #0)))) + #0))) (test "Can get length of text." - (|> (run (#synthesis.Extension "lux text size" (list sample0S))) + (|> (run (#synthesis.Extension "lux text size" (list sample-lowerS))) (case> (#error.Success valueV) (n/= sample-size (:coerce Nat valueV)) @@ -226,7 +212,7 @@ #0))) (test "Can find index of sub-text." (and (|> (run (#synthesis.Extension "lux text index" - (list concatenatedS sample0S + (list concatenatedS sample-lowerS (synthesis.i64 +0)))) (case> (^multi (#error.Success valueV) [(:coerce (Maybe Nat) valueV) (#.Some valueV)]) @@ -235,7 +221,7 @@ _ #0)) (|> (run (#synthesis.Extension "lux text index" - (list concatenatedS sample1S + (list concatenatedS sample-upperS (synthesis.i64 +0)))) (case> (^multi (#error.Success valueV) [(:coerce (Maybe Nat) valueV) (#.Some valueV)]) @@ -256,16 +242,16 @@ _ #0))))] (test "Can clip text to extract sub-text." - (and (test-clip 0 sample-size sample0) - (test-clip sample-size (n/* 2 sample-size) sample1)))) + (and (test-clip 0 sample-size sample-lower) + (test-clip sample-size (n/* 2 sample-size) sample-upper)))) (test "Can extract individual characters from text." (|> (run (#synthesis.Extension "lux text char" - (list sample0S + (list sample-lowerS (synthesis.i64 char-idx)))) (case> (^multi (#error.Success valueV) [(:coerce (Maybe Int) valueV) (#.Some valueV)]) (text.contains? ("lux int char" valueV) - sample0) + sample-lower) _ #0))) @@ -283,8 +269,7 @@ #1 (#error.Error error) - (exec (log! error) - #0)))) + #0))) (test "Can throw runtime errors." (and (|> (run (#synthesis.Extension "lux try" (list (synthesis.function/abstraction @@ -317,8 +302,7 @@ (n/>= pre post)) (#error.Error error) - (exec (log! error) - #0)))) + #0))) ))) (def: (all-specs run) @@ -331,38 +315,38 @@ (io-spec run) )) -(context: "[JVM] Common procedures." +(context: "[JVM] Common extensions." (<| (times 100) (all-specs common.run-jvm))) -## (context: "[JS] Common procedures." +## (context: "[JS] Common extensions." ## (<| (times 100) ## (all-specs common.run-js))) -## (context: "[Lua] Common procedures." +## (context: "[Lua] Common extensions." ## (<| (times 100) ## (all-specs common.run-lua))) -## (context: "[Ruby] Common procedures." +## (context: "[Ruby] Common extensions." ## (<| (times 100) ## (all-specs common.run-ruby))) -## (context: "[Python] Common procedures." +## (context: "[Python] Common extensions." ## (<| (times 100) ## (all-specs common.run-python))) -## (context: "[R] Common procedures." +## (context: "[R] Common extensions." ## (<| (times 100) ## (all-specs common.run-r))) -## (context: "[Scheme] Common procedures." +## (context: "[Scheme] Common extensions." ## (<| (times 100) ## (all-specs common.run-scheme))) -## (context: "[Common Lisp] Common procedures." +## (context: "[Common Lisp] Common extensions." ## (<| (times 100) ## (all-specs common.run-common-lisp))) -## (context: "[PHP] Common procedures." +## (context: "[PHP] Common extensions." ## (<| (times 100) ## (all-specs common.run-php))) diff --git a/new-luxc/test/test/luxc/lang/translation/function.lux b/new-luxc/test/test/luxc/lang/translation/function.lux index 981dbb889..ef5bf7b67 100644 --- a/new-luxc/test/test/luxc/lang/translation/function.lux +++ b/new-luxc/test/test/luxc/lang/translation/function.lux @@ -1,18 +1,21 @@ (.module: - [lux #* + [lux (#- function) [control [monad (#+ do)] pipe] [data ["." maybe] ["." error (#+ Error)] + ["." number] + [text + format] [collection ["." list ("list/." Functor)]]] [math - ["r" random ("r/." Monad)]] + ["r" random (#+ Random) ("r/." Monad)]] [compiler [default - ["." reference] + ["." reference (#+ Register)] [phase [analysis (#+ Arity)] ["." synthesis (#+ Synthesis)]]]] @@ -21,77 +24,83 @@ [luxc ["." common (#+ Runner)]]]) -(def: max-arity Nat 10) +(def: max-arity Arity 10) (def: arity - (r.Random Arity) + (Random Arity) (|> r.nat (r/map (|>> (n/% max-arity) (n/max 1))))) -(def: gen-function - (r.Random [Arity Nat Synthesis]) +(def: (local arity) + (-> Arity(Random Register)) + (|> r.nat (r/map (|>> (n/% arity) inc)))) + +(def: function + (Random [Arity Register Synthesis]) (do r.Monad - [arity arity - arg (|> r.nat (:: @ map (n/% arity)))] - (wrap [arity arg + [arity ..arity + local (..local arity)] + (wrap [arity local (synthesis.function/abstraction {#synthesis.environment (list) #synthesis.arity arity - #synthesis.body (synthesis.variable/local arg)})]))) - -(def: upper-alpha-ascii - (r.Random Nat) - (|> r.nat (:: r.Functor map (|>> (n/% 26) (n/+ 65))))) + #synthesis.body (synthesis.variable/local local)})]))) (def: #export (check reference) (-> Frac (Error Any) Bit) (|>> (case> (#error.Success valueT) - (|> valueT (:coerce Frac) (f/= reference)) + (f/= reference (:coerce Frac valueT)) (#error.Error error) (exec (log! error) #0)))) +(def: #export safe-frac + (Random Frac) + (|> r.frac (r.filter (|>> number.not-a-number? not)))) + (def: (function-spec run) (-> Runner Test) (do r.Monad - [[arity arg functionS] gen-function - cut-off (|> r.nat (:: @ map (n/% arity))) - args (r.list arity r.frac) - #let [arg-value (maybe.assume (list.nth arg args)) - argsS (list/map (|>> synthesis.f64) args) - last-arg (dec arity) - cut-off (|> cut-off (n/min (dec last-arg)))]] + [[arity local functionS] ..function + partial-arity (|> r.nat (:: @ map (|>> (n/% arity) (n/max 1)))) + inputs (r.list arity safe-frac) + #let [expectation (maybe.assume (list.nth (dec local) inputs)) + inputsS (list/map (|>> synthesis.f64) inputs)]] ($_ seq (test "Can read arguments." - (|> (run (synthesis.function/apply [functionS argsS])) - (check arg-value))) + (|> (run (synthesis.function/apply {#synthesis.function functionS + #synthesis.arguments inputsS})) + (check expectation))) (test "Can partially apply functions." (or (n/= 1 arity) - (let [partial-arity (inc cut-off) - preS (list.take partial-arity argsS) - postS (list.drop partial-arity argsS)] - (|> (run (synthesis.function/apply {#synthesis.function (synthesis.function/apply {#synthesis.function functionS - #synthesis.arguments preS}) - #synthesis.arguments postS})) - (check arg-value))))) + (let [preS (list.take partial-arity inputsS) + postS (list.drop partial-arity inputsS) + partialS (synthesis.function/apply {#synthesis.function functionS + #synthesis.arguments preS}) + totalS (synthesis.function/apply {#synthesis.function partialS + #synthesis.arguments postS})] + (|> (run totalS) + (check expectation))))) (test "Can read environment." (or (n/= 1 arity) - (let [environment (|> (list.n/range 0 cut-off) + (let [environment (|> partial-arity + (list.n/range 1) (list/map (|>> #reference.Local))) - arity::super (inc cut-off) - argument (if (n/<= cut-off arg) - (synthesis.variable/foreign arg) - (synthesis.variable/local (n/- (dec arity::super) arg))) - arity::sub (|> arity (n/- arity::super)) - functionS (synthesis.function/abstraction - {#synthesis.environment (list) - #synthesis.arity arity::super - #synthesis.body (synthesis.function/abstraction - {#synthesis.environment environment - #synthesis.arity arity::sub - #synthesis.body argument})})] - (|> (run (synthesis.function/apply [functionS argsS])) - (check arg-value))))) + variableS (if (n/<= partial-arity local) + (synthesis.variable/foreign (dec local)) + (synthesis.variable/local (|> local (n/- partial-arity)))) + inner-arity (n/- partial-arity arity) + innerS (synthesis.function/abstraction + {#synthesis.environment environment + #synthesis.arity inner-arity + #synthesis.body variableS}) + outerS (synthesis.function/abstraction + {#synthesis.environment (list) + #synthesis.arity partial-arity + #synthesis.body innerS})] + (|> (run (synthesis.function/apply {#synthesis.function outerS + #synthesis.arguments inputsS})) + (check expectation))))) ))) (context: "[JVM] Function." diff --git a/new-luxc/test/test/luxc/lang/translation/reference.lux b/new-luxc/test/test/luxc/lang/translation/reference.lux index c1a348f76..18205a560 100644 --- a/new-luxc/test/test/luxc/lang/translation/reference.lux +++ b/new-luxc/test/test/luxc/lang/translation/reference.lux @@ -4,15 +4,14 @@ [monad (#+ do)] pipe] [data - ["e" error] - ["." text]] + ["." number]] [compiler [default ["." reference] [phase ["." synthesis]]]] [math - ["r" random]] + ["r" random (#+ Random)]] test] [test [luxc @@ -20,16 +19,16 @@ [// ["&" function]]) -(def: name^ - (r.Random Name) +(def: name + (Random Name) (let [name-part (r.ascii/upper-alpha 5)] [(r.and name-part name-part)])) (def: (definitions-spec define) (-> Definer Test) (do r.Monad - [name name^ - value r.frac] + [name ..name + value &.safe-frac] (test "Can refer to definitions." (|> (define name (synthesis.f64 value)) (&.check value))))) @@ -38,7 +37,7 @@ (-> Runner Test) (do r.Monad [register (|> r.nat (:: @ map (n/% 100))) - value r.frac] + value &.safe-frac] (test "Can refer to local variables/registers." (|> (run (synthesis.branch/let [(synthesis.f64 value) register diff --git a/stdlib/source/lux/compiler/default/phase/synthesis.lux b/stdlib/source/lux/compiler/default/phase/synthesis.lux index 29c2189c3..bf60c9798 100644 --- a/stdlib/source/lux/compiler/default/phase/synthesis.lux +++ b/stdlib/source/lux/compiler/default/phase/synthesis.lux @@ -3,8 +3,11 @@ [control [monad (#+ do)]] [data [error (#+ Error)] + ["." text + format] [collection - ["dict" dictionary (#+ Dictionary)]]]] + [list ("list/." Functor)] + ["." dictionary (#+ Dictionary)]]]] ["." // ["." analysis (#+ Environment Arity Analysis)] ["." extension (#+ Extension)] @@ -21,7 +24,7 @@ (def: #export fresh-resolver Resolver - (dict.new reference.Hash)) + (dictionary.new reference.Hash)) (def: #export init State @@ -268,3 +271,30 @@ [function/abstraction #..Function #..Abstraction] [function/apply #..Function #..Apply] ) + +(def: #export (%synthesis value) + (Format Synthesis) + (case value + (^template [ ] + (^ ( value)) + ( value)) + ([..bit %b] + [..f64 %f] + [..text %t]) + + (^ (..i64 value)) + (%n (.nat value)) + + (^ (..variant [lefts right? content])) + (|> (%synthesis content) + (format (%n lefts) " " (%b right?) " ") + (text.enclose ["(" ")"])) + + (^ (..tuple members)) + (|> members + (list/map %synthesis) + (text.join-with " ") + (text.enclose ["[" "]"])) + + _ + "???")) diff --git a/stdlib/source/lux/math/random.lux b/stdlib/source/lux/math/random.lux index eab1ae04c..92eced24d 100644 --- a/stdlib/source/lux/math/random.lux +++ b/stdlib/source/lux/math/random.lux @@ -25,8 +25,7 @@ [tree ["." finger (#+ Tree)]]]] [type - [refinement (#+ Refiner Refined)]] - ]) + [refinement (#+ Refiner Refined)]]]) (type: #export #rec PRNG {#.doc "An abstract way to represent any PRNG."} diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux index 702f7f342..572a69e02 100644 --- a/stdlib/test/tests.lux +++ b/stdlib/test/tests.lux @@ -42,6 +42,7 @@ [compiler [host [".H" scheme]] + ["._" cli] ["._" default ["._" evaluation] [phase @@ -58,15 +59,15 @@ ["._scheme" expression]]] [extension ["._" statement]]] - ["._default" cache] - [repl - ["._" type]]] + ["._default" cache]] [meta ["._meta" io ["._meta_io" context] ["._meta_io" archive]] ["._meta" archive] - ["._meta" cache]]]] + ["._meta" cache]]] + ["._" interpreter + ["._interpreter" type]]] ## TODO: Must have 100% coverage on tests. [test ["_." lux] -- cgit v1.2.3