diff options
Diffstat (limited to '')
7 files changed, 145 insertions, 166 deletions
diff --git a/stdlib/source/lux/abstract/interval.lux b/stdlib/source/lux/abstract/interval.lux index f5c3ce656..17e749804 100644 --- a/stdlib/source/lux/abstract/interval.lux +++ b/stdlib/source/lux/abstract/interval.lux @@ -1,3 +1,4 @@ +## https://en.wikipedia.org/wiki/Interval_(mathematics) (.module: [lux #*] [// diff --git a/stdlib/source/lux/target/jvm/bytecode.lux b/stdlib/source/lux/target/jvm/bytecode.lux index a31b90195..bba140a7a 100644 --- a/stdlib/source/lux/target/jvm/bytecode.lux +++ b/stdlib/source/lux/target/jvm/bytecode.lux @@ -9,8 +9,7 @@ ["." state (#+ State')] ["." function] ["." try (#+ Try)] - ["." exception (#+ exception:)] - ["." pipe (#+ when>)]] + ["." exception (#+ exception:)]] [data ["." product] ["." maybe] @@ -124,13 +123,13 @@ ["Expected" (/stack.format expected)] ["Actual" (/stack.format actual)])) -(with-expansions [<success> (as-is (#try.Success [[pool - environment - (update@ #known - (dictionary.put label [actual (#.Some @here)]) - tracker)] - [..relative-identity - []]]))] +(with-expansions [<success> (as-is (wrap [[pool + environment + (update@ #known + (dictionary.put label [actual (#.Some @here)]) + tracker)] + [..relative-identity + []]]))] (def: #export (set-label label) (-> Label (Bytecode Any)) (function (_ [pool environment tracker]) @@ -193,7 +192,7 @@ (wrap [[pool environment' (set@ #program-counter program-counter' tracker)] - [(function.constant (#try.Success [..no-exceptions (bytecode input)])) + [(function.constant (wrap [..no-exceptions (bytecode input)])) []]])))) (template [<name> <frames>] @@ -408,11 +407,11 @@ (function (_ [pool environment tracker]) (do try.monad [_ (/environment.stack environment)] - (#try.Success [[pool - (/environment.discontinue environment) - tracker] - [..relative-identity - []]])))) + (wrap [[pool + (/environment.discontinue environment) + tracker] + [..relative-identity + []]])))) (template [<name> <consumption> <instruction>] [(def: #export <name> @@ -660,6 +659,15 @@ #.None (exception.throw ..unknown-label [label]))) +(def: (acknowledge-label stack label tracker) + (-> Stack Label Tracker Tracker) + (case (dictionary.get label (get@ #known tracker)) + (#.Some _) + tracker + + #.None + (update@ #known (dictionary.put label [stack #.None]) tracker))) + (template [<consumption> <name> <instruction>] [(def: #export (<name> label) (-> Label (Bytecode Any)) @@ -675,8 +683,7 @@ [[pool environment' (|> tracker - (when> [(get@ #known) (dictionary.contains? label) not] - [(update@ #known (dictionary.put label [actual #.None]))]) + (..acknowledge-label actual label) (set@ #program-counter program-counter'))] [(function (_ resolver) (do try.monad @@ -689,7 +696,7 @@ (exception.throw ..cannot-do-a-big-jump [label @from jump]) (#.Right jump) - (#try.Success [..no-exceptions (bytecode jump)])))) + (wrap [..no-exceptions (bytecode jump)])))) []]])))))))] [$1 ifeq _.ifeq] @@ -713,71 +720,49 @@ [$2 if-acmpne _.if-acmpne] ) -(def: #export (goto label) - (-> Label (Bytecode Any)) - (let [[estimator bytecode] _.goto] - (function (_ [pool environment tracker]) - (do try.monad - [#let [@here (get@ #program-counter tracker)] - program-counter' (step estimator @here)] - (wrap (let [@from @here] - [[pool - (/environment.discontinue environment) - (set@ #program-counter program-counter' tracker)] - [(function (_ resolver) - (case (dictionary.get label resolver) - (#.Some [expected (#.Some @to)]) - (do try.monad - [actual (/environment.stack environment) - _ (exception.assert ..mismatched-environments [(name-of _.goto) label @here expected actual] - (:: /stack.equivalence = expected actual)) - jump (..jump @from @to)] - (case jump - (#.Left jump) - (exception.throw ..cannot-do-a-big-jump [label @from jump]) - - (#.Right jump) - (#try.Success [..no-exceptions (bytecode jump)]))) - - (#.Some [expected #.None]) - (exception.throw ..unset-label [label]) - - #.None - (exception.throw ..unknown-label [label]))) - []]])))))) +(template [<name> <instruction> <on-long-jump> <on-short-jump>] + [(def: #export (<name> label) + (-> Label (Bytecode Any)) + (let [[estimator bytecode] <instruction>] + (function (_ [pool environment tracker]) + (do try.monad + [actual (/environment.stack environment) + #let [@here (get@ #program-counter tracker)] + program-counter' (step estimator @here)] + (wrap (let [@from @here] + [[pool + (/environment.discontinue environment) + (|> tracker + (..acknowledge-label actual label) + (set@ #program-counter program-counter'))] + [(function (_ resolver) + (case (dictionary.get label resolver) + (#.Some [expected (#.Some @to)]) + (do try.monad + [_ (exception.assert ..mismatched-environments [(name-of <instruction>) label @here expected actual] + (:: /stack.equivalence = expected actual)) + jump (..jump @from @to)] + (case jump + (#.Left jump) + <on-long-jump> -(def: #export (goto-w label) - (-> Label (Bytecode Any)) - (let [[estimator bytecode] _.goto-w] - (function (_ [pool environment tracker]) - (do try.monad - [#let [@here (get@ #program-counter tracker)] - program-counter' (step estimator @here)] - (wrap (let [@from @here] - [[pool - (/environment.discontinue environment) - (set@ #program-counter program-counter' tracker)] - [(function (_ resolver) - (case (dictionary.get label resolver) - (#.Some [expected (#.Some @to)]) - (do try.monad - [actual (/environment.stack environment) - _ (exception.assert ..mismatched-environments [(name-of _.goto-w) label @here expected actual] - (:: /stack.equivalence = expected actual)) - jump (..jump @from @to)] - (case jump - (#.Left jump) - (#try.Success [..no-exceptions (bytecode jump)]) - - (#.Right jump) - (#try.Success [..no-exceptions (bytecode (/jump.lift jump))]))) - - (#.Some [expected #.None]) - (exception.throw ..unset-label [label]) - - #.None - (exception.throw ..unknown-label [label]))) - []]])))))) + (#.Right jump) + <on-short-jump>)) + + (#.Some [expected #.None]) + (exception.throw ..unset-label [label]) + + #.None + (exception.throw ..unknown-label [label]))) + []]]))))))] + + [goto _.goto + (exception.throw ..cannot-do-a-big-jump [label @from jump]) + (wrap [..no-exceptions (bytecode jump)])] + [goto-w _.goto-w + (wrap [..no-exceptions (bytecode jump)]) + (wrap [..no-exceptions (bytecode (/jump.lift jump))])] + ) (def: (big-jump jump) (-> Any-Jump Big-Jump) @@ -797,18 +782,20 @@ (do try.monad [environment' (|> environment (/environment.consumes $1)) + actual (/environment.stack environment') program-counter' (step (estimator (list.size afterwards)) (get@ #program-counter tracker))] (wrap (let [@from (get@ #program-counter tracker)] - [[pool environment' (set@ #program-counter program-counter' tracker)] + [[pool + environment' + (|> (list@fold (..acknowledge-label actual) tracker (list& default at-minimum afterwards)) + (set@ #program-counter program-counter'))] [(function (_ resolver) (let [get (: (-> Label (Maybe [Stack (Maybe Address)])) (function (_ label) (dictionary.get label resolver)))] (case (do maybe.monad - [[_ @default] (get default) - @default @default - [_ @at-minimum] (get at-minimum) - @at-minimum @at-minimum + [@default (|> default get (monad.bind @ product.right)) + @at-minimum (|> at-minimum get (monad.bind @ product.right)) @afterwards (|> afterwards (monad.map @ get) (monad.bind @ (monad.map @ product.right)))] @@ -819,7 +806,7 @@ >at-minimum (:: @ map ..big-jump (..jump @from @at-minimum)) >afterwards (monad.map @ (|>> (..jump @from) (:: @ map ..big-jump)) @afterwards)] - (#try.Success [..no-exceptions (bytecode minimum >default [>at-minimum >afterwards])])) + (wrap [..no-exceptions (bytecode minimum >default [>at-minimum >afterwards])])) #.None (exception.throw ..invalid-tableswitch [])))) @@ -838,16 +825,19 @@ (do try.monad [environment' (|> environment (/environment.consumes $1)) + actual (/environment.stack environment') program-counter' (step (estimator (list.size cases)) (get@ #program-counter tracker))] (wrap (let [@from (get@ #program-counter tracker)] - [[pool environment' (set@ #program-counter program-counter' tracker)] + [[pool + environment' + (|> (list@fold (..acknowledge-label actual) tracker (list& default (list@map product.right cases))) + (set@ #program-counter program-counter'))] [(function (_ resolver) (let [get (: (-> Label (Maybe [Stack (Maybe Address)])) (function (_ label) (dictionary.get label resolver)))] (case (do maybe.monad - [[_ @default] (get default) - @default @default + [@default (|> default get (monad.bind @ product.right)) @cases (|> cases (monad.map @ (|>> product.right get)) (monad.bind @ (monad.map @ product.right)))] @@ -858,7 +848,7 @@ >cases (|> @cases (monad.map @ (|>> (..jump @from) (:: @ map ..big-jump))) (:: @ map (|>> (list.zip2 (list@map product.left cases)))))] - (#try.Success [..no-exceptions (bytecode >default >cases)])) + (wrap [..no-exceptions (bytecode >default >cases)])) #.None (exception.throw ..invalid-lookupswitch [])))) @@ -972,9 +962,7 @@ (#try.Success [[pool environment - (|> tracker - (when> [(get@ #known) (dictionary.contains? @handler) not] - [(update@ #known (dictionary.put @handler [/stack.catch #.None]))]))] + (..acknowledge-label /stack.catch @handler tracker)] [(function (_ resolver) (do try.monad [[_ @start] (..resolve-label @start resolver) diff --git a/stdlib/source/lux/target/jvm/encoding/unsigned.lux b/stdlib/source/lux/target/jvm/encoding/unsigned.lux index 4286976dc..65e3632f7 100644 --- a/stdlib/source/lux/target/jvm/encoding/unsigned.lux +++ b/stdlib/source/lux/target/jvm/encoding/unsigned.lux @@ -41,16 +41,20 @@ (n.< (:representation reference) (:representation sample)))) - (exception: #export (value-exceeds-the-maximum {value Nat} + (exception: #export (value-exceeds-the-maximum {type Name} + {value Nat} {maximum (Unsigned Any)}) (exception.report + ["Type" (%.name type)] ["Value" (%.nat value)] ["Maximum" (%.nat (:representation maximum))])) (exception: #export [brand] (subtraction-cannot-yield-negative-value + {type Name} {parameter (Unsigned brand)} {subject (Unsigned brand)}) (exception.report + ["Type" (%.name type)] ["Parameter" (%.nat (:representation parameter))] ["Subject" (%.nat (:representation subject))])) @@ -69,7 +73,7 @@ (-> Nat (Try <name>)) (if (n.<= (:representation <maximum>) value) (#try.Success (:abstraction value)) - (exception.throw ..value-exceeds-the-maximum [value <maximum>]))) + (exception.throw ..value-exceeds-the-maximum [(name-of <name>) value <maximum>]))) (def: #export (<+> parameter subject) (-> <name> <name> (Try <name>)) @@ -83,7 +87,7 @@ subject' (:representation subject)] (if (n.<= subject' parameter') (#try.Success (:abstraction (n.- parameter' subject'))) - (exception.throw ..subtraction-cannot-yield-negative-value [parameter subject])))) + (exception.throw ..subtraction-cannot-yield-negative-value [(name-of <name>) parameter subject])))) (def: #export (<max> left right) (-> <name> <name> <name>) diff --git a/stdlib/source/lux/target/jvm/type.lux b/stdlib/source/lux/target/jvm/type.lux index e5c7304ee..1dd5af027 100644 --- a/stdlib/source/lux/target/jvm/type.lux +++ b/stdlib/source/lux/target/jvm/type.lux @@ -5,7 +5,8 @@ [hash (#+ Hash)]] [data ["." maybe] - ["." text] + ["." text + ["%" format (#+ Format)]] [number ["n" nat]] [collection @@ -195,3 +196,7 @@ (text.size repr))) (:: maybe.monad map (|>> //name.internal //name.external))) #.None))) + +(def: #export format + (All [a] (Format (Type a))) + (|>> ..signature /signature.signature)) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/apply.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/apply.lux index 68e81845b..ba9b80add 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/apply.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/apply.lux @@ -89,16 +89,12 @@ _.areturn) _ (do _.monad [@default _.new-label - #let [failure ($_ _.compose - (_.set-label @default) - ////runtime.apply-failure - _.aconst-null - _.areturn)] @labelsH _.new-label @labelsT (|> _.new-label (list.repeat (dec num-partials)) (monad.seq _.monad)) - #let [cases (|> (#.Cons [@labelsH @labelsT]) + #let [cases (|> (list@compose (#.Cons [@labelsH @labelsT]) + (list @default)) list.enumerate (list@map (function (_ [stage @case]) (let [current-partials (|> (list.indices stage) @@ -107,53 +103,51 @@ already-partial? (n.> 0 stage) exact-match? (i.= over-extent (.int stage)) has-more-than-necessary? (i.> over-extent (.int stage))] - (cond exact-match? - ($_ _.compose - (_.set-label @case) - ////reference.this - (if already-partial? - (_.invokevirtual class //reset.name (//reset.type class)) - (_@wrap [])) - current-partials - (..inputs ..this-offset apply-arity) - (_.invokevirtual class //implementation.name (//implementation.type function-arity)) - _.areturn) - - has-more-than-necessary? - (let [inputs-to-completion (|> function-arity (n.- stage)) - inputs-left (|> apply-arity (n.- inputs-to-completion))] - ($_ _.compose - (_.set-label @case) - ////reference.this - (_.invokevirtual class //reset.name (//reset.type class)) - current-partials - (..inputs ..this-offset inputs-to-completion) - (_.invokevirtual class //implementation.name (//implementation.type function-arity)) - (apply (n.+ ..this-offset inputs-to-completion) inputs-left) - _.areturn)) + ($_ _.compose + (_.set-label @case) + (cond exact-match? + ($_ _.compose + ////reference.this + (if already-partial? + (_.invokevirtual class //reset.name (//reset.type class)) + (_@wrap [])) + current-partials + (..inputs ..this-offset apply-arity) + (_.invokevirtual class //implementation.name (//implementation.type function-arity)) + _.areturn) + + has-more-than-necessary? + (let [inputs-to-completion (|> function-arity (n.- stage)) + inputs-left (|> apply-arity (n.- inputs-to-completion))] + ($_ _.compose + ////reference.this + (_.invokevirtual class //reset.name (//reset.type class)) + current-partials + (..inputs ..this-offset inputs-to-completion) + (_.invokevirtual class //implementation.name (//implementation.type function-arity)) + (apply (n.+ ..this-offset inputs-to-completion) inputs-left) + _.areturn)) - ## (i.< over-extent (.int stage)) - (let [current-environment (|> (list.indices (list.size environment)) - (list@map (///foreign.get class)) - (monad.seq _.monad)) - missing-partials (|> _.aconst-null - (list.repeat (|> num-partials (n.- apply-arity) (n.- stage))) - (monad.seq _.monad))] - ($_ _.compose - (_.set-label @case) - (_.new class) - _.dup - current-environment - ///partial/count.value - (..increment apply-arity) - current-partials - (..inputs ..this-offset apply-arity) - missing-partials - (_.invokevirtual class //init.name (//init.type environment function-arity)) - _.areturn)))))) + ## (i.< over-extent (.int stage)) + (let [current-environment (|> (list.indices (list.size environment)) + (list@map (///foreign.get class)) + (monad.seq _.monad)) + missing-partials (|> _.aconst-null + (list.repeat (|> num-partials (n.- apply-arity) (n.- stage))) + (monad.seq _.monad))] + ($_ _.compose + (_.new class) + _.dup + current-environment + ///partial/count.value + (..increment apply-arity) + current-partials + (..inputs ..this-offset apply-arity) + missing-partials + (_.invokevirtual class //init.name (//init.type environment function-arity)) + _.areturn))))))) (monad.seq _.monad))]] ($_ _.compose ///partial/count.value (_.tableswitch (try.assume (signed.s4 +0)) @default [@labelsH @labelsT]) - ## cases - failure))))))) + cases))))))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/init.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/init.lux index 0a51d555d..7308c0734 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/init.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/init.lux @@ -41,7 +41,7 @@ (def: (partials arity) (-> Arity (List (Type Value))) - (list.repeat arity ////type.value)) + (list.repeat (dec arity) ////type.value)) (def: #export (type environment arity) (-> Environment Arity (Type category.Method)) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux index 89a1b94c1..99a8ed79a 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux @@ -230,12 +230,6 @@ (..illegal-state-exception message) _.athrow)))) -(def: apply-failure::name "apply_failure") -(def: #export apply-failure (..procedure ..apply-failure::name ..failure::type)) - -(def: apply-failure::method - (..failure ..apply-failure::name "Error while applying function.")) - (def: pm-failure::name "pm_failure") (def: #export pm-failure (..procedure ..pm-failure::name ..failure::type)) @@ -515,7 +509,6 @@ (list ..decode-frac::method ..variant::method - ..apply-failure::method ..pm-failure::method ..push::method @@ -547,16 +540,10 @@ (_.aload arity) (_.invokevirtual //function.class ..apply::name (..apply::type //function/arity.minimum)) _.areturn)))))) - (list& (method.method method.public + (list& (method.method (modifier@compose method.public method.abstract) ..apply::name (..apply::type //function/arity.minimum) (list) - ## TODO: It shouldn't be necessary to set the code for this method, since it's abstract. - ## Setting this might be a bug. Verify & fix ASAP. - (#.Some - ($_ _.compose - ..apply-failure - ..this - _.areturn))))) + #.None))) <init>::method (method.method method.public "<init>" //function.init (list) (#.Some |