diff options
Diffstat (limited to 'stdlib/source/library/lux/meta/compiler/target/jvm')
38 files changed, 6022 insertions, 0 deletions
diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/attribute.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/attribute.lux new file mode 100644 index 000000000..04d68cb41 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/attribute.lux @@ -0,0 +1,199 @@ +(.require + [library + [lux (.except Info Code Type #info) + [abstract + [monad (.only do)] + ["[0]" equivalence (.only Equivalence)]] + [control + ["[0]" try]] + [data + ["[0]" sum] + ["[0]" product] + ["[0]" binary + ["[1]F" \\format (.only Format)]]] + [math + [number + ["n" nat]]] + [meta + [macro + ["^" pattern]]]]] + ["[0]" // + ["[1][0]" index (.only Index)] + ["[1][0]" type (.only Type) + ["[2][0]" signature (.only Signature)]] + [encoding + ["[1][0]" unsigned (.only U2 U4)]] + ["[1][0]" constant (.only UTF8 Class Value) + ["[2][0]" pool (.only Pool Resource) (.use "[1]#[0]" monad)]]] + ["[0]" / + ["[1][0]" constant (.only Constant)] + ["[1][0]" code] + ["[1][0]" line_number_table (.only Line_Number_Table)]]) + +(type .public (Info about) + (Record + [#name (Index UTF8) + #length U4 + #info about])) + +(def .public (info_equivalence Equivalence<about>) + (All (_ about) + (-> (Equivalence about) + (Equivalence (Info about)))) + (all product.equivalence + //index.equivalence + //unsigned.equivalence + Equivalence<about>)) + +(def (info_format format) + (All (_ about) + (-> (Format about) + (Format (Info about)))) + (function (_ [name length info]) + (let [[nameS nameT] (//index.format name) + [lengthS lengthT] (//unsigned.format/4 length) + [infoS infoT] (format info)] + [(all n.+ nameS lengthS infoS) + (|>> nameT lengthT infoT)]))) + +(with_expansions [<Code> (these (/code.Code Attribute))] + (type .public Attribute + (Rec Attribute + (Variant + {#Constant (Info (Constant Any))} + {#Code (Info <Code>)} + {#Signature (Info (Index UTF8))} + {#Source_File (Info (Index UTF8))} + {#Line_Number_Table (Info Line_Number_Table)}))) + + (type .public Code + <Code>) + ) + +(def .public equivalence + (Equivalence Attribute) + (equivalence.rec + (function (_ equivalence) + (all sum.equivalence + (info_equivalence /constant.equivalence) + (info_equivalence (/code.equivalence equivalence)) + (info_equivalence //index.equivalence) + (info_equivalence //index.equivalence) + (info_equivalence /line_number_table.equivalence) + )))) + +(def common_attribute_length + (all n.+ + ... u2 attribute_name_index; + //unsigned.bytes/2 + ... u4 attribute_length; + //unsigned.bytes/4 + )) + +(def (length attribute) + (-> Attribute Nat) + (when attribute + (^.with_template [<tag>] + [{<tag> [name length info]} + (|> length //unsigned.value (n.+ ..common_attribute_length))]) + ([#Constant] + [#Code] + [#Signature] + [#Source_File] + [#Line_Number_Table]))) + +... TODO: Inline ASAP +(def (constant' index @name) + (-> (Constant Any) (Index UTF8) Attribute) + {#Constant [#name @name + ... https://docs.oracle.com/javase/specs/jvms/se7/html/jvms-4.html#jvms-4.7.2 + #length (|> /constant.length //unsigned.u4 try.trusted) + #info index]}) + +(def .public (constant index) + (-> (Constant Any) (Resource Attribute)) + (//pool#each (constant' index) (//pool.utf8 "ConstantValue"))) + +... TODO: Inline ASAP +(def (code' specification @name) + (-> Code (Index UTF8) Attribute) + {#Code [#name @name + ... https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.7.3 + #length (|> specification + (/code.length ..length) + //unsigned.u4 + try.trusted) + #info specification]}) + +(def .public (code specification) + (-> Code (Resource Attribute)) + (//pool#each (code' specification) (//pool.utf8 "Code"))) + +... TODO: Inline ASAP +(def (signature' it @name) + (-> (Index UTF8) (Index UTF8) Attribute) + {#Signature [#name @name + ... https://docs.oracle.com/javase/specs/jvms/se7/html/jvms-4.html#jvms-4.7.9 + #length (|> //index.length //unsigned.u4 try.trusted) + #info it]}) + +(def .public (signature it) + (All (_ category) + (-> (Signature category) (Resource Attribute))) + (do //pool.monad + [it (|> it //signature.signature //pool.utf8)] + (//pool#each (signature' it) + (//pool.utf8 "Signature")))) + +... TODO: Inline ASAP +(def (source_file' it @name) + (-> (Index UTF8) (Index UTF8) + Attribute) + {#Source_File [#name @name + ... https://docs.oracle.com/javase/specs/jvms/se7/html/jvms-4.html#jvms-4.7.10 + #length (|> //index.length //unsigned.u4 try.trusted) + #info it]}) + +(def .public (source_file it) + (-> Text + (Resource Attribute)) + (do //pool.monad + [it (//pool.utf8 it)] + (//pool#each (source_file' it) + (//pool.utf8 "SourceFile")))) + +... TODO: Inline ASAP +(def (line_number_table' it @name) + (-> Line_Number_Table (Index UTF8) + Attribute) + {#Line_Number_Table [#name @name + ... https://docs.oracle.com/javase/specs/jvms/se7/html/jvms-4.html#jvms-4.7.12 + #length (|> it + /line_number_table.length + //unsigned.u4 + try.trusted) + #info it]}) + +(def .public (line_number_table it) + (-> Line_Number_Table + (Resource Attribute)) + (//pool#each (line_number_table' it) + (//pool.utf8 "LineNumberTable"))) + +(def .public (format it) + (Format Attribute) + (when it + {#Constant it} + ((info_format /constant.format) it) + + {#Code it} + ((info_format (/code.format format)) it) + + {#Signature it} + ((info_format //index.format) it) + + {#Source_File it} + ((info_format //index.format) it) + + {#Line_Number_Table it} + ((info_format /line_number_table.format) it))) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/attribute/code.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/attribute/code.lux new file mode 100644 index 000000000..a350fde0f --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/attribute/code.lux @@ -0,0 +1,83 @@ +(.require + [library + [lux (.except Code) + [abstract + [equivalence (.only Equivalence)]] + [data + ["[0]" product] + ["[0]" binary (.only Binary)] + ["[0]" binary + ["[1]F" \\format (.only Format) (.use "[1]#[0]" monoid)]] + [collection + ["[0]" sequence (.only Sequence) (.use "[1]#[0]" functor mix)]]] + [math + [number + ["n" nat]]]]] + ["[0]" /// + [bytecode + [environment + ["[1][0]" limit (.only Limit)]]] + [encoding + ["[1][0]" unsigned (.only U2)]]] + ["[0]" / + ["[1][0]" exception (.only Exception)]]) + +(type .public (Code Attribute) + (Record + [#limit Limit + #code Binary + #exception_table (Sequence Exception) + #attributes (Sequence Attribute)])) + +(def .public (length length code) + (All (_ Attribute) (-> (-> Attribute Nat) (Code Attribute) Nat)) + (all n.+ + ... u2 max_stack; + ... u2 max_locals; + ///limit.length + ... u4 code_length; + ///unsigned.bytes/4 + ... u1 code[code_length]; + (binary.size (the #code code)) + ... u2 exception_table_length; + ///unsigned.bytes/2 + ... exception_table[exception_table_length]; + (|> code + (the #exception_table) + sequence.size + (n.* /exception.length)) + ... u2 attributes_count; + ///unsigned.bytes/2 + ... attribute_info attributes[attributes_count]; + (|> code + (the #attributes) + (sequence#each length) + (sequence#mix n.+ 0)))) + +(def .public (equivalence attribute_equivalence) + (All (_ attribute) + (-> (Equivalence attribute) (Equivalence (Code attribute)))) + (all product.equivalence + ///limit.equivalence + binary.equivalence + (sequence.equivalence /exception.equivalence) + (sequence.equivalence attribute_equivalence) + )) + +... https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.7.3 +(def .public (format format code) + (All (_ Attribute) (-> (Format Attribute) (Format (Code Attribute)))) + (all binaryF#composite + ... u2 max_stack; + ... u2 max_locals; + (///limit.format (the #limit code)) + ... u4 code_length; + ... u1 code[code_length]; + (binaryF.binary_32 (the #code code)) + ... u2 exception_table_length; + ... exception_table[exception_table_length]; + ((binaryF.sequence_16 /exception.format) (the #exception_table code)) + ... u2 attributes_count; + ... attribute_info attributes[attributes_count]; + ((binaryF.sequence_16 format) (the #attributes code)) + )) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/attribute/code/exception.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/attribute/code/exception.lux new file mode 100644 index 000000000..08c7cc129 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/attribute/code/exception.lux @@ -0,0 +1,59 @@ +(.require + [library + [lux (.except) + [abstract + [equivalence (.only Equivalence)]] + [data + ["[0]" product] + [binary + ["[0]" \\format (.only Format)]]] + [math + [number + ["n" nat]]]]] + ["[0]" // + ["//[1]" /// + [constant (.only Class)] + ["[1][0]" index (.only Index)] + [bytecode + ["[1][0]" address (.only Address)]] + [encoding + ["[1][0]" unsigned (.only U2)]]]]) + +(type .public Exception + (Record + [#start Address + #end Address + #handler Address + #catch (Index Class)])) + +(def .public equivalence + (Equivalence Exception) + (all product.equivalence + ////address.equivalence + ////address.equivalence + ////address.equivalence + ////index.equivalence + )) + +... https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-4.html#jvms-4.7.3 +(def .public length + Nat + (all n.+ + ... u2 start_pc; + ////unsigned.bytes/2 + ... u2 end_pc; + ////unsigned.bytes/2 + ... u2 handler_pc; + ////unsigned.bytes/2 + ... u2 catch_type; + ////unsigned.bytes/2 + )) + +(def .public format + (Format Exception) + (all \\format.and + ////address.format + ////address.format + ////address.format + ////index.format + )) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/attribute/constant.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/attribute/constant.lux new file mode 100644 index 000000000..830632337 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/attribute/constant.lux @@ -0,0 +1,27 @@ +(.require + [library + [lux (.except) + [abstract + [equivalence (.only Equivalence)]] + [data + [binary + [\\format (.only Format)]]]]] + ["[0]" /// + [constant (.only Value)] + ["[1][0]" index (.only Index)] + [encoding + ["[1][0]" unsigned (.only U2 U4)]]]) + +(type .public (Constant a) + (Index (Value a))) + +(def .public equivalence + (All (_ a) (Equivalence (Constant a))) + ///index.equivalence) + +(def .public length + ///index.length) + +(def .public format + (All (_ a) (Format (Constant a))) + ///index.format) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/attribute/line_number_table.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/attribute/line_number_table.lux new file mode 100644 index 000000000..1a3e73ece --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/attribute/line_number_table.lux @@ -0,0 +1,71 @@ +... https://docs.oracle.com/javase/specs/jvms/se7/html/jvms-4.html#jvms-4.7.12 +(.require + [library + [lux (.except) + [abstract + [equivalence (.only Equivalence)]] + [data + ["[0]" product] + ["[0]" binary + ["![1]" \\format (.only Format) (.use "[1]#[0]" monoid)]] + [collection + ["[0]" sequence (.only Sequence)]]] + [math + [number + ["n" nat]]]]] + [/// + [encoding + ["[0]" unsigned (.only U2)]]]) + +(type .public Entry + (Record + [#start_program_counter U2 + #line_number U2])) + +(def entry_length + Nat + (all n.+ + ... u2 start_pc; + unsigned.bytes/2 + ... u2 line_number; + unsigned.bytes/2 + )) + +(def entry_equivalence + (Equivalence Entry) + (all product.equivalence + unsigned.equivalence + unsigned.equivalence + )) + +(def (entry_format it) + (Format Entry) + (all !binary#composite + (unsigned.format/2 (the #start_program_counter it)) + (unsigned.format/2 (the #line_number it)) + )) + +(type .public Line_Number_Table + (Sequence Entry)) + +(def .public empty + Line_Number_Table + sequence.empty) + +(def .public (length it) + (-> Line_Number_Table + Nat) + (all n.+ + ... u2 line_number_table_length; + unsigned.bytes/2 + ... line_number_table[line_number_table_length]; + (n.* entry_length (sequence.size it)) + )) + +(def .public equivalence + (Equivalence Line_Number_Table) + (sequence.equivalence entry_equivalence)) + +(def .public format + (Format Line_Number_Table) + (!binary.sequence_16 entry_format)) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/bytecode.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/bytecode.lux new file mode 100644 index 000000000..dc51330fa --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/bytecode.lux @@ -0,0 +1,1204 @@ +(.require + [library + [lux (.except Type Label int try except) + ["[0]" ffi (.only import)] + [abstract + [monoid (.only Monoid)] + [functor (.only Functor)] + ["[0]" monad (.only Monad do)]] + [control + ["[0]" writer (.only Writer)] + ["[0]" state (.only +State)] + ["[0]" maybe] + ["[0]" try (.only Try) (.use "[1]#[0]" monad)] + ["[0]" exception]] + [data + ["[0]" product] + [text + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor mix)] + ["[0]" dictionary (.only Dictionary)] + ["[0]" sequence (.only Sequence)]]] + [math + [number + ["n" nat] + ["i" int] + ["[0]" i32 (.only I32)]]] + [meta + [macro + ["^" pattern] + ["[0]" template]]]]] + ["[0]" / + ["_" instruction (.only Primitive_Array_Type Instruction Estimator) (.use "[1]#[0]" monoid)] + ["[1][0]" address (.only Address)] + ["[1][0]" jump (.only Jump Big_Jump)] + ["[1][0]" environment (.only Environment) + [limit + ["/[0]" registry (.only Register Registry)] + ["/[0]" stack (.only Stack)]]] + ["/[1]" // + ["[1][0]" index (.only Index)] + [encoding + ["[1][0]" name] + ["[1][0]" unsigned (.only U1 U2)] + ["[1][0]" signed (.only S1 S2 S4)]] + ["[1][0]" constant (.only UTF8) + ["[1]/[0]" pool (.only Pool Resource)]] + [attribute + ["[0]" line_number_table (.only Line_Number_Table)] + [code + ["[1][0]" exception (.only Exception)]]] + ["[0]" type (.only Type) + [category (.only Class Object Value' Value Return' Return Method)] + ["[0]" reflection] + ["[0]" parser]]]]) + +(type .public Label + Nat) + +(type .public Resolver + (Dictionary Label [Stack (Maybe Address)])) + +(type .public Tracker + (Record + [#program_counter Address + #next Label + #known Resolver + #line_number_table Line_Number_Table])) + +(def fresh + Tracker + [#program_counter /address.start + #next 0 + #known (dictionary.empty n.hash) + #line_number_table line_number_table.empty]) + +(type .public Relative + (-> Resolver + (Try [(Sequence Exception) + Instruction]))) + +(def no_exceptions + (Sequence Exception) + sequence.empty) + +(def relative#identity + Relative + (function (_ _) + {try.#Success [..no_exceptions _.empty]})) + +(def try|do + (template (_ <binding> <term> <then>) + [(.when <term> + {try.#Success <binding>} + <then> + + failure + (as_expected failure))])) + +(def try|in + (template (_ <it>) + [{try.#Success <it>}])) + +(def (relative#composite left right) + (-> Relative Relative Relative) + (cond (same? ..relative#identity left) + right + + (same? ..relative#identity right) + left + + ... else + (function (_ resolver) + (<| (try|do [left_exceptions left_instruction] (left resolver)) + (try|do [right_exceptions right_instruction] (right resolver)) + (try|in [(of sequence.monoid composite left_exceptions right_exceptions) + (_#composite left_instruction right_instruction)]))))) + +(def relative_monoid + (Monoid Relative) + (implementation + (def identity ..relative#identity) + (def composite ..relative#composite))) + +(type .public (Bytecode a) + (+State Try [Pool Environment Tracker] + (Writer Relative a))) + +(def .public new_label + (Bytecode Label) + (function (_ [pool environment tracker]) + {try.#Success [[pool + environment + (revised #next ++ tracker)] + [..relative#identity + (the #next tracker)]]})) + +(exception.def .public (label_has_already_been_set label) + (exception.Exception Label) + (exception.report + (list ["Label" (%.nat label)]))) + +(exception.def .public (mismatched_environments [instruction label address expected actual]) + (exception.Exception [Symbol Label Address Stack Stack]) + (exception.report + (list ["Instruction" (%.symbol instruction)] + ["Label" (%.nat label)] + ["Address" (/address.text address)] + ["Expected" (/stack.text expected)] + ["Actual" (/stack.text actual)]))) + +(def .public (set? label) + (-> Label (Bytecode (Maybe [Stack Address]))) + (function (_ state) + (let [[pool environment tracker] state] + {try.#Success [state + [..relative#identity + (when (dictionary.value label (the #known tracker)) + {.#Some [expected {.#Some address}]} + {.#Some [expected address]} + + _ + {.#None})]]}))) + +(def .public (acknowledged? label) + (-> Label (Bytecode (Maybe Stack))) + (function (_ state) + (let [[pool environment tracker] state] + {try.#Success [state + [..relative#identity + (when (dictionary.value label (the #known tracker)) + {.#Some [expected {.#None}]} + {.#Some expected} + + _ + {.#None})]]}))) + +(def .public stack + (Bytecode (Maybe Stack)) + (function (_ state) + (let [[pool environment tracker] state] + {try.#Success [state + [..relative#identity + (the /environment.#stack environment)]]}))) + +(with_expansions [<success> (these (try|in [[pool + environment + (revised #known + (dictionary.has label [actual {.#Some @here}]) + tracker)] + [..relative#identity + []]]))] + (def .public (set_label label) + (-> Label (Bytecode Any)) + (function (_ [pool environment tracker]) + (let [@here (the #program_counter tracker)] + (when (dictionary.value label (the #known tracker)) + {.#Some [expected {.#Some address}]} + (exception.except ..label_has_already_been_set [label]) + + {.#Some [expected {.#None}]} + (<| (try|do [actual environment] (/environment.continue expected environment)) + <success>) + + ... {.#None} + _ + (<| (try|do [actual environment] (/environment.continue (|> environment + (the /environment.#stack) + (maybe.else /stack.empty)) + environment)) + <success>)))))) + +(def .public functor + (Functor Bytecode) + (implementation + (def (each $ it) + (function (_ state) + (when (it state) + {try.#Success [state' [relative it]]} + {try.#Success [state' [relative ($ it)]]} + + ... {try.#Failure error} + failure + (as_expected failure)))))) + +(def .public monad + (Monad Bytecode) + (implementation + (def functor ..functor) + + (def (in it) + (function (_ state) + {try.#Success [state [relative#identity it]]})) + + (def (conjoint ^^it) + (function (_ state) + (when (^^it state) + {try.#Success [state' [left ^it]]} + (when (^it state') + {try.#Success [state'' [right it]]} + {try.#Success [state'' [(relative#composite left right) it]]} + + ... {try.#Failure error} + failure + (as_expected failure)) + + ... {try.#Failure error} + failure + (as_expected failure)))))) + +(def .public (when_continuous it) + (-> (Bytecode Any) (Bytecode Any)) + (do ..monad + [stack ..stack] + (.when stack + {.#Some _} + it + + ... {.#None} + _ + (in [])))) + +(def .public (when_acknowledged @ it) + (-> Label (Bytecode Any) (Bytecode Any)) + (do ..monad + [?@ (..acknowledged? @)] + (.when ?@ + {.#Some _} + it + + ... {.#None} + _ + (in [])))) + +(def .public (failure error) + (-> Text Bytecode) + (function (_ _) + {try.#Failure error})) + +(def .public (except exception value) + (All (_ e) (-> (exception.Exception e) e Bytecode)) + (..failure (exception.error exception value))) + +(def .public (resolve environment bytecode) + (All (_ a) + (-> Environment (Bytecode a) + (Resource [Environment Line_Number_Table (Sequence Exception) Instruction a]))) + (function (_ pool) + (<| (try|do [[pool environment tracker] [relative output]] (bytecode [pool environment ..fresh])) + (try|do [exceptions instruction] (relative (the #known tracker))) + (try|in [pool [environment + (the #line_number_table tracker) + exceptions + instruction + output]])))) + +(def (step estimator counter) + (-> Estimator Address (Try Address)) + (/address.move (estimator counter) counter)) + +(def (bytecode consumption production registry [estimator bytecode] input) + (All (_ a) (-> U2 U2 Registry [Estimator (-> [a] Instruction)] a (Bytecode Any))) + (function (_ [pool environment tracker]) + (<| (try|do environment' (|> environment + (/environment.consumes consumption) + (monad.then try.monad (|>> (/environment.produces production) + (try#each (/environment.has registry)) + try#conjoint)))) + (try|do program_counter' (step estimator (the #program_counter tracker))) + (try|in [[pool + environment' + (has #program_counter program_counter' tracker)] + [(function (_ _) + (try|in [..no_exceptions (bytecode input)])) + []]])))) + +(with_template [<name> <frames>] + [(def <name> U2 + (|> <frames> //unsigned.u2 try.trusted))] + + [$0 0] + [$1 1] + [$2 2] + [$3 3] + [$4 4] + [$5 5] + [$6 6] + ) + +(with_template [<name> <registry>] + [(def <name> Registry (|> <registry> //unsigned.u2 try.trusted /registry.registry))] + + [@_ 0] + [@0 1] + [@1 2] + [@2 3] + [@3 4] + [@4 5] + ) + +(with_template [<name> <consumption> <production> <registry> <instruction>] + [(def .public <name> + (Bytecode Any) + (..bytecode <consumption> + <production> + <registry> + <instruction> + []))] + + [nop $0 $0 @_ _.nop] + + [aconst_null $0 $1 @_ _.aconst_null] + + [iconst_m1 $0 $1 @_ _.iconst_m1] + [iconst_0 $0 $1 @_ _.iconst_0] + [iconst_1 $0 $1 @_ _.iconst_1] + [iconst_2 $0 $1 @_ _.iconst_2] + [iconst_3 $0 $1 @_ _.iconst_3] + [iconst_4 $0 $1 @_ _.iconst_4] + [iconst_5 $0 $1 @_ _.iconst_5] + + [lconst_0 $0 $2 @_ _.lconst_0] + [lconst_1 $0 $2 @_ _.lconst_1] + + [fconst_0 $0 $1 @_ _.fconst_0] + [fconst_1 $0 $1 @_ _.fconst_1] + [fconst_2 $0 $1 @_ _.fconst_2] + + [dconst_0 $0 $2 @_ _.dconst_0] + [dconst_1 $0 $2 @_ _.dconst_1] + + [pop $1 $0 @_ _.pop] + [pop2 $2 $0 @_ _.pop2] + + [dup $1 $2 @_ _.dup] + [dup_x1 $2 $3 @_ _.dup_x1] + [dup_x2 $3 $4 @_ _.dup_x2] + [dup2 $2 $4 @_ _.dup2] + [dup2_x1 $3 $5 @_ _.dup2_x1] + [dup2_x2 $4 $6 @_ _.dup2_x2] + + [swap $2 $2 @_ _.swap] + + [iaload $2 $1 @_ _.iaload] + [laload $2 $2 @_ _.laload] + [faload $2 $1 @_ _.faload] + [daload $2 $2 @_ _.daload] + [aaload $2 $1 @_ _.aaload] + [baload $2 $1 @_ _.baload] + [caload $2 $1 @_ _.caload] + [saload $2 $1 @_ _.saload] + + [iload_0 $0 $1 @0 _.iload_0] + [iload_1 $0 $1 @1 _.iload_1] + [iload_2 $0 $1 @2 _.iload_2] + [iload_3 $0 $1 @3 _.iload_3] + + [lload_0 $0 $2 @1 _.lload_0] + [lload_1 $0 $2 @2 _.lload_1] + [lload_2 $0 $2 @3 _.lload_2] + [lload_3 $0 $2 @4 _.lload_3] + + [fload_0 $0 $1 @0 _.fload_0] + [fload_1 $0 $1 @1 _.fload_1] + [fload_2 $0 $1 @2 _.fload_2] + [fload_3 $0 $1 @3 _.fload_3] + + [dload_0 $0 $2 @1 _.dload_0] + [dload_1 $0 $2 @2 _.dload_1] + [dload_2 $0 $2 @3 _.dload_2] + [dload_3 $0 $2 @4 _.dload_3] + + [aload_0 $0 $1 @0 _.aload_0] + [aload_1 $0 $1 @1 _.aload_1] + [aload_2 $0 $1 @2 _.aload_2] + [aload_3 $0 $1 @3 _.aload_3] + + [iastore $3 $0 @_ _.iastore] + [lastore $4 $0 @_ _.lastore] + [fastore $3 $0 @_ _.fastore] + [dastore $4 $0 @_ _.dastore] + [aastore $3 $0 @_ _.aastore] + [bastore $3 $0 @_ _.bastore] + [castore $3 $0 @_ _.castore] + [sastore $3 $0 @_ _.sastore] + + [istore_0 $1 $0 @0 _.istore_0] + [istore_1 $1 $0 @1 _.istore_1] + [istore_2 $1 $0 @2 _.istore_2] + [istore_3 $1 $0 @3 _.istore_3] + + [lstore_0 $2 $0 @1 _.lstore_0] + [lstore_1 $2 $0 @2 _.lstore_1] + [lstore_2 $2 $0 @3 _.lstore_2] + [lstore_3 $2 $0 @4 _.lstore_3] + + [fstore_0 $1 $0 @0 _.fstore_0] + [fstore_1 $1 $0 @1 _.fstore_1] + [fstore_2 $1 $0 @2 _.fstore_2] + [fstore_3 $1 $0 @3 _.fstore_3] + + [dstore_0 $2 $0 @1 _.dstore_0] + [dstore_1 $2 $0 @2 _.dstore_1] + [dstore_2 $2 $0 @3 _.dstore_2] + [dstore_3 $2 $0 @4 _.dstore_3] + + [astore_0 $1 $0 @0 _.astore_0] + [astore_1 $1 $0 @1 _.astore_1] + [astore_2 $1 $0 @2 _.astore_2] + [astore_3 $1 $0 @3 _.astore_3] + + [iadd $2 $1 @_ _.iadd] + [isub $2 $1 @_ _.isub] + [imul $2 $1 @_ _.imul] + [idiv $2 $1 @_ _.idiv] + [irem $2 $1 @_ _.irem] + [ineg $1 $1 @_ _.ineg] + [iand $2 $1 @_ _.iand] + [ior $2 $1 @_ _.ior] + [ixor $2 $1 @_ _.ixor] + [ishl $2 $1 @_ _.ishl] + [ishr $2 $1 @_ _.ishr] + [iushr $2 $1 @_ _.iushr] + + [ladd $4 $2 @_ _.ladd] + [lsub $4 $2 @_ _.lsub] + [lmul $4 $2 @_ _.lmul] + [ldiv $4 $2 @_ _.ldiv] + [lrem $4 $2 @_ _.lrem] + [lneg $2 $2 @_ _.lneg] + [land $4 $2 @_ _.land] + [lor $4 $2 @_ _.lor] + [lxor $4 $2 @_ _.lxor] + [lshl $3 $2 @_ _.lshl] + [lshr $3 $2 @_ _.lshr] + [lushr $3 $2 @_ _.lushr] + + [fadd $2 $1 @_ _.fadd] + [fsub $2 $1 @_ _.fsub] + [fmul $2 $1 @_ _.fmul] + [fdiv $2 $1 @_ _.fdiv] + [frem $2 $1 @_ _.frem] + [fneg $1 $1 @_ _.fneg] + + [dadd $4 $2 @_ _.dadd] + [dsub $4 $2 @_ _.dsub] + [dmul $4 $2 @_ _.dmul] + [ddiv $4 $2 @_ _.ddiv] + [drem $4 $2 @_ _.drem] + [dneg $2 $2 @_ _.dneg] + + [l2i $2 $1 @_ _.l2i] + [l2f $2 $1 @_ _.l2f] + [l2d $2 $2 @_ _.l2d] + + [f2i $1 $1 @_ _.f2i] + [f2l $1 $2 @_ _.f2l] + [f2d $1 $2 @_ _.f2d] + + [d2i $2 $1 @_ _.d2i] + [d2l $2 $2 @_ _.d2l] + [d2f $2 $1 @_ _.d2f] + + [i2l $1 $2 @_ _.i2l] + [i2f $1 $1 @_ _.i2f] + [i2d $1 $2 @_ _.i2d] + [i2b $1 $1 @_ _.i2b] + [i2c $1 $1 @_ _.i2c] + [i2s $1 $1 @_ _.i2s] + + [lcmp $4 $1 @_ _.lcmp] + + [fcmpl $2 $1 @_ _.fcmpl] + [fcmpg $2 $1 @_ _.fcmpg] + + [dcmpl $4 $1 @_ _.dcmpl] + [dcmpg $4 $1 @_ _.dcmpg] + + [arraylength $1 $1 @_ _.arraylength] + + [monitorenter $1 $0 @_ _.monitorenter] + [monitorexit $1 $0 @_ _.monitorexit] + ) + +(def discontinuity! + (Bytecode Any) + (function (_ [pool environment tracker]) + (<| (try|do _ (/environment.stack environment)) + (try|in [[pool + (/environment.discontinue environment) + tracker] + [..relative#identity + []]])))) + +(with_template [<name> <consumption> <instruction>] + [(def .public <name> + (Bytecode Any) + (do ..monad + [_ (..bytecode <consumption> $0 @_ <instruction> [])] + ..discontinuity!))] + + [ireturn $1 _.ireturn] + [lreturn $2 _.lreturn] + [freturn $1 _.freturn] + [dreturn $2 _.dreturn] + [areturn $1 _.areturn] + [return $0 _.return] + + [athrow $1 _.athrow] + ) + +(def .public (bipush byte) + (-> S1 (Bytecode Any)) + (..bytecode $0 $1 @_ _.bipush [byte])) + +(def (lifted resource) + (All (_ a) + (-> (Resource a) + (Bytecode a))) + (function (_ [pool environment tracker]) + (<| (try|do [pool' output] (resource pool)) + (try|in [[pool' environment tracker] + [..relative#identity + output]])))) + +(def .public (string value) + (-> //constant.UTF8 (Bytecode Any)) + (do ..monad + [index (..lifted (//constant/pool.string value))] + (when (|> index //index.value //unsigned.value //unsigned.u1) + {try.#Success index} + (..bytecode $0 $1 @_ _.ldc [index]) + + {try.#Failure _} + (..bytecode $0 $1 @_ _.ldc_w/string [index])))) + +(import java/lang/Float + "[1]::[0]" + ("static" floatToRawIntBits "manual" [float] int)) + +(import java/lang/Double + "[1]::[0]" + ("static" doubleToRawLongBits "manual" [double] long)) + +(with_template [<name> <type> <constructor> <constant> <wide> <to_lux> <specializations>] + [(def .public (<name> value) + (-> <type> (Bytecode Any)) + (when (|> value <to_lux>) + (^.with_template [<special> <instruction>] + [<special> (..bytecode $0 $1 @_ <instruction> [])]) + <specializations> + + _ (do ..monad + [index (..lifted (<constant> (<constructor> value)))] + (when (|> index //index.value //unsigned.value //unsigned.u1) + {try.#Success index} + (..bytecode $0 $1 @_ _.ldc [index]) + + {try.#Failure _} + (..bytecode $0 $1 @_ <wide> [index])))))] + + [int I32 //constant.integer //constant/pool.integer _.ldc_w/integer + (<| .int i32.i64) + ([-1 _.iconst_m1] + [+0 _.iconst_0] + [+1 _.iconst_1] + [+2 _.iconst_2] + [+3 _.iconst_3] + [+4 _.iconst_4] + [+5 _.iconst_5])] + ) + +(def (arbitrary_float value) + (-> java/lang/Float (Bytecode Any)) + (do ..monad + [index (..lifted (//constant/pool.float (//constant.float value)))] + (when (|> index //index.value //unsigned.value //unsigned.u1) + {try.#Success index} + (..bytecode $0 $1 @_ _.ldc [index]) + + {try.#Failure _} + (..bytecode $0 $1 @_ _.ldc_w/float [index])))) + +(def float_bits + (-> java/lang/Float Int) + (|>> java/lang/Float::floatToRawIntBits + ffi.int_to_long + (as Int))) + +(def negative_zero_float_bits + (|> -0.0 (as java/lang/Double) ffi.double_to_float ..float_bits)) + +(def .public (float value) + (-> java/lang/Float (Bytecode Any)) + (if (i.= ..negative_zero_float_bits + (..float_bits value)) + (..arbitrary_float value) + (when (|> value ffi.float_to_double (as Frac)) + (^.with_template [<special> <instruction>] + [<special> (..bytecode $0 $1 @_ <instruction> [])]) + ([+0.0 _.fconst_0] + [+1.0 _.fconst_1] + [+2.0 _.fconst_2]) + + _ (..arbitrary_float value)))) + +(with_template [<name> <type> <constructor> <constant> <wide> <to_lux> <specializations>] + [(def .public (<name> value) + (-> <type> (Bytecode Any)) + (when (|> value <to_lux>) + (^.with_template [<special> <instruction>] + [<special> (..bytecode $0 $2 @_ <instruction> [])]) + <specializations> + + _ (do ..monad + [index (..lifted (<constant> (<constructor> value)))] + (..bytecode $0 $2 @_ <wide> [index]))))] + + [long Int //constant.long //constant/pool.long _.ldc2_w/long + (<|) + ([+0 _.lconst_0] + [+1 _.lconst_1])] + ) + +(def (arbitrary_double value) + (-> java/lang/Double (Bytecode Any)) + (do ..monad + [index (..lifted (//constant/pool.double (//constant.double (as Frac value))))] + (..bytecode $0 $2 @_ _.ldc2_w/double [index]))) + +(def double_bits + (-> java/lang/Double Int) + (|>> java/lang/Double::doubleToRawLongBits + (as Int))) + +(def negative_zero_double_bits + (..double_bits (as java/lang/Double -0.0))) + +(def .public (double value) + (-> java/lang/Double (Bytecode Any)) + (if (i.= ..negative_zero_double_bits + (..double_bits value)) + (..arbitrary_double value) + (when (as Frac value) + (^.with_template [<special> <instruction>] + [<special> (..bytecode $0 $2 @_ <instruction> [])]) + ([+0.0 _.dconst_0] + [+1.0 _.dconst_1]) + + _ (..arbitrary_double value)))) + +(exception.def .public (invalid_register id) + (exception.Exception Nat) + (exception.report + (list ["ID" (%.nat id)]))) + +(def (register id) + (-> Nat (Bytecode Register)) + (when (//unsigned.u1 id) + {try.#Success register} + (of ..monad in register) + + {try.#Failure error} + (..except ..invalid_register [id]))) + +(with_template [<for> <size> <name> <general> <specials>] + [(def .public (<name> local) + (-> Nat (Bytecode Any)) + (with_expansions [<specials>' (template.spliced <specials>)] + (`` (when local + (,, (with_template [<case> <instruction> <registry>] + [<case> (..bytecode $0 <size> <registry> <instruction> [])] + + <specials>')) + _ (do ..monad + [local (..register local)] + (..bytecode $0 <size> (<for> local) <general> [local]))))))] + + [/registry.for $1 iload _.iload + [[0 _.iload_0 @0] + [1 _.iload_1 @1] + [2 _.iload_2 @2] + [3 _.iload_3 @3]]] + [/registry.for_wide $2 lload _.lload + [[0 _.lload_0 @1] + [1 _.lload_1 @2] + [2 _.lload_2 @3] + [3 _.lload_3 @4]]] + [/registry.for $1 fload _.fload + [[0 _.fload_0 @0] + [1 _.fload_1 @1] + [2 _.fload_2 @2] + [3 _.fload_3 @3]]] + [/registry.for_wide $2 dload _.dload + [[0 _.dload_0 @1] + [1 _.dload_1 @2] + [2 _.dload_2 @3] + [3 _.dload_3 @4]]] + [/registry.for $1 aload _.aload + [[0 _.aload_0 @0] + [1 _.aload_1 @1] + [2 _.aload_2 @2] + [3 _.aload_3 @3]]] + ) + +(with_template [<for> <size> <name> <general> <specials>] + [(def .public (<name> local) + (-> Nat (Bytecode Any)) + (with_expansions [<specials>' (template.spliced <specials>)] + (`` (when local + (,, (with_template [<case> <instruction> <registry>] + [<case> (..bytecode <size> $0 <registry> <instruction> [])] + + <specials>')) + _ (do ..monad + [local (..register local)] + (..bytecode <size> $0 (<for> local) <general> [local]))))))] + + [/registry.for $1 istore _.istore + [[0 _.istore_0 @0] + [1 _.istore_1 @1] + [2 _.istore_2 @2] + [3 _.istore_3 @3]]] + [/registry.for_wide $2 lstore _.lstore + [[0 _.lstore_0 @1] + [1 _.lstore_1 @2] + [2 _.lstore_2 @3] + [3 _.lstore_3 @4]]] + [/registry.for $1 fstore _.fstore + [[0 _.fstore_0 @0] + [1 _.fstore_1 @1] + [2 _.fstore_2 @2] + [3 _.fstore_3 @3]]] + [/registry.for_wide $2 dstore _.dstore + [[0 _.dstore_0 @1] + [1 _.dstore_1 @2] + [2 _.dstore_2 @3] + [3 _.dstore_3 @4]]] + [/registry.for $1 astore _.astore + [[0 _.astore_0 @0] + [1 _.astore_1 @1] + [2 _.astore_2 @2] + [3 _.astore_3 @3]]] + ) + +(with_template [<consumption> <production> <name> <instruction> <input>] + [(def .public <name> + (-> <input> (Bytecode Any)) + (..bytecode <consumption> <production> @_ <instruction>))] + + [$1 $1 newarray _.newarray Primitive_Array_Type] + [$0 $1 sipush _.sipush S2] + ) + +(exception.def .public (unknown_label label) + (exception.Exception Label) + (exception.report + (list ["Label" (%.nat label)]))) + +(exception.def .public (cannot_do_a_big_jump [label @from jump]) + (exception.Exception [Label Address Big_Jump]) + (exception.report + (list ["Label" (%.nat label)] + ["Start" (|> @from /address.value //unsigned.value %.nat)] + ["Target" (|> jump //signed.value %.int)]))) + +(type Any_Jump + (Either Big_Jump + Jump)) + +(def (jump @from @to) + (-> Address Address (Try Any_Jump)) + (<| (try|do jump (try#each //signed.value + (/address.jump @from @to))) + (let [big? (or (i.> (//signed.value //signed.maximum/2) + jump) + (i.< (//signed.value //signed.minimum/2) + jump))]) + (if big? + (try#each (|>> {.#Left}) (//signed.s4 jump)) + (try#each (|>> {.#Right}) (//signed.s2 jump))))) + +(exception.def .public (unset_label label) + (exception.Exception Label) + (exception.report + (list ["Label" (%.nat label)]))) + +(def (resolve_label label resolver) + (-> Label Resolver (Try [Stack Address])) + (when (dictionary.value label resolver) + {.#Some [actual {.#Some address}]} + {try.#Success [actual address]} + + {.#Some [actual {.#None}]} + (exception.except ..unset_label [label]) + + ... {.#None} + _ + (exception.except ..unknown_label [label]))) + +(def (acknowledge_label stack label tracker) + (-> Stack Label Tracker Tracker) + (when (dictionary.value label (the #known tracker)) + {.#Some _} + tracker + + ... {.#None} + _ + (revised #known (dictionary.has label [stack {.#None}]) tracker))) + +(with_template [<consumption> <name> <instruction>] + [(def .public (<name> label) + (-> Label (Bytecode Any)) + (let [[estimator bytecode] <instruction>] + (function (_ [pool environment tracker]) + (<| (let [@here (the #program_counter tracker)]) + (try|do environment' (|> environment + (/environment.consumes <consumption>))) + (try|do actual (/environment.stack environment')) + (try|do program_counter' (step estimator @here)) + (try|in (let [@from @here] + [[pool + environment' + (|> tracker + (..acknowledge_label actual label) + (has #program_counter program_counter'))] + [(function (_ resolver) + (<| (try|do [expected @to] (..resolve_label label resolver)) + (try|do _ (exception.assertion ..mismatched_environments [(symbol <instruction>) label @here expected actual] + (of /stack.equivalence = expected actual))) + (try|do jump (..jump @from @to)) + (when jump + {.#Left jump} + (exception.except ..cannot_do_a_big_jump [label @from jump]) + + {.#Right jump} + (try|in [..no_exceptions (bytecode jump)])))) + []]]))))))] + + [$1 ifeq _.ifeq] + [$1 ifne _.ifne] + [$1 iflt _.iflt] + [$1 ifge _.ifge] + [$1 ifgt _.ifgt] + [$1 ifle _.ifle] + + [$1 ifnull _.ifnull] + [$1 ifnonnull _.ifnonnull] + + [$2 if_icmpeq _.if_icmpeq] + [$2 if_icmpne _.if_icmpne] + [$2 if_icmplt _.if_icmplt] + [$2 if_icmpge _.if_icmpge] + [$2 if_icmpgt _.if_icmpgt] + [$2 if_icmple _.if_icmple] + + [$2 if_acmpeq _.if_acmpeq] + [$2 if_acmpne _.if_acmpne] + ) + +(with_template [<name> <instruction> <on_long_jump> <on_short_jump>] + [(def .public (<name> label) + (-> Label (Bytecode Any)) + (let [[estimator bytecode] <instruction>] + (function (_ [pool environment tracker]) + (<| (try|do actual (/environment.stack environment)) + (let [@here (the #program_counter tracker)]) + (try|do program_counter' (step estimator @here)) + (try|in (let [@from @here] + [[pool + (/environment.discontinue environment) + (|> tracker + (..acknowledge_label actual label) + (has #program_counter program_counter'))] + [(function (_ resolver) + (when (dictionary.value label resolver) + {.#Some [expected {.#Some @to}]} + (<| (try|do _ (exception.assertion ..mismatched_environments [(symbol <instruction>) label @here expected actual] + (of /stack.equivalence = expected actual))) + (try|do jump (..jump @from @to)) + (when jump + {.#Left jump} + <on_long_jump> + + {.#Right jump} + <on_short_jump>)) + + {.#Some [expected {.#None}]} + (exception.except ..unset_label [label]) + + ... {.#None} + _ + (exception.except ..unknown_label [label]))) + []]]))))))] + + [goto _.goto + (exception.except ..cannot_do_a_big_jump [label @from jump]) + (try|in [..no_exceptions (bytecode jump)])] + [goto_w _.goto_w + (try|in [..no_exceptions (bytecode jump)]) + (try|in [..no_exceptions (bytecode (/jump.lifted jump))])] + ) + +(def (big_jump jump) + (-> Any_Jump Big_Jump) + (when jump + {.#Left big} + big + + {.#Right small} + (/jump.lifted small))) + +(exception.def .public invalid_tableswitch) + +(def .public (tableswitch minimum default [at_minimum afterwards]) + (-> S4 Label [Label (List Label)] (Bytecode Any)) + (let [[estimator bytecode] _.tableswitch] + (function (_ [pool environment tracker]) + (<| (try|do environment' (|> environment + (/environment.consumes $1))) + (try|do actual (/environment.stack environment')) + (try|do program_counter' (step (estimator (list.size afterwards)) (the #program_counter tracker))) + (try|in (let [@from (the #program_counter tracker)] + [[pool + environment' + (|> (list#mix (..acknowledge_label actual) tracker (list.partial default at_minimum afterwards)) + (has #program_counter program_counter'))] + [(function (_ resolver) + (let [get (is (-> Label (Maybe [Stack (Maybe Address)])) + (function (_ label) + (dictionary.value label resolver)))] + (when (do [! maybe.monad] + [@default (|> default get (monad.then ! product.right)) + @at_minimum (|> at_minimum get (monad.then ! product.right))] + (|> afterwards + (monad.each ! get) + (monad.then ! (monad.each ! product.right)) + (of ! each (|>> [@default @at_minimum])))) + {.#Some [@default @at_minimum @afterwards]} + (<| (try|do >default (try#each ..big_jump (..jump @from @default))) + (try|do >at_minimum (try#each ..big_jump (..jump @from @at_minimum))) + (try|do >afterwards (monad.each try.monad (|>> (..jump @from) (try#each ..big_jump)) + @afterwards)) + (try|in [..no_exceptions (bytecode minimum >default [>at_minimum >afterwards])])) + + ... {.#None} + _ + (exception.except ..invalid_tableswitch [])))) + []]])))))) + +(exception.def .public invalid_lookupswitch) + +(def .public (lookupswitch default cases) + (-> Label (List [S4 Label]) (Bytecode Any)) + (let [cases (list.sorted (function (_ [left _] [right _]) + (i.< (//signed.value left) + (//signed.value right))) + cases) + [estimator bytecode] _.lookupswitch] + (function (_ [pool environment tracker]) + (<| (try|do environment' (|> environment + (/environment.consumes $1))) + (try|do actual (/environment.stack environment')) + (try|do program_counter' (step (estimator (list.size cases)) (the #program_counter tracker))) + (try|in (let [@from (the #program_counter tracker)] + [[pool + environment' + (|> (list#mix (..acknowledge_label actual) tracker (list.partial default (list#each product.right cases))) + (has #program_counter program_counter'))] + [(function (_ resolver) + (let [get (is (-> Label (Maybe [Stack (Maybe Address)])) + (function (_ label) + (dictionary.value label resolver)))] + (when (do [! maybe.monad] + [@default (|> default get (monad.then ! product.right))] + (|> cases + (monad.each ! (|>> product.right get)) + (monad.then ! (monad.each ! product.right)) + (of ! each (|>> [@default])))) + {.#Some [@default @cases]} + (<| (try|do >default (try#each ..big_jump (..jump @from @default))) + (try|do >cases (|> @cases + (monad.each try.monad (|>> (..jump @from) (try#each ..big_jump))) + (try#each (|>> (list.zipped_2 (list#each product.left cases)))))) + (try|in [..no_exceptions (bytecode >default >cases)])) + + ... {.#None} + _ + (exception.except ..invalid_lookupswitch [])))) + []]])))))) + +(def reflection + (All (_ category) + (-> (Type (<| Return' Value' category)) Text)) + (|>> type.reflection reflection.reflection)) + +(with_template [<consumption> <production> <name> <category> <instruction>] + [(def .public (<name> class) + (-> (Type <category>) (Bytecode Any)) + (do ..monad + [... TODO: Make sure it's impossible to have indexes greater than U2. + index (..lifted (//constant/pool.class (//name.internal (..reflection class))))] + (..bytecode <consumption> <production> @_ <instruction> [index])))] + + [$0 $1 new Class _.new] + [$1 $1 anewarray Object _.anewarray] + [$1 $1 checkcast Object _.checkcast] + [$1 $1 instanceof Object _.instanceof] + ) + +(def .public (iinc register increase) + (-> Nat U1 (Bytecode Any)) + (do ..monad + [register (..register register)] + (..bytecode $0 $0 (/registry.for register) _.iinc [register increase]))) + +(exception.def .public (multiarray_cannot_be_zero_dimensional class) + (exception.Exception (Type Object)) + (exception.report + (list ["Class" (..reflection class)]))) + +(def .public (multianewarray class dimensions) + (-> (Type Object) U1 (Bytecode Any)) + (do ..monad + [_ (is (Bytecode Any) + (when (|> dimensions //unsigned.value) + 0 (..except ..multiarray_cannot_be_zero_dimensional [class]) + _ (in []))) + index (..lifted (//constant/pool.class (//name.internal (..reflection class))))] + (..bytecode (//unsigned.lifted/2 dimensions) $1 @_ _.multianewarray [index dimensions]))) + +(def (type_size type) + (-> (Type Return) Nat) + (cond (same? type.void type) + 0 + + (or (same? type.long type) + (same? type.double type)) + 2 + + ... else + 1)) + +(with_template [<static?> <name> <instruction> <method>] + [(def .public (<name> class method type) + (-> (Type Class) Text (Type Method) (Bytecode Any)) + (let [[type_variables inputs output exceptions] (parser.method type)] + (do ..monad + [index (<| ..lifted + (<method> (..reflection class)) + [//constant/pool.#name method + //constant/pool.#descriptor (type.descriptor type)]) + .let [consumption (|> inputs + (list#each ..type_size) + (list#mix n.+ (if <static?> 0 1)) + //unsigned.u1 + try.trusted) + production (|> output ..type_size //unsigned.u1 try.trusted)]] + (..bytecode (//unsigned.lifted/2 consumption) + (//unsigned.lifted/2 production) + @_ + <instruction> [index consumption production]))))] + + [#1 invokestatic _.invokestatic //constant/pool.method] + [#0 invokevirtual _.invokevirtual //constant/pool.method] + [#0 invokespecial _.invokespecial //constant/pool.method] + [#0 invokeinterface _.invokeinterface //constant/pool.interface_method] + ) + +(with_template [<consumption> <name> <1> <2>] + [(def .public (<name> class field type) + (-> (Type Class) Text (Type Value) (Bytecode Any)) + (do ..monad + [index (<| ..lifted + (//constant/pool.field (..reflection class)) + [//constant/pool.#name field + //constant/pool.#descriptor (type.descriptor type)])] + (if (or (same? type.long type) + (same? type.double type)) + (..bytecode <consumption> $2 @_ <2> [index]) + (..bytecode <consumption> $1 @_ <1> [index]))))] + + [$0 getstatic _.getstatic/1 _.getstatic/2] + [$1 getfield _.getfield/1 _.getfield/2] + ) + +(with_template [<name> <consumption/1> <1> <consumption/2> <2>] + [(def .public (<name> class field type) + (-> (Type Class) Text (Type Value) (Bytecode Any)) + (do [! ..monad] + [index (<| ..lifted + (//constant/pool.field (..reflection class)) + [//constant/pool.#name field + //constant/pool.#descriptor (type.descriptor type)])] + (if (or (same? type.long type) + (same? type.double type)) + (..bytecode <consumption/2> $0 @_ <2> [index]) + (..bytecode <consumption/1> $0 @_ <1> [index]))))] + + [putstatic $1 _.putstatic/1 $2 _.putstatic/2] + [putfield $2 _.putfield/1 $3 _.putfield/2] + ) + +(exception.def .public (invalid_range_for_try [start end]) + (exception.Exception [Address Address]) + (exception.report + (list ["Start" (|> start /address.value //unsigned.value %.nat)] + ["End" (|> end /address.value //unsigned.value %.nat)]))) + +(def .public (try @start @end @handler catch) + (-> Label Label Label (Type Class) (Bytecode Any)) + (do ..monad + [@catch (..lifted (//constant/pool.class (//name.internal (..reflection catch))))] + (function (_ [pool environment tracker]) + {try.#Success + [[pool + environment + (..acknowledge_label /stack.catch @handler tracker)] + [(function (_ resolver) + (<| (try|do [_ @start] (..resolve_label @start resolver)) + (try|do [_ @end] (..resolve_label @end resolver)) + (try|do _ (if (/address.after? @start @end) + (try|in []) + (exception.except ..invalid_range_for_try [@start @end]))) + (try|do [_ @handler] (..resolve_label @handler resolver)) + (try|in [(sequence.sequence + [//exception.#start @start + //exception.#end @end + //exception.#handler @handler + //exception.#catch @catch]) + _.empty]))) + []]]}))) + +(def .public (composite pre post) + (All (_ pre post) + (-> (Bytecode pre) (Bytecode post) (Bytecode post))) + (function (_ state) + (when (pre state) + {try.#Success [state' [left _]]} + (when (post state') + {try.#Success [state'' [right it]]} + {try.#Success [state'' [(relative#composite left right) it]]} + + ... {try.#Failure error} + failure + failure) + + ... {try.#Failure error} + failure + (as_expected failure)))) + +(def .public (map line) + (-> Nat (Bytecode Any)) + (function (_ [pool environment tracker]) + (<| (let [instruction (/address.value (the #program_counter tracker))]) + (try|do line (//unsigned.u2 line)) + (try|in [[pool + environment + (revised #line_number_table + (sequence.suffix [line_number_table.#start_program_counter instruction + line_number_table.#line_number line]) + tracker)] + [..relative#identity + []]])))) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/bytecode/address.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/bytecode/address.lux new file mode 100644 index 000000000..6bcb3655a --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/bytecode/address.lux @@ -0,0 +1,75 @@ +(.require + [library + [lux (.except) + [abstract + [equivalence (.only Equivalence)] + [monad (.only do)]] + [control + ["[0]" try (.only Try)]] + [data + [binary + [\\format (.only Format)]] + [text + ["%" \\format]]] + [math + [number + ["n" nat]]] + [meta + [type + ["[0]" nominal (.except def)]]]]] + ["[0]" // + [jump (.only Big_Jump)] + ["/[1]" // + [encoding + ["[1][0]" unsigned (.only U2)] + ["[1][0]" signed (.only S4)]]]]) + +(nominal.def .public Address + U2 + + (def .public value + (-> Address U2) + (|>> representation)) + + (def .public start + Address + (|> 0 ///unsigned.u2 try.trusted abstraction)) + + (def .public (move distance) + (-> U2 (-> Address (Try Address))) + (|>> representation + (///unsigned.+/2 distance) + (of try.functor each (|>> abstraction)))) + + (def with_sign + (-> Address (Try S4)) + (|>> representation ///unsigned.value .int ///signed.s4)) + + (def .public (jump from to) + (-> Address Address (Try Big_Jump)) + (do try.monad + [from (with_sign from) + to (with_sign to)] + (///signed.-/4 from to))) + + (def .public (after? reference subject) + (-> Address Address Bit) + (n.> (|> reference representation ///unsigned.value) + (|> subject representation ///unsigned.value))) + + (def .public equivalence + (Equivalence Address) + (implementation + (def (= reference subject) + (of ///unsigned.equivalence = + (representation reference) + (representation subject))))) + + (def .public format + (Format Address) + (|>> representation ///unsigned.format/2)) + + (def .public text + (%.Format Address) + (|>> representation ///unsigned.value %.nat)) + ) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/bytecode/environment.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/bytecode/environment.lux new file mode 100644 index 000000000..9fd4d7250 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/bytecode/environment.lux @@ -0,0 +1,110 @@ +(.require + [library + [lux (.except Type static has) + [abstract + [monad (.only do)] + [monoid (.only Monoid)]] + [control + ["[0]" try (.only Try)] + ["[0]" exception (.only Exception)]]]] + [/ + ["/[0]" limit (.only Limit) + ["/[0]" stack (.only Stack)] + ["/[0]" registry (.only Registry)]] + [/// + [encoding + [unsigned (.only U2)]] + [type (.only Type) + [category (.only Method)]]]]) + +(type .public Environment + (Record + [#limit Limit + #stack (Maybe Stack)])) + +(with_template [<name> <limit>] + [(def .public (<name> type) + (-> (Type Method) (Try Environment)) + (do try.monad + [limit (<limit> type)] + (in [#limit limit + #stack {.#Some /stack.empty}])))] + + [static /limit.static] + [virtual /limit.virtual] + ) + +(type .public Condition + (-> Environment (Try Environment))) + +(def .public monoid + (Monoid Condition) + (implementation + (def identity + (|>> {try.#Success})) + + (def (composite left right) + (function (_ environment) + (do try.monad + [environment (left environment)] + (right environment)))))) + +(exception.def .public discontinuity) + +(def .public (stack environment) + (-> Environment (Try Stack)) + (when (the ..#stack environment) + {.#Some stack} + {try.#Success stack} + + {.#None} + (exception.except ..discontinuity []))) + +(def .public discontinue + (-> Environment Environment) + (.has ..#stack {.#None})) + +(exception.def .public (mismatched_stacks [expected actual]) + (Exception [Stack Stack]) + (exception.report + (list ["Expected" (/stack.text expected)] + ["Actual" (/stack.text actual)]))) + +(def .public (continue expected environment) + (-> Stack Environment (Try [Stack Environment])) + (when (the ..#stack environment) + {.#Some actual} + (if (of /stack.equivalence = expected actual) + {try.#Success [actual environment]} + (exception.except ..mismatched_stacks [expected actual])) + + {.#None} + {try.#Success [expected (.has ..#stack {.#Some expected} environment)]})) + +(def .public (consumes amount) + (-> U2 Condition) + ... TODO: Revisit this definition once lenses/optics have been implemented, + ... since it can probably be simplified with them. + (function (_ environment) + (do try.monad + [previous (..stack environment) + current (/stack.pop amount previous)] + (in (.has ..#stack {.#Some current} environment))))) + +(def .public (produces amount) + (-> U2 Condition) + (function (_ environment) + (do try.monad + [previous (..stack environment) + current (/stack.push amount previous) + .let [limit (|> environment + (the [..#limit /limit.#stack]) + (/stack.max current))]] + (in (|> environment + (.has ..#stack {.#Some current}) + (.has [..#limit /limit.#stack] limit)))))) + +(def .public (has registry) + (-> Registry Condition) + (|>> (revised [..#limit /limit.#registry] (/registry.has registry)) + {try.#Success})) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/bytecode/environment/limit.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/bytecode/environment/limit.lux new file mode 100644 index 000000000..ce5801345 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/bytecode/environment/limit.lux @@ -0,0 +1,59 @@ +(.require + [library + [lux (.except Type static) + [abstract + [monad (.only do)] + [equivalence (.only Equivalence)]] + [control + ["[0]" try (.only Try)]] + [data + ["[0]" product] + [binary + ["[0]" \\format (.only Format) (.use "[1]#[0]" monoid)]]] + [math + [number + ["n" nat]]]]] + ["[0]" / + ["[1][0]" stack (.only Stack)] + ["[1][0]" registry (.only Registry)] + [//// + [type (.only Type) + [category (.only Method)]]]]) + +(type .public Limit + (Record + [#stack Stack + #registry Registry])) + +(with_template [<name> <registry>] + [(def .public (<name> type) + (-> (Type Method) (Try Limit)) + (do try.monad + [registry (<registry> type)] + (in [#stack /stack.empty + #registry registry])))] + + [static /registry.static] + [virtual /registry.virtual] + ) + +(def .public length + (all n.+ + ... u2 max_stack; + /stack.length + ... u2 max_locals; + /registry.length)) + +(def .public equivalence + (Equivalence Limit) + (all product.equivalence + /stack.equivalence + /registry.equivalence + )) + +(def .public (format limit) + (Format Limit) + (all \\format#composite + (/stack.format (the #stack limit)) + (/registry.format (the #registry limit)) + )) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/bytecode/environment/limit/registry.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/bytecode/environment/limit/registry.lux new file mode 100644 index 000000000..9737de12c --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/bytecode/environment/limit/registry.lux @@ -0,0 +1,93 @@ +(.require + [library + [lux (.except Type for static has) + [abstract + ["[0]" equivalence (.only Equivalence)]] + [control + ["[0]" try (.only Try) (.use "[1]#[0]" functor)]] + [data + [binary + [\\format (.only Format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor mix)]]] + [math + [number + ["n" nat]]] + [meta + [type + ["[0]" nominal (.except def)]]]]] + ["[0]" ///// + [encoding + ["[1][0]" unsigned (.only U1 U2)]] + ["[1][0]" type (.only Type) + [category (.only Method)] + ["[1]/[0]" parser]]]) + +(type .public Register + U1) + +(def normal 1) +(def wide 2) + +(nominal.def .public Registry + U2 + + (def .public registry + (-> U2 Registry) + (|>> abstraction)) + + (def (minimal type) + (-> (Type Method) Nat) + (let [[type_variables inputs output exceptions] (/////type/parser.method type)] + (|> inputs + (list#each (function (_ input) + (if (or (same? /////type.long input) + (same? /////type.double input)) + ..wide + ..normal))) + (list#mix n.+ 0)))) + + (with_template [<start> <name>] + [(def .public <name> + (-> (Type Method) (Try Registry)) + (|>> ..minimal + (n.+ <start>) + /////unsigned.u2 + (try#each ..registry)))] + + [0 static] + [1 virtual] + ) + + (def .public equivalence + (Equivalence Registry) + (of equivalence.functor each + (|>> representation) + /////unsigned.equivalence)) + + (def .public format + (Format Registry) + (|>> representation /////unsigned.format/2)) + + (def .public (has needed) + (-> Registry Registry Registry) + (|>> representation + (/////unsigned.max/2 (representation needed)) + abstraction)) + + (with_template [<name> <extra>] + [(def .public <name> + (-> Register Registry) + (let [extra (|> <extra> /////unsigned.u2 try.trusted)] + (|>> /////unsigned.lifted/2 + (/////unsigned.+/2 extra) + try.trusted + abstraction)))] + + [for ..normal] + [for_wide ..wide] + ) + ) + +(def .public length + /////unsigned.bytes/2) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/bytecode/environment/limit/stack.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/bytecode/environment/limit/stack.lux new file mode 100644 index 000000000..7517c2b60 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/bytecode/environment/limit/stack.lux @@ -0,0 +1,70 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" equivalence (.only Equivalence)]] + [control + ["[0]" maybe] + ["[0]" try (.only Try)]] + [data + [text + ["%" \\format]] + [binary + [\\format (.only Format)]]] + [meta + [type + ["[0]" nominal (.except def)]]]]] + ["[0]" ///// + [encoding + ["[1][0]" unsigned (.only U2)]]]) + +(nominal.def .public Stack + U2 + + (with_template [<frames> <name>] + [(def .public <name> + Stack + (|> <frames> /////unsigned.u2 maybe.trusted abstraction))] + + [0 empty] + [1 catch] + ) + + (def .public equivalence + (Equivalence Stack) + (of equivalence.functor each + (|>> representation) + /////unsigned.equivalence)) + + (def .public format + (Format Stack) + (|>> representation /////unsigned.format/2)) + + (def stack + (-> U2 Stack) + (|>> abstraction)) + + (with_template [<op> <name>] + [(def .public (<name> amount) + (-> U2 (-> Stack (Try Stack))) + (|>> representation + (<op> amount) + (of try.functor each ..stack)))] + + [/////unsigned.+/2 push] + [/////unsigned.-/2 pop] + ) + + (def .public (max left right) + (-> Stack Stack Stack) + (abstraction + (/////unsigned.max/2 (representation left) + (representation right)))) + + (def .public text + (%.Format Stack) + (|>> representation /////unsigned.value %.nat)) + ) + +(def .public length + /////unsigned.bytes/2) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/bytecode/instruction.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/bytecode/instruction.lux new file mode 100644 index 000000000..d8a6963ae --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/bytecode/instruction.lux @@ -0,0 +1,704 @@ +(.require + [library + [lux (.except) + [ffi (.only)] + [abstract + [monad (.only do)] + [monoid (.only Monoid)]] + [control + ["[0]" function] + ["[0]" try]] + [data + ["[0]" product] + ["[0]" binary + [/ (.only)] + ["[1]" \\unsafe] + ["[0]" \\format (.only Mutation Specification)]] + [collection + ["[0]" list]]] + [math + [number (.only hex) + ["n" nat]]] + [meta + [macro + ["[0]" template]] + [type + ["[0]" nominal (.except def)]]]]] + ["[0]" // + ["[1][0]" address (.only Address)] + ["[1][0]" jump (.only Jump Big_Jump)] + [environment + [limit + [registry (.only Register)]]] + ["/[1]" // + ["[1][0]" index (.only Index)] + ["[1][0]" constant (.only Class Reference)] + [encoding + ["[1][0]" unsigned (.only U1 U2 U4)] + ["[1][0]" signed (.only S1 S2 S4)]] + [type + [category (.only Value Method)]]]]) + +(type .public Size + U2) + +(type .public Estimator + (-> Address Size)) + +(def fixed + (-> Size Estimator) + function.constant) + +(type .public Instruction + (-> Specification Specification)) + +(def .public empty + Instruction + function.identity) + +(def .public result + (-> Instruction Specification) + (function.on \\format.no_op)) + +(type Opcode + Nat) + +(with_template [<size> <name>] + [(def <name> Size (|> <size> ///unsigned.u2 try.trusted))] + + [1 opcode_size] + [1 register_size] + [1 byte_size] + [2 index_size] + [4 big_jump_size] + [4 integer_size] + ) + +(def (nullary' opcode) + (-> Opcode Mutation) + (function (_ [offset binary]) + [(n.+ (///unsigned.value ..opcode_size) + offset) + (binary.has_8! offset opcode binary)])) + +(def nullary + [Estimator (-> Opcode Instruction)] + [(..fixed ..opcode_size) + (function (_ opcode [size mutation]) + [(n.+ (///unsigned.value ..opcode_size) + size) + (|>> mutation ((nullary' opcode)))])]) + +(with_template [<name> <size>] + [(def <name> + Size + (|> ..opcode_size + (///unsigned.+/2 <size>) + try.trusted))] + + [size/1 ..register_size] + [size/2 ..index_size] + [size/4 ..big_jump_size] + ) + +(with_template [<shift> <name> <inputT> <format> <unwrap>] + [(with_expansions [<private> (template.symbol ["'" <name>])] + (def (<private> opcode input0) + (-> Opcode <inputT> Mutation) + (function (_ [offset binary]) + [(n.+ (///unsigned.value <shift>) offset) + (|> binary + (binary.has_8! offset opcode) + (<format> (n.+ (///unsigned.value ..opcode_size) offset) + (<unwrap> input0)))])) + + (def <name> + [Estimator (-> Opcode <inputT> Instruction)] + [(..fixed <shift>) + (function (_ opcode input0 [size mutation]) + [(n.+ (///unsigned.value <shift>) size) + (|>> mutation ((<private> opcode input0)))])]))] + + [..size/1 unary/1 U1 binary.has_8! ///unsigned.value] + [..size/2 unary/2 U2 binary.has_16! ///unsigned.value] + [..size/2 jump/2 Jump binary.has_16! ///signed.value] + [..size/4 jump/4 Big_Jump binary.has_32! ///signed.value] + ) + +(with_template [<shift> <name> <inputT> <format>] + [(with_expansions [<private> (template.symbol ["'" <name>])] + (def (<private> opcode input0) + (-> Opcode <inputT> Mutation) + (function (_ [offset binary]) + [(n.+ (///unsigned.value <shift>) offset) + (|> binary + (binary.has_8! offset opcode) + (<format> (n.+ (///unsigned.value ..opcode_size) offset) + (///signed.value input0)))])) + + (def <name> + [Estimator (-> Opcode <inputT> Instruction)] + [(..fixed <shift>) + (function (_ opcode input0 [size mutation]) + [(n.+ (///unsigned.value <shift>) size) + (|>> mutation ((<private> opcode input0)))])]))] + + [..size/1 unary/1' S1 binary.has_8!] + [..size/2 unary/2' S2 binary.has_16!] + ) + +(def size/11 + Size + (|> ..opcode_size + (///unsigned.+/2 ..register_size) try.trusted + (///unsigned.+/2 ..byte_size) try.trusted)) + +(def (binary/11' opcode input0 input1) + (-> Opcode U1 U1 Mutation) + (function (_ [offset binary]) + [(n.+ (///unsigned.value ..size/11) offset) + (|> binary + (binary.has_8! offset opcode) + (binary.has_8! (n.+ (///unsigned.value ..opcode_size) offset) + (///unsigned.value input0)) + (binary.has_8! (n.+ (///unsigned.value ..size/1) offset) + (///unsigned.value input1)))])) + +(def binary/11 + [Estimator (-> Opcode U1 U1 Instruction)] + [(..fixed ..size/11) + (function (_ opcode input0 input1 [size mutation]) + [(n.+ (///unsigned.value ..size/11) size) + (|>> mutation ((binary/11' opcode input0 input1)))])]) + +(def size/21 + Size + (|> ..opcode_size + (///unsigned.+/2 ..index_size) try.trusted + (///unsigned.+/2 ..byte_size) try.trusted)) + +(def (binary/21' opcode input0 input1) + (-> Opcode U2 U1 Mutation) + (function (_ [offset binary]) + [(n.+ (///unsigned.value ..size/21) offset) + (|> binary + (binary.has_8! offset opcode) + (binary.has_16! (n.+ (///unsigned.value ..opcode_size) offset) + (///unsigned.value input0)) + (binary.has_8! (n.+ (///unsigned.value ..size/2) offset) + (///unsigned.value input1)))])) + +(def binary/21 + [Estimator (-> Opcode U2 U1 Instruction)] + [(..fixed ..size/21) + (function (_ opcode input0 input1 [size mutation]) + [(n.+ (///unsigned.value ..size/21) size) + (|>> mutation ((binary/21' opcode input0 input1)))])]) + +(def size/211 + Size + (|> ..opcode_size + (///unsigned.+/2 ..index_size) try.trusted + (///unsigned.+/2 ..byte_size) try.trusted + (///unsigned.+/2 ..byte_size) try.trusted)) + +(def (trinary/211' opcode input0 input1 input2) + (-> Opcode U2 U1 U1 Mutation) + (function (_ [offset binary]) + [(n.+ (///unsigned.value ..size/211) offset) + (|> binary + (binary.has_8! offset opcode) + (binary.has_16! (n.+ (///unsigned.value ..opcode_size) offset) + (///unsigned.value input0)) + (binary.has_8! (n.+ (///unsigned.value ..size/2) offset) + (///unsigned.value input1)) + (binary.has_8! (n.+ (///unsigned.value ..size/21) offset) + (///unsigned.value input2)))])) + +(def trinary/211 + [Estimator (-> Opcode U2 U1 U1 Instruction)] + [(..fixed ..size/211) + (function (_ opcode input0 input1 input2 [size mutation]) + [(n.+ (///unsigned.value ..size/211) size) + (|>> mutation ((trinary/211' opcode input0 input1 input2)))])]) + +(nominal.def .public Primitive_Array_Type + U1 + + (def code + (-> Primitive_Array_Type U1) + (|>> representation)) + + (with_template [<code> <name>] + [(def .public <name> + (|> <code> ///unsigned.u1 try.trusted abstraction))] + + [04 t_boolean] + [05 t_char] + [06 t_float] + [07 t_double] + [08 t_byte] + [09 t_short] + [10 t_int] + [11 t_long] + )) + +... https://docs.oracle.com/javase/specs/jvms/se8/html/jvms-6.html#jvms-6.5 +(with_expansions [<constants> (with_template [<code> <name>] + [[<code> <name> [] []]] + + ["01" aconst_null] + + ["02" iconst_m1] + ["03" iconst_0] + ["04" iconst_1] + ["05" iconst_2] + ["06" iconst_3] + ["07" iconst_4] + ["08" iconst_5] + + ["09" lconst_0] + ["0A" lconst_1] + + ["0B" fconst_0] + ["0C" fconst_1] + ["0D" fconst_2] + + ["0E" dconst_0] + ["0F" dconst_1]) + <register_loads> (with_template [<code> <name>] + [[<code> <name> [[register Register]] [register]]] + + ["15" iload] + ["16" lload] + ["17" fload] + ["18" dload] + ["19" aload]) + <simple_register_loads> (with_template [<code> <name>] + [[<code> <name> [] []]] + + ["1A" iload_0] + ["1B" iload_1] + ["1C" iload_2] + ["1D" iload_3] + + ["1E" lload_0] + ["1F" lload_1] + ["20" lload_2] + ["21" lload_3] + + ["22" fload_0] + ["23" fload_1] + ["24" fload_2] + ["25" fload_3] + + ["26" dload_0] + ["27" dload_1] + ["28" dload_2] + ["29" dload_3] + + ["2A" aload_0] + ["2B" aload_1] + ["2C" aload_2] + ["2D" aload_3]) + <register_stores> (with_template [<code> <name>] + [[<code> <name> [[register Register]] [register]]] + + ["36" istore] + ["37" lstore] + ["38" fstore] + ["39" dstore] + ["3A" astore]) + <simple_register_stores> (with_template [<code> <name>] + [[<code> <name> [] []]] + + ["3B" istore_0] + ["3C" istore_1] + ["3D" istore_2] + ["3E" istore_3] + + ["3F" lstore_0] + ["40" lstore_1] + ["41" lstore_2] + ["42" lstore_3] + + ["43" fstore_0] + ["44" fstore_1] + ["45" fstore_2] + ["46" fstore_3] + + ["47" dstore_0] + ["48" dstore_1] + ["49" dstore_2] + ["4A" dstore_3] + + ["4B" astore_0] + ["4C" astore_1] + ["4D" astore_2] + ["4E" astore_3]) + <array_loads> (with_template [<code> <name>] + [[<code> <name> [] []]] + + ["2E" iaload] + ["2F" laload] + ["30" faload] + ["31" daload] + ["32" aaload] + ["33" baload] + ["34" caload] + ["35" saload]) + <array_stores> (with_template [<code> <name>] + [[<code> <name> [] []]] + + ["4f" iastore] + ["50" lastore] + ["51" fastore] + ["52" dastore] + ["53" aastore] + ["54" bastore] + ["55" castore] + ["56" sastore]) + <arithmetic> (with_template [<code> <name>] + [[<code> <name> [] []]] + + ["60" iadd] + ["64" isub] + ["68" imul] + ["6c" idiv] + ["70" irem] + ["74" ineg] + ["78" ishl] + ["7a" ishr] + ["7c" iushr] + ["7e" iand] + ["80" ior] + ["82" ixor] + + ["61" ladd] + ["65" lsub] + ["69" lmul] + ["6D" ldiv] + ["71" lrem] + ["75" lneg] + ["7F" land] + ["81" lor] + ["83" lxor] + + ["62" fadd] + ["66" fsub] + ["6A" fmul] + ["6E" fdiv] + ["72" frem] + ["76" fneg] + + ["63" dadd] + ["67" dsub] + ["6B" dmul] + ["6F" ddiv] + ["73" drem] + ["77" dneg]) + <conversions> (with_template [<code> <name>] + [[<code> <name> [] []]] + + ["88" l2i] + ["89" l2f] + ["8A" l2d] + + ["8B" f2i] + ["8C" f2l] + ["8D" f2d] + + ["8E" d2i] + ["8F" d2l] + ["90" d2f] + + ["85" i2l] + ["86" i2f] + ["87" i2d] + ["91" i2b] + ["92" i2c] + ["93" i2s]) + <comparisons> (with_template [<code> <name>] + [[<code> <name> [] []]] + + ["94" lcmp] + + ["95" fcmpl] + ["96" fcmpg] + + ["97" dcmpl] + ["98" dcmpg]) + <returns> (with_template [<code> <name>] + [[<code> <name> [] []]] + + ["AC" ireturn] + ["AD" lreturn] + ["AE" freturn] + ["AF" dreturn] + ["B0" areturn] + ["B1" return] + ) + <jumps> (with_template [<code> <name>] + [[<code> <name> [[jump Jump]] [jump]]] + + ["99" ifeq] + ["9A" ifne] + ["9B" iflt] + ["9C" ifge] + ["9D" ifgt] + ["9E" ifle] + + ["9F" if_icmpeq] + ["A0" if_icmpne] + ["A1" if_icmplt] + ["A2" if_icmpge] + ["A3" if_icmpgt] + ["A4" if_icmple] + + ["A5" if_acmpeq] + ["A6" if_acmpne] + + ["A7" goto] + ["A8" jsr] + + ["C6" ifnull] + ["C7" ifnonnull]) + <fields> (with_template [<code> <name>] + [[<code> <name> [[index (Index (Reference Value))]] [(///index.value index)]]] + + ["B2" getstatic/1] ["B2" getstatic/2] + ["B3" putstatic/1] ["B3" putstatic/2] + ["B4" getfield/1] ["B4" getfield/2] + ["B5" putfield/1] ["B5" putfield/2])] + (with_template [<arity> <definitions>] + [(with_expansions [<definitions>' (template.spliced <definitions>)] + (with_template [<code> <name> <instruction_inputs> <arity_inputs>] + [(with_expansions [<inputs>' (template.spliced <instruction_inputs>) + <input_types> (with_template [<input_name> <input_type>] + [<input_type>] + + <inputs>') + <input_names> (with_template [<input_name> <input_type>] + [<input_name>] + + <inputs>')] + (def .public <name> + [Estimator (-> [<input_types>] Instruction)] + (let [[estimator <arity>'] <arity>] + [estimator + (function (_ [<input_names>]) + (`` (<arity>' (hex <code>) (,, (template.spliced <arity_inputs>)))))])))] + + <definitions>' + ))] + + [..nullary + [["00" nop [] []] + <constants> + ["57" pop [] []] + ["58" pop2 [] []] + ["59" dup [] []] + ["5A" dup_x1 [] []] + ["5B" dup_x2 [] []] + ["5C" dup2 [] []] + ["5D" dup2_x1 [] []] + ["5E" dup2_x2 [] []] + ["5F" swap [] []] + <simple_register_loads> + <array_loads> + <simple_register_stores> + <array_stores> + <arithmetic> + ["79" lshl [] []] + ["7B" lshr [] []] + ["7D" lushr [] []] + <conversions> + <comparisons> + <returns> + ["BE" arraylength [] []] + ["BF" athrow [] []] + ["C2" monitorenter [] []] + ["C3" monitorexit [] []]]] + + [..unary/1 + [["12" ldc [[index U1]] [index]] + <register_loads> + <register_stores> + ["A9" ret [[register Register]] [register]] + ["BC" newarray [[type Primitive_Array_Type]] [(..code type)]]]] + + [..unary/1' + [["10" bipush [[byte S1]] [byte]]]] + + [..unary/2 + [["13" ldc_w/integer [[index (Index ///constant.Integer)]] [(///index.value index)]] + ["13" ldc_w/float [[index (Index ///constant.Float)]] [(///index.value index)]] + ["13" ldc_w/string [[index (Index ///constant.String)]] [(///index.value index)]] + ["14" ldc2_w/long [[index (Index ///constant.Long)]] [(///index.value index)]] + ["14" ldc2_w/double [[index (Index ///constant.Double)]] [(///index.value index)]] + <fields> + ["BB" new [[index (Index Class)]] [(///index.value index)]] + ["BD" anewarray [[index (Index Class)]] [(///index.value index)]] + ["C0" checkcast [[index (Index Class)]] [(///index.value index)]] + ["C1" instanceof [[index (Index Class)]] [(///index.value index)]] + ["B6" invokevirtual [[index (Index (Reference Method))] [count U1] [output_count U1]] [(///index.value index)]] + ["B7" invokespecial [[index (Index (Reference Method))] [count U1] [output_count U1]] [(///index.value index)]] + ["B8" invokestatic [[index (Index (Reference Method))] [count U1] [output_count U1]] [(///index.value index)]]]] + + [..unary/2' + [["11" sipush [[short S2]] [short]]]] + + [..jump/2 + [<jumps>]] + + [..jump/4 + [["C8" goto_w [[jump Big_Jump]] [jump]] + ["C9" jsr_w [[jump Big_Jump]] [jump]]]] + + [..binary/11 + [["84" iinc [[register Register] [byte U1]] [register byte]]]] + + [..binary/21 + [["C5" multianewarray [[index (Index Class)] [count U1]] [(///index.value index) count]]]] + + [..trinary/211 + [["B9" invokeinterface [[index (Index (Reference Method))] [count U1] [output_count U1]] [(///index.value index) count (try.trusted (///unsigned.u1 0))]]]] + )) + +(def (switch_padding offset) + (-> Nat Nat) + (let [parameter_start (n.+ (///unsigned.value ..opcode_size) + offset)] + (n.% 4 + (n.- (n.% 4 parameter_start) + 4)))) + +(def .public tableswitch + [(-> Nat Estimator) + (-> S4 Big_Jump [Big_Jump (List Big_Jump)] Instruction)] + (let [estimator (is (-> Nat Estimator) + (function (_ amount_of_afterwards offset) + (|> (all n.+ + (///unsigned.value ..opcode_size) + (switch_padding (///unsigned.value (//address.value offset))) + (///unsigned.value ..big_jump_size) + (///unsigned.value ..integer_size) + (///unsigned.value ..integer_size) + (n.* (///unsigned.value ..big_jump_size) + (++ amount_of_afterwards))) + ///unsigned.u2 + try.trusted)))] + [estimator + (function (_ minimum default [at_minimum afterwards]) + (let [amount_of_afterwards (list.size afterwards) + estimator (estimator amount_of_afterwards)] + (function (_ [size mutation]) + (let [padding (switch_padding size) + tableswitch_size (try.trusted + (do [! try.monad] + [size (///unsigned.u2 size)] + (of ! each (|>> estimator ///unsigned.value) + (//address.move size //address.start)))) + tableswitch_mutation (is Mutation + (function (_ [offset binary]) + [(n.+ tableswitch_size offset) + (try.trusted + (do [! try.monad] + [amount_of_afterwards (|> amount_of_afterwards .int ///signed.s4) + maximum (///signed.+/4 minimum amount_of_afterwards)] + (in (let [_ (binary.has_8! offset (hex "AA") binary) + offset (n.+ (///unsigned.value ..opcode_size) offset) + _ (when padding + 3 (|> binary + (binary.has_8! offset 0) + (binary.has_16! (++ offset) 0)) + 2 (binary.has_16! offset 0 binary) + 1 (binary.has_8! offset 0 binary) + _ binary) + offset (n.+ padding offset) + _ (binary.has_32! offset (///signed.value default) binary) + offset (n.+ (///unsigned.value ..big_jump_size) offset) + _ (binary.has_32! offset (///signed.value minimum) binary) + offset (n.+ (///unsigned.value ..integer_size) offset) + _ (binary.has_32! offset (///signed.value maximum) binary)] + (loop (again [offset (n.+ (///unsigned.value ..integer_size) offset) + afterwards (is (List Big_Jump) + {.#Item at_minimum afterwards})]) + (when afterwards + {.#End} + binary + + {.#Item head tail} + (exec + (binary.has_32! offset (///signed.value head) binary) + (again (n.+ (///unsigned.value ..big_jump_size) offset) + tail))))))))]))] + [(n.+ tableswitch_size + size) + (|>> mutation tableswitch_mutation)]))))])) + +(def .public lookupswitch + [(-> Nat Estimator) + (-> Big_Jump (List [S4 Big_Jump]) Instruction)] + (let [case_size (n.+ (///unsigned.value ..integer_size) + (///unsigned.value ..big_jump_size)) + estimator (is (-> Nat Estimator) + (function (_ amount_of_cases offset) + (|> (all n.+ + (///unsigned.value ..opcode_size) + (switch_padding (///unsigned.value (//address.value offset))) + (///unsigned.value ..big_jump_size) + (///unsigned.value ..integer_size) + (n.* amount_of_cases case_size)) + ///unsigned.u2 + try.trusted)))] + [estimator + (function (_ default cases) + (let [amount_of_cases (list.size cases) + estimator (estimator amount_of_cases)] + (function (_ [size mutation]) + (let [padding (switch_padding size) + lookupswitch_size (try.trusted + (do [! try.monad] + [size (///unsigned.u2 size)] + (of ! each (|>> estimator ///unsigned.value) + (//address.move size //address.start)))) + lookupswitch_mutation (is Mutation + (function (_ [offset binary]) + [(n.+ lookupswitch_size offset) + (let [_ (binary.has_8! offset (hex "AB") binary) + offset (n.+ (///unsigned.value ..opcode_size) offset) + _ (when padding + 3 (|> binary + (binary.has_8! offset 0) + (binary.has_16! (++ offset) 0)) + 2 (binary.has_16! offset 0 binary) + 1 (binary.has_8! offset 0 binary) + _ binary) + offset (n.+ padding offset) + _ (binary.has_32! offset (///signed.value default) binary) + offset (n.+ (///unsigned.value ..big_jump_size) offset) + _ (binary.has_32! offset amount_of_cases binary)] + (loop (again [offset (n.+ (///unsigned.value ..integer_size) offset) + cases cases]) + (when cases + {.#End} + binary + + {.#Item [value jump] tail} + (exec + (binary.has_32! offset (///signed.value value) binary) + (binary.has_32! (n.+ (///unsigned.value ..integer_size) offset) (///signed.value jump) binary) + (again (n.+ case_size offset) + tail)))))]))] + [(n.+ lookupswitch_size + size) + (|>> mutation lookupswitch_mutation)]))))])) + +(def .public monoid + (Monoid Instruction) + (implementation + (def identity ..empty) + + (def (composite left right) + (|>> left right)))) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/bytecode/jump.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/bytecode/jump.lux new file mode 100644 index 000000000..13c5f8f07 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/bytecode/jump.lux @@ -0,0 +1,29 @@ +(.require + [library + [lux (.except) + [abstract + [equivalence (.only Equivalence)]] + [data + [binary + [\\format (.only Format)]]]]] + ["[0]" /// + [encoding + ["[1][0]" signed (.only S2 S4)]]]) + +(type .public Jump + S2) + +(def .public equivalence + (Equivalence Jump) + ///signed.equivalence) + +(def .public format + (Format Jump) + ///signed.format/2) + +(type .public Big_Jump + S4) + +(def .public lifted + (-> Jump Big_Jump) + ///signed.lifted/4) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/class.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/class.lux new file mode 100644 index 000000000..5ffb48007 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/class.lux @@ -0,0 +1,152 @@ +(.require + [library + [lux (.except Type public private) + [abstract + [equivalence (.only Equivalence)] + ["[0]" monad (.only do)]] + [control + ["[0]" state] + ["[0]" try (.only Try)]] + [data + ["[0]" product] + ["[0]" binary + ["[1]F" \\format (.only Format) (.use "[1]#[0]" monoid)]] + [collection + ["[0]" sequence (.only Sequence)]]]]] + ["[0]" // + ["[1][0]" modifier (.only Modifier modifiers)] + ["[1][0]" version (.only Version Minor Major)] + ["[1][0]" magic (.only Magic)] + ["[1][0]" index (.only Index)] + ["[1][0]" attribute (.only Attribute)] + ["[1][0]" field (.only Field)] + ["[1][0]" method (.only Method)] + [encoding + ["[1][0]" unsigned] + ["[1][0]" name (.only Internal)]] + ["[1][0]" type (.only Type) + [category (.only Inheritance)] + ["[2][0]" signature (.only Signature)]] + ["[1][0]" constant (.only Constant) + ["[2][0]" pool (.only Pool Resource)]]]) + +(type .public Class + (Rec Class + (Record + [#magic Magic + #minor_version Minor + #major_version Major + #constant_pool Pool + #modifier (Modifier Class) + #this (Index //constant.Class) + #super (Index //constant.Class) + #interfaces (Sequence (Index //constant.Class)) + #fields (Sequence Field) + #methods (Sequence Method) + #attributes (Sequence Attribute)]))) + +(modifiers + Class + ["0001" public] + ["0010" final] + ["0020" super] + ["0200" interface] + ["0400" abstract] + ["1000" synthetic] + ["2000" annotation] + ["4000" enum] + ) + +(def .public equivalence + (Equivalence Class) + (all product.equivalence + //unsigned.equivalence + //unsigned.equivalence + //unsigned.equivalence + //pool.equivalence + //modifier.equivalence + //index.equivalence + //index.equivalence + (sequence.equivalence //index.equivalence) + (sequence.equivalence //field.equivalence) + (sequence.equivalence //method.equivalence) + (sequence.equivalence //attribute.equivalence))) + +(def (install_classes this super interfaces) + (-> Internal Internal (List Internal) + (Resource [(Index //constant.Class) (Index //constant.Class) (Sequence (Index //constant.Class))])) + (do [! //pool.monad] + [@this (//pool.class this) + @super (//pool.class super) + @interfaces (is (Resource (Sequence (Index //constant.Class))) + (monad.mix ! (function (_ interface @interfaces) + (do ! + [@interface (//pool.class interface)] + (in (sequence.suffix @interface @interfaces)))) + sequence.empty + interfaces))] + (in [@this @super @interfaces]))) + +(def .public (class version modifier + this signature super interfaces + fields methods attributes) + (-> Major (Modifier Class) + Internal (Maybe (Signature Inheritance)) Internal (List Internal) + (List (Resource Field)) + (List (Resource Method)) + (List (Resource Attribute)) + (Try Class)) + (do try.monad + [[pool [@this @super @interfaces] fields methods attributes @signature] + (<| (state.result' //pool.empty) + (do [! //pool.monad] + [classes (install_classes this super interfaces) + fields (monad.all ! fields) + methods (monad.all ! methods) + attributes (monad.all ! attributes) + @signature (when signature + {.#Some signature} + (of ! each (|>> {.#Some}) (//attribute.signature signature)) + + {.#None} + (in {.#None}))] + (in [classes fields methods attributes @signature])))] + (in [#magic //magic.code + #minor_version //version.default_minor + #major_version version + #constant_pool pool + #modifier modifier + #this @this + #super @super + #interfaces @interfaces + #fields (sequence.of_list fields) + #methods (sequence.of_list methods) + #attributes (sequence.of_list (when @signature + {.#Some @signature} + {.#Item @signature attributes} + + {.#None} + attributes))]))) + +(def .public (format class) + (Format Class) + (`` (all binaryF#composite + (,, (with_template [<format> <slot>] + [(<format> (the <slot> class))] + + [//magic.format #magic] + [//version.format #minor_version] + [//version.format #major_version] + [//pool.format #constant_pool] + [//modifier.format #modifier] + [//index.format #this] + [//index.format #super])) + (,, (with_template [<format> <slot>] + [((binaryF.sequence_16 <format>) (the <slot> class))] + + [//index.format #interfaces] + [//field.format #fields] + [//method.format #methods] + [//attribute.format #attributes] + )) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/constant.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/constant.lux new file mode 100644 index 000000000..f5cdd6cf8 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/constant.lux @@ -0,0 +1,251 @@ +(.require + [library + [lux (.except Double) + ["[0]" ffi (.only import)] + [abstract + [monad (.only do)] + ["[0]" equivalence (.only Equivalence)]] + [data + ["[0]" sum] + ["[0]" product] + ["[0]" text] + ["[0]" binary + ["[1]F" \\format (.only Format) (.use "[1]#[0]" monoid)]]] + [math + [number + ["[0]" i32 (.only I32)] + ["[0]" i64] + ["[0]" int] + ["[0]" frac]]] + [meta + [macro + ["^" pattern] + ["[0]" template]] + [type + ["[0]" nominal (.except def #name)]] + [compiler + ["@" target]]]]] + ["[0]" / + ["[1][0]" tag] + ["/[1]" // + ["[1][0]" index (.only Index)] + [type + ["[1][0]" category] + ["[1][0]" descriptor (.only Descriptor)]] + [encoding + ["[1][0]" unsigned]]]]) + +(type .public UTF8 + Text) + +(def utf8_format + (Format UTF8) + binaryF.utf8_16) + +(nominal.def .public Class + (Index UTF8) + + (def .public index + (-> Class (Index UTF8)) + (|>> representation)) + + (def .public class + (-> (Index UTF8) Class) + (|>> abstraction)) + + (def .public class_equivalence + (Equivalence Class) + (of equivalence.functor each + ..index + //index.equivalence)) + + (def class_format + (Format Class) + (|>> representation //index.format)) + ) + +(import java/lang/Float + "[1]::[0]" + ("static" floatToRawIntBits "manual" [float] int)) + +(def .public float_equivalence + (Equivalence java/lang/Float) + (implementation + (def (= parameter subject) + (for @.old + ("jvm feq" parameter subject) + + @.jvm + (.jvm_float_=# (.jvm_object_cast# parameter) + (.jvm_object_cast# subject)))))) + +(import java/lang/Double + "[1]::[0]" + ("static" doubleToRawLongBits [double] long)) + +(nominal.def .public (Value kind) + kind + + (def .public value + (All (_ kind) (-> (Value kind) kind)) + (|>> representation)) + + (def .public (value_equivalence Equivalence<kind>) + (All (_ kind) + (-> (Equivalence kind) + (Equivalence (Value kind)))) + (of equivalence.functor each + (|>> representation) + Equivalence<kind>)) + + (with_template [<constructor> <type> <marker>] + [(type .public <type> + (Value <marker>)) + + (def .public <constructor> + (-> <marker> <type>) + (|>> abstraction))] + + [integer Integer I32] + [float Float java/lang/Float] + [long Long .Int] + [double Double Frac] + [string String (Index UTF8)] + ) + + (with_template [<format_name> <type> <write> <format>] + [(def <format_name> + (Format <type>) + (`` (|>> representation + (,, (template.spliced <write>)) + (,, (template.spliced <format>)))))] + + [integer_format Integer [] [binaryF.bits_32]] + [float_format Float [java/lang/Float::floatToRawIntBits ffi.of_int .i64] [i32.i32 binaryF.bits_32]] + [long_format Long [] [binaryF.bits_64]] + [double_format Double [java/lang/Double::doubleToRawLongBits ffi.of_long] [binaryF.bits_64]] + [string_format String [] [//index.format]] + ) + ) + +(type .public (Name_And_Type of) + (Record + [#name (Index UTF8) + #descriptor (Index (Descriptor of))])) + +(type .public (Reference of) + (Record + [#class (Index Class) + #name_and_type (Index (Name_And_Type of))])) + +(with_template [<type> <equivalence> <format>] + [(def .public <equivalence> + (Equivalence (<type> Any)) + (all product.equivalence + //index.equivalence + //index.equivalence)) + + (def <format> + (Format (<type> Any)) + (all binaryF.and + //index.format + //index.format))] + + [Name_And_Type name_and_type_equivalence name_and_type_format] + [Reference reference_equivalence reference_format] + ) + +(type .public Constant + (Variant + {#UTF8 UTF8} + {#Integer Integer} + {#Float Float} + {#Long Long} + {#Double Double} + {#Class Class} + {#String String} + {#Field (Reference //category.Value)} + {#Method (Reference //category.Method)} + {#Interface_Method (Reference //category.Method)} + {#Name_And_Type (Name_And_Type Any)})) + +(def .public (size constant) + (-> Constant Nat) + (when constant + (^.or {#Long _} {#Double _}) + 2 + + _ + 1)) + +(def .public equivalence + (Equivalence Constant) + ... TODO: Delete the explicit "implementation" and use the combinator + ... version below as soon as the new format for variants is implemented. + (implementation + (def (= reference sample) + (when [reference sample] + (^.with_template [<tag> <equivalence>] + [[{<tag> reference} {<tag> sample}] + (of <equivalence> = reference sample)]) + ([#UTF8 text.equivalence] + [#Integer (..value_equivalence i32.equivalence)] + [#Long (..value_equivalence int.equivalence)] + [#Float (..value_equivalence float_equivalence)] + [#Double (..value_equivalence frac.equivalence)] + [#Class ..class_equivalence] + [#String (..value_equivalence //index.equivalence)] + [#Field ..reference_equivalence] + [#Method ..reference_equivalence] + [#Interface_Method ..reference_equivalence] + [#Name_And_Type ..name_and_type_equivalence]) + + _ + false))) + ... (all sum.equivalence + ... ... #UTF8 + ... text.equivalence + ... ... #Long + ... (..value_equivalence int.equivalence) + ... ... #Double + ... (..value_equivalence frac.equivalence) + ... ... #Class + ... ..class_equivalence + ... ... #String + ... (..value_equivalence //index.equivalence) + ... ... #Field + ... ..reference_equivalence + ... ... #Method + ... ..reference_equivalence + ... ... #Interface_Method + ... ..reference_equivalence + ... ... #Name_And_Type + ... ..name_and_type_equivalence + ... ) + ) + +(def .public format + (Format Constant) + (with_expansions [<constants> (these [#UTF8 /tag.utf8 ..utf8_format] + [#Integer /tag.integer ..integer_format] + [#Float /tag.float ..float_format] + [#Long /tag.long ..long_format] + [#Double /tag.double ..double_format] + [#Class /tag.class ..class_format] + [#String /tag.string ..string_format] + [#Field /tag.field ..reference_format] + [#Method /tag.method ..reference_format] + [#Interface_Method /tag.interface_method ..reference_format] + [#Name_And_Type /tag.name_and_type ..name_and_type_format] + ... TODO: Method_Handle + ... TODO: Method_Type + ... TODO: Invoke_Dynamic + )] + (function (_ value) + (when value + (^.with_template [<case> <tag> <format>] + [{<case> value} + (binaryF#composite (/tag.format <tag>) + (<format> value))]) + (<constants>) + )))) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/constant/pool.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/constant/pool.lux new file mode 100644 index 000000000..46adfd870 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/constant/pool.lux @@ -0,0 +1,217 @@ +(.require + [library + [lux (.except Double) + ["[0]" ffi] + [abstract + [equivalence (.only Equivalence)] + [functor (.only Functor)] + [monad (.only Monad do)]] + [control + ["[0]" pipe] + ["[0]" state (.only +State)] + ["[0]" try (.only Try)]] + [data + ["[0]" product] + ["[0]" text] + [binary + ["[0]" \\format (.only Format) (.use "specification#[0]" monoid)]] + [collection + ["[0]" sequence (.only Sequence) (.use "[1]#[0]" mix)]]] + [math + [number + ["[0]" int] + ["[0]" frac] + ["[0]" i32]]]]] + ["[0]" // (.only UTF8 String Class Integer Float Long Double Constant Name_And_Type Reference) + [// + ["[1][0]" index (.only Index)] + [encoding + ["[1][0]" name (.only Internal External)] + ["[1][0]" unsigned]] + [type + [category (.only Value Method)] + ["[1][0]" descriptor (.only Descriptor)]]]]) + +(type .public Pool + [Index (Sequence [Index Constant])]) + +(def .public equivalence + (Equivalence Pool) + (product.equivalence //index.equivalence + (sequence.equivalence (product.equivalence //index.equivalence + //.equivalence)))) + +(type .public (Resource a) + (+State Try Pool a)) + +(def .public functor + (Functor Resource) + (implementation + (def (each $ it) + (|>> it + (pipe.when + {try.#Success [state output]} + {try.#Success [state ($ output)]} + + ... {try.#Failure error} + failure + (as_expected failure)))))) + +(def .public monad + (Monad Resource) + (implementation + (def functor ..functor) + + (def (in it) + (function (_ state) + {try.#Success [state it]})) + + (def (conjoint it) + (function (_ state) + (when (it state) + {try.#Success [state' it']} + (it' state') + + ... {try.#Failure error} + failure + (as_expected failure)))))) + +(def try|each + (template (_ <binding> <value> <body>) + [(when <value> + {try.#Success <binding>} + <body> + + ... {try.#Failure error} + failure + (as_expected failure))])) + +(def try|in + (template (_ <it>) + [{try.#Success <it>}])) + +(def !add + (template (_ <state> <tag> <equivalence> <value>) + [(let [[current pool] <state> + <value>' <value>] + (with_expansions [<try_again> (these (again (.++ idx)))] + (loop (again [idx 0]) + (when (sequence.item idx pool) + {try.#Success entry} + (when entry + [index {<tag> reference}] + (if (of <equivalence> = reference <value>') + {try.#Success [[current pool] + index]} + <try_again>) + + _ + <try_again>) + + {try.#Failure _} + (<| (let [new {<tag> <value>'}]) + (try|each @new (//unsigned.u2 (//.size new))) + (try|each next (is (Try Index) + (|> current + //index.value + (//unsigned.+/2 @new) + (of try.monad each //index.index)))) + (try|in [[next + (sequence.suffix [current new] pool)] + current]))))))])) + +(def /|do + (template (_ <state> <body>) + [(function (_ <state>) + <body>)])) + +(def /|each + (template (_ <state> <binding> <value> <body>) + [(when (<value> <state>) + {try.#Success [<state> <binding>]} + <body> + + ... {try.#Failure error} + failure + (as_expected failure))])) + +(type (Adder of) + (-> of (Resource (Index of)))) + +(with_template [<name> <type> <tag> <equivalence>] + [(def .public (<name> value) + (Adder <type>) + (<| (/|do %) + (!add % <tag> <equivalence> value)))] + + [integer Integer //.#Integer (//.value_equivalence i32.equivalence)] + [float Float //.#Float (//.value_equivalence //.float_equivalence)] + [long Long //.#Long (//.value_equivalence int.equivalence)] + [double Double //.#Double (//.value_equivalence frac.equivalence)] + [utf8 UTF8 //.#UTF8 text.equivalence] + ) + +(def .public (string value) + (-> Text (Resource (Index String))) + (<| (/|do %) + (/|each % @value (utf8 value)) + (let [value (//.string @value)]) + (!add % //.#String (//.value_equivalence //index.equivalence) value))) + +(def .public (class name) + (-> Internal (Resource (Index Class))) + (<| (/|do %) + (/|each % @name (utf8 (//name.read name))) + (let [value (//.class @name)]) + (!add % //.#Class //.class_equivalence value))) + +(def .public (descriptor value) + (All (_ kind) + (-> (Descriptor kind) + (Resource (Index (Descriptor kind))))) + (<| (let [value (//descriptor.descriptor value)]) + (/|do %) + (!add % //.#UTF8 text.equivalence value))) + +(type .public (Member of) + (Record + [#name UTF8 + #descriptor (Descriptor of)])) + +(def .public (name_and_type [name descriptor]) + (All (_ of) + (-> (Member of) (Resource (Index (Name_And_Type of))))) + (<| (/|do %) + (/|each % @name (utf8 name)) + (/|each % @descriptor (..descriptor descriptor)) + (!add % //.#Name_And_Type //.name_and_type_equivalence [//.#name @name //.#descriptor @descriptor]))) + +(with_template [<name> <tag> <of>] + [(def .public (<name> class member) + (-> External (Member <of>) (Resource (Index (Reference <of>)))) + (<| (/|do %) + (/|each % @class (..class (//name.internal class))) + (/|each % @name_and_type (name_and_type member)) + (!add % <tag> //.reference_equivalence [//.#class @class //.#name_and_type @name_and_type])))] + + [field //.#Field Value] + [method //.#Method Method] + [interface_method //.#Interface_Method Method] + ) + +(def !index + (template (_ <index>) + [(|> <index> //index.value //unsigned.value)])) + +(def .public format + (Format Pool) + (function (_ [next pool]) + (sequence#mix (function (_ [_index post] pre) + (specification#composite pre (//.format post))) + (\\format.bits_16 (!index next)) + pool))) + +(def .public empty + Pool + [(|> 1 //unsigned.u2 try.trusted //index.index) + sequence.empty]) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/constant/tag.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/constant/tag.lux new file mode 100644 index 000000000..66a66f48a --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/constant/tag.lux @@ -0,0 +1,52 @@ +(.require + [library + [lux (.except Tag) + [abstract + [equivalence (.only Equivalence)]] + [control + ["[0]" try]] + [data + [binary + [\\format (.only Format)]]] + [meta + [type + ["[0]" nominal (.except def)]]]]] + ["[0]" /// + [encoding + ["[1][0]" unsigned (.only U1) (.use "u1//[0]" equivalence)]]]) + +(nominal.def .public Tag + U1 + + (def .public equivalence + (Equivalence Tag) + (implementation + (def (= reference sample) + (u1//= (representation reference) + (representation sample))))) + + (with_template [<code> <name>] + [(def .public <name> + Tag + (|> <code> ///unsigned.u1 try.trusted abstraction))] + + [01 utf8] + [03 integer] + [04 float] + [05 long] + [06 double] + [07 class] + [08 string] + [09 field] + [10 method] + [11 interface_method] + [12 name_and_type] + [15 method_handle] + [16 method_type] + [18 invoke_dynamic] + ) + + (def .public format + (Format Tag) + (|>> representation ///unsigned.format/1)) + ) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/encoding/name.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/encoding/name.lux new file mode 100644 index 000000000..108ad8752 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/encoding/name.lux @@ -0,0 +1,42 @@ +(.require + [library + [lux (.except) + [data + ["[0]" text (.only) + ["%" \\format (.only format)]]] + [meta + [type + ["[0]" nominal (.except def)]]]]]) + +(def .public internal_separator "/") +(def .public external_separator ".") + +(type .public External + Text) + +(nominal.def .public Internal + Text + + (def .public internal + (-> External Internal) + (|>> (text.replaced ..external_separator + ..internal_separator) + abstraction)) + + (def .public read + (-> Internal Text) + (|>> representation)) + + (def .public external + (-> Internal External) + (|>> representation + (text.replaced ..internal_separator + ..external_separator)))) + +(def .public safe + (-> Text External) + (|>> ..internal ..external)) + +(def .public (qualify package class) + (-> Text External External) + (format (..safe package) ..external_separator class)) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/encoding/signed.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/encoding/signed.lux new file mode 100644 index 000000000..428f5ef8a --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/encoding/signed.lux @@ -0,0 +1,114 @@ +(.require + [library + [lux (.except int) + [abstract + [equivalence (.only Equivalence)] + [order (.only Order)]] + [control + ["[0]" try (.only Try)] + ["[0]" exception (.only Exception)]] + [data + [text + ["%" \\format (.only format)]] + [binary + ["[0]" \\format (.only Format)]]] + [math + [number + ["[0]" i64] + ["n" nat] + ["i" int]]] + [meta + [macro + ["[0]" template]] + [type + ["[0]" nominal (.except def)]]]]]) + +(nominal.def .public (Signed brand) + Int + + (def .public value + (-> (Signed Any) Int) + (|>> representation)) + + (def .public equivalence + (All (_ brand) (Equivalence (Signed brand))) + (implementation + (def (= reference sample) + (i.= (representation reference) (representation sample))))) + + (def .public order + (All (_ brand) (Order (Signed brand))) + (implementation + (def equivalence ..equivalence) + (def (< reference sample) + (i.< (representation reference) (representation sample))))) + + (exception.def .public (value_exceeds_the_scope [value scope]) + (Exception [Int Nat]) + (exception.report + (list ["Value" (%.int value)] + ["Scope (in bytes)" (%.nat scope)]))) + + (with_template [<bytes> <name> <size> <constructor> <maximum> <minimum> <+> <->] + [(with_expansions [<raw> (template.symbol [<name> "'"])] + (nominal.def <raw> Any) + (type .public <name> (Signed <raw>))) + + (def .public <size> <bytes>) + + (def .public <maximum> + <name> + (|> <bytes> (n.* i64.bits_per_byte) -- i64.mask abstraction)) + + (def .public <minimum> + <name> + (let [it (representation <maximum>)] + (abstraction (-- (i.- it +0))))) + + (def .public <constructor> + (-> Int (Try <name>)) + (let [positive (representation <maximum>) + negative (i64.not positive)] + (function (_ value) + (if (i.= (if (i.< +0 value) + (i64.or negative value) + (i64.and positive value)) + value) + {try.#Success (abstraction value)} + (exception.except ..value_exceeds_the_scope [value <size>]))))) + + (with_template [<abstract_operation> <concrete_operation>] + [(def .public (<abstract_operation> parameter subject) + (-> <name> <name> (Try <name>)) + (<constructor> + (<concrete_operation> (representation parameter) + (representation subject))))] + + [<+> i.+] + [<-> i.-] + )] + + [1 S1 bytes/1 s1 maximum/1 minimum/1 +/1 -/1] + [2 S2 bytes/2 s2 maximum/2 minimum/2 +/2 -/2] + [4 S4 bytes/4 s4 maximum/4 minimum/4 +/4 -/4] + ) + + (with_template [<name> <from> <to>] + [(def .public <name> + (-> <from> <to>) + (|>> transmutation))] + + [lifted/2 S1 S2] + [lifted/4 S2 S4] + ) + + (with_template [<format_name> <type> <format>] + [(def .public <format_name> + (Format <type>) + (|>> representation <format>))] + + [format/1 S1 \\format.bits_8] + [format/2 S2 \\format.bits_16] + [format/4 S4 \\format.bits_32] + ) + ) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/encoding/unsigned.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/encoding/unsigned.lux new file mode 100644 index 000000000..afd21a166 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/encoding/unsigned.lux @@ -0,0 +1,120 @@ +(.require + [library + [lux (.except nat) + [abstract + [equivalence (.only Equivalence)] + [order (.only Order)]] + [control + ["[0]" try (.only Try)] + ["[0]" exception (.only Exception)]] + [data + [text + ["%" \\format (.only format)]] + [binary + ["[0]" \\format (.only Format)]]] + [math + [number + ["n" nat] + ["[0]" i64]]] + [meta + [macro + ["[0]" template]] + [type + ["[0]" nominal (.except def)]]]]]) + +(nominal.def .public (Unsigned brand) + Nat + + (def .public value + (-> (Unsigned Any) Nat) + (|>> representation)) + + (def .public equivalence + (All (_ brand) (Equivalence (Unsigned brand))) + (implementation + (def (= reference sample) + (n.= (representation reference) + (representation sample))))) + + (def .public order + (All (_ brand) (Order (Unsigned brand))) + (implementation + (def equivalence ..equivalence) + (def (< reference sample) + (n.< (representation reference) + (representation sample))))) + + (exception.def .public (value_exceeds_the_maximum [type value maximum]) + (Exception [Symbol Nat (Unsigned Any)]) + (exception.report + (list ["Type" (%.symbol type)] + ["Value" (%.nat value)] + ["Maximum" (%.nat (representation maximum))]))) + + (exception.def .public (subtraction_cannot_yield_negative_value [type parameter subject]) + (All (_ brand) (Exception [Symbol (Unsigned brand) (Unsigned brand)])) + (exception.report + (list ["Type" (%.symbol type)] + ["Parameter" (%.nat (representation parameter))] + ["Subject" (%.nat (representation subject))]))) + + (with_template [<bytes> <name> <size> <constructor> <maximum> <+> <-> <max>] + [(with_expansions [<raw> (template.symbol [<name> "'"])] + (nominal.def .public <raw> Any) + (type .public <name> (Unsigned <raw>))) + + (def .public <size> <bytes>) + + (def .public <maximum> + <name> + (|> <bytes> (n.* i64.bits_per_byte) i64.mask abstraction)) + + (def .public (<constructor> value) + (-> Nat (Try <name>)) + (if (n.> (representation <maximum>) value) + (exception.except ..value_exceeds_the_maximum [(symbol <name>) value <maximum>]) + {try.#Success (abstraction value)})) + + (def .public (<+> parameter subject) + (-> <name> <name> (Try <name>)) + (<constructor> + (n.+ (representation parameter) + (representation subject)))) + + (def .public (<-> parameter subject) + (-> <name> <name> (Try <name>)) + (let [parameter' (representation parameter) + subject' (representation subject)] + (if (n.> subject' parameter') + (exception.except ..subtraction_cannot_yield_negative_value [(symbol <name>) parameter subject]) + {try.#Success (abstraction (n.- parameter' subject'))}))) + + (def .public (<max> left right) + (-> <name> <name> <name>) + (abstraction (n.max (representation left) + (representation right))))] + + [1 U1 bytes/1 u1 maximum/1 +/1 -/1 max/1] + [2 U2 bytes/2 u2 maximum/2 +/2 -/2 max/2] + [4 U4 bytes/4 u4 maximum/4 +/4 -/4 max/4] + ) + + (with_template [<name> <from> <to>] + [(def .public <name> + (-> <from> <to>) + (|>> transmutation))] + + [lifted/2 U1 U2] + [lifted/4 U2 U4] + ) + + (with_template [<format_name> <type> <format>] + [(def .public <format_name> + (Format <type>) + (|>> representation <format>))] + + [format/1 U1 \\format.bits_8] + [format/2 U2 \\format.bits_16] + [format/4 U4 \\format.bits_32] + ) + ) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/field.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/field.lux new file mode 100644 index 000000000..443d34f16 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/field.lux @@ -0,0 +1,81 @@ +(.require + [library + [lux (.except Type static public private) + [abstract + [equivalence (.only Equivalence)] + ["[0]" monad (.only do)]] + [data + ["[0]" product] + ["[0]" binary + ["[1]F" \\format (.only Format) (.use "[1]#[0]" monoid)]] + [collection + ["[0]" sequence (.only Sequence)]]]]] + ["[0]" // + ["[0]" modifier (.only Modifier modifiers)] + ["[1][0]" constant (.only UTF8) + ["[1]/[0]" pool (.only Pool Resource)]] + ["[1][0]" index (.only Index)] + ["[1][0]" attribute (.only Attribute)] + ["[1][0]" type (.only Type) + [category (.only Value)] + [descriptor (.only Descriptor)]]]) + +(type .public Field + (Rec Field + (Record + [#modifier (Modifier Field) + #name (Index UTF8) + #descriptor (Index (Descriptor Value)) + #attributes (Sequence Attribute)]))) + +(modifiers + Field + ["0001" public] + ["0002" private] + ["0004" protected] + ["0008" static] + ["0010" final] + ["0040" volatile] + ["0080" transient] + ["1000" synthetic] + ["4000" enum] + ) + +(def .public equivalence + (Equivalence Field) + (all product.equivalence + modifier.equivalence + //index.equivalence + //index.equivalence + (sequence.equivalence //attribute.equivalence))) + +(def .public (format field) + (Format Field) + (`` (all binaryF#composite + (,, (with_template [<format> <slot>] + [(<format> (the <slot> field))] + + [modifier.format #modifier] + [//index.format #name] + [//index.format #descriptor] + [(binaryF.sequence_16 //attribute.format) #attributes])) + ))) + +(def .public (field modifier name with_signature? type attributes) + (-> (Modifier Field) UTF8 Bit (Type Value) (Sequence Attribute) + (Resource Field)) + (do [! //constant/pool.monad] + [@name (//constant/pool.utf8 name) + @descriptor (//constant/pool.descriptor (//type.descriptor type)) + @signature (if with_signature? + (of ! each (|>> {.#Some}) (//attribute.signature (//type.signature type))) + (in {.#None}))] + (in [#modifier modifier + #name @name + #descriptor @descriptor + #attributes (when @signature + {.#Some @signature} + (sequence.suffix @signature attributes) + + {.#None} + attributes)]))) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/index.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/index.lux new file mode 100644 index 000000000..522684c1c --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/index.lux @@ -0,0 +1,39 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" equivalence (.only Equivalence)]] + [data + [binary + [\\format (.only Format)]]] + [meta + [type + ["[0]" nominal (.except def)]]]]] + ["[0]" // + [encoding + ["[1][0]" unsigned (.only U2)]]]) + +(def .public length + //unsigned.bytes/2) + +(nominal.def .public (Index kind) + U2 + + (def .public index + (All (_ kind) (-> U2 (Index kind))) + (|>> abstraction)) + + (def .public value + (-> (Index Any) U2) + (|>> representation)) + + (def .public equivalence + (All (_ kind) (Equivalence (Index kind))) + (of equivalence.functor each + ..value + //unsigned.equivalence)) + + (def .public format + (All (_ kind) (Format (Index kind))) + (|>> representation //unsigned.format/2)) + ) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/loader.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/loader.lux new file mode 100644 index 000000000..70c85cc93 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/loader.lux @@ -0,0 +1,148 @@ +(.require + [library + [lux (.except) + ["[0]" ffi (.only import object to)] + [abstract + [monad (.only do)]] + [control + ["[0]" try (.only Try)] + ["[0]" exception (.only Exception)] + ["[0]" io (.only IO)] + [concurrency + ["[0]" atom (.only Atom)]]] + [data + ["[0]" binary (.only Binary)] + ["[0]" text (.only) + ["%" \\format (.only format)]] + [collection + ["[0]" array] + ["[0]" dictionary (.only Dictionary)]]] + [meta + [compiler + ["@" target]]]]]) + +(type .public Library + (Atom (Dictionary Text Binary))) + +(exception.def .public (already_stored class) + (Exception Text) + (exception.report + (list ["Class" class]))) + +(exception.def .public (unknown class) + (Exception Text) + (exception.report + (list ["Class" class]))) + +(exception.def .public (cannot_define [class error]) + (Exception [Text Text]) + (exception.report + (list ["Class" class] + ["Error" error]))) + +(import java/lang/Object + "[1]::[0]" + (getClass [] (java/lang/Class java/lang/Object))) + +(import java/lang/String + "[1]::[0]") + +(import java/lang/reflect/Method + "[1]::[0]" + (invoke [java/lang/Object [java/lang/Object]] "try" java/lang/Object)) + +(import (java/lang/Class a) + "[1]::[0]" + (getDeclaredMethod [java/lang/String [(java/lang/Class [? < java/lang/Object])]] java/lang/reflect/Method)) + +(import java/lang/Integer + "[1]::[0]" + ("read_only" "static" TYPE (java/lang/Class java/lang/Integer))) + +(import java/lang/reflect/AccessibleObject + "[1]::[0]" + (setAccessible [boolean] void)) + +(import java/lang/ClassLoader + "[1]::[0]" + (loadClass [java/lang/String] + "io" "try" (java/lang/Class java/lang/Object))) + +(with_expansions [<elemT> (these (java/lang/Class java/lang/Object))] + (def java/lang/ClassLoader::defineClass + java/lang/reflect/Method + (let [signature (|> (ffi.array <elemT> 4) + (ffi.write! 0 (as <elemT> + (ffi.class_for java/lang/String))) + (ffi.write! 1 (java/lang/Object::getClass (ffi.array byte 0))) + (ffi.write! 2 (as <elemT> + (java/lang/Integer::TYPE))) + (ffi.write! 3 (as <elemT> + (java/lang/Integer::TYPE))))] + (to (java/lang/Class::getDeclaredMethod (ffi.as_string "defineClass") + signature + (ffi.class_for java/lang/ClassLoader)) + (java/lang/reflect/AccessibleObject::setAccessible true))))) + +(def .public (define class_name bytecode loader) + (-> Text Binary java/lang/ClassLoader (Try java/lang/Object)) + (let [signature (array.of_list (list (as java/lang/Object + class_name) + (as java/lang/Object + bytecode) + (as java/lang/Object + (|> 0 + (as (Nominal "java.lang.Long")) + ffi.long_to_int)) + (as java/lang/Object + (|> bytecode + binary.size + (as (Nominal "java.lang.Long")) + ffi.long_to_int))))] + (java/lang/reflect/Method::invoke loader signature java/lang/ClassLoader::defineClass))) + +(def .public (new_library _) + (-> Any Library) + (atom.atom (dictionary.empty text.hash))) + +(def .public (memory library) + (-> Library java/lang/ClassLoader) + (with_expansions [<cast> (for @.old + (<|) + + @.jvm + .jvm_object_cast#)] + (<| <cast> + (object [] java/lang/ClassLoader [] + [] + (java/lang/ClassLoader (findClass self [class_name java/lang/String]) + (java/lang/Class [? < java/lang/Object]) + "throws" [java/lang/ClassNotFoundException] + (let [class_name (as Text class_name) + classes (|> library atom.read! io.run!)] + (when (dictionary.value class_name classes) + {.#Some bytecode} + (when (..define class_name bytecode (<| <cast> self)) + {try.#Success class} + (as_expected class) + + {try.#Failure error} + (panic! (exception.error ..cannot_define [class_name error]))) + + {.#None} + (panic! (exception.error ..unknown [class_name]))))))))) + +(def .public (store name bytecode library) + (-> Text Binary Library (IO (Try Any))) + (do [! io.monad] + [library' (atom.read! library)] + (if (dictionary.key? library' name) + (in (exception.except ..already_stored name)) + (do ! + [_ (atom.update! (dictionary.has name bytecode) library)] + (in {try.#Success []}))))) + +(def .public (load name loader) + (-> Text java/lang/ClassLoader + (IO (Try (java/lang/Class java/lang/Object)))) + (java/lang/ClassLoader::loadClass (ffi.as_string name) loader)) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/magic.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/magic.lux new file mode 100644 index 000000000..e5fc0a09d --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/magic.lux @@ -0,0 +1,22 @@ +(.require + [library + [lux (.except) + [control + ["[0]" try]] + [math + [number (.only hex)]]]] + ["[0]" // + [encoding + ["[1][0]" unsigned (.only U4)]]]) + +(type .public Magic + U4) + +(def .public code + Magic + (|> (hex "CAFEBABE") + //unsigned.u4 + try.trusted)) + +(def .public format + //unsigned.format/4) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/method.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/method.lux new file mode 100644 index 000000000..a4689017a --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/method.lux @@ -0,0 +1,118 @@ +(.require + [library + [lux (.except Type static public private) + [abstract + [equivalence (.only Equivalence)] + ["[0]" monad (.only do)]] + [control + ["[0]" try]] + [data + ["[0]" product] + [binary + ["[0]" \\format (.only Format) (.use "[1]#[0]" monoid)]] + [collection + ["[0]" sequence (.only Sequence)] + ["[0]" list]]]]] + ["[0]" // + ["[1][0]" modifier (.only Modifier modifiers)] + ["[1][0]" index (.only Index)] + ["[1][0]" attribute (.only Attribute) + ["[2][0]" code]] + ["[1][0]" constant (.only UTF8) + ["[2][0]" pool (.only Pool Resource)]] + ["[1][0]" bytecode (.only Bytecode) + ["[2][0]" environment (.only Environment)] + ["[2][0]" instruction]] + ["[1][0]" type (.only Type) + [descriptor (.only Descriptor)] + ["[2][0]" category] + ["[2][0]" signature (.only Signature)]]]) + +(type .public Method + (Rec Method + (Record + [#modifier (Modifier Method) + #name (Index UTF8) + #descriptor (Index (Descriptor //category.Method)) + #attributes (Sequence Attribute)]))) + +(modifiers + Method + ["0001" public] + ["0002" private] + ["0004" protected] + ["0008" static] + ["0010" final] + ["0020" synchronized] + ["0040" bridge] + ["0080" var_args] + ["0100" native] + ["0400" abstract] + ["0800" strict] + ["1000" synthetic] + ) + +(def .public (method modifier name with_signature? type attributes code) + (-> (Modifier Method) UTF8 Bit (Type //category.Method) (List (Resource Attribute)) (Maybe (Bytecode Any)) + (Resource Method)) + (do [! //pool.monad] + [@name (//pool.utf8 name) + @descriptor (//pool.descriptor (//type.descriptor type)) + attributes (|> (if with_signature? + (list.partial (//attribute.signature (//type.signature type)) attributes) + attributes) + (monad.all !) + (of ! each sequence.of_list)) + attributes (when code + {.#Some code} + (do ! + [environment (when (if (//modifier.has? static modifier) + (//environment.static type) + (//environment.virtual type)) + {try.#Success environment} + (in environment) + + {try.#Failure error} + (function (_ _) + {try.#Failure error})) + [environment line_number_table exceptions instruction output] (//bytecode.resolve environment code) + .let [bytecode (|> instruction //instruction.result \\format.instance)] + code_attributes (is (Resource (Sequence Attribute)) + (if (sequence.empty? line_number_table) + (in sequence.empty) + (do ! + [@line_number_table (//attribute.line_number_table line_number_table)] + (in (sequence.sequence @line_number_table))))) + @code (//attribute.code [//code.#limit (the //environment.#limit environment) + //code.#code bytecode + //code.#exception_table exceptions + //code.#attributes code_attributes])] + (in (sequence.suffix @code attributes))) + + {.#None} + (in attributes))] + (in [#modifier modifier + #name @name + #descriptor @descriptor + #attributes attributes]))) + +(def .public equivalence + (Equivalence Method) + (all product.equivalence + //modifier.equivalence + //index.equivalence + //index.equivalence + (sequence.equivalence //attribute.equivalence) + )) + +(def .public (format field) + (Format Method) + (`` (all \\format#composite + (,, (with_template [<format> <slot>] + [(<format> (the <slot> field))] + + [//modifier.format #modifier] + [//index.format #name] + [//index.format #descriptor] + [(\\format.sequence_16 //attribute.format) #attributes])) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/modifier.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/modifier.lux new file mode 100644 index 000000000..59359f103 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/modifier.lux @@ -0,0 +1,93 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" equivalence (.only Equivalence)] + ["[0]" monoid (.only Monoid)]] + [control + ["<>" parser] + ["[0]" try]] + [data + ["[0]" binary + ["[1]F" \\format (.only Format)]]] + [math + ["[0]" number (.only hex) + ["[0]" i64]]] + [meta + ["[0]" code (.only) + ["<[1]>" \\parser]] + [macro (.only with_symbols) + [syntax (.only syntax)]] + [type + ["[0]" nominal (.except def)]]]]] + ["[0]" // + [encoding + ["[1][0]" unsigned]]]) + +(nominal.def .public (Modifier of) + //unsigned.U2 + + (def .public code + (-> (Modifier Any) //unsigned.U2) + (|>> representation)) + + (def .public equivalence + (All (_ of) (Equivalence (Modifier of))) + (implementation + (def (= reference sample) + (of //unsigned.equivalence = + (representation reference) + (representation sample))))) + + (def !abstraction + (template (_ value) + [(|> value + //unsigned.u2 + try.trusted + abstraction)])) + + (def !representation + (template (_ value) + [(|> value + representation + //unsigned.value)])) + + (def .public (has? sub super) + (All (_ of) (-> (Modifier of) (Modifier of) Bit)) + (let [sub (!representation sub)] + (|> (!representation super) + (i64.and sub) + (of i64.equivalence = sub)))) + + (def .public monoid + (All (_ of) (Monoid (Modifier of))) + (implementation + (def identity + (!abstraction (hex "0000"))) + + (def (composite left right) + (!abstraction (i64.or (!representation left) + (!representation right)))))) + + (def .public empty + Modifier + (of ..monoid identity)) + + (def .public format + (All (_ of) (Format (Modifier of))) + (|>> representation //unsigned.format/2)) + ) + +(def .public modifiers + (syntax (_ [ofT <code>.any + options (<>.many <code>.any)]) + (with_symbols [g!modifier g!code] + (in (list (` (with_template [(, g!code) (, g!modifier)] + [(def (,' .public) (, g!modifier) + (..Modifier (, ofT)) + (|> (number.hex (, g!code)) + //unsigned.u2 + try.trusted + as_expected))] + + (,* options)))))))) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/modifier/inner.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/modifier/inner.lux new file mode 100644 index 000000000..6a2a188fe --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/modifier/inner.lux @@ -0,0 +1,23 @@ +(.require + [library + [lux (.except static) + [meta + [type + ["[0]" nominal (.except def)]]]]] + [// (.only modifiers)]) + +(nominal.def .public Inner Any) + +(modifiers + Inner + ["0001" public] + ["0002" private] + ["0004" protected] + ["0008" static] + ["0010" final] + ["0200" interface] + ["0400" abstract] + ["1000" synthetic] + ["2000" annotation] + ["4000" enum] + ) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/reflection.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/reflection.lux new file mode 100644 index 000000000..d62ce7c3f --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/reflection.lux @@ -0,0 +1,385 @@ +(.require + [library + [lux (.except parameter type) + ["[0]" ffi (.only import)] + [abstract + ["[0]" monad (.only do)]] + [control + ["[0]" try (.only Try) (.use "[1]#[0]" functor)] + ["[0]" exception (.only Exception)]] + [data + ["[0]" text (.use "[1]#[0]" equivalence) + ["%" \\format (.only format)] + ["<t>" \\parser]] + [collection + ["[0]" list (.use "[1]#[0]" mix functor)] + ["[0]" array] + ["[0]" dictionary]]] + [math + [number + ["n" nat]]] + [meta + ["[0]" type] + [macro + ["^" pattern]]]]] + ["[0]" // + [encoding + ["[1][0]" name (.only External)]] + ["/" type (.only) + [category (.only Void Value Return Method Primitive Object Class Array Parameter)] + ["[1][0]" lux (.only Mapping)] + ["[1][0]" descriptor] + ["[1][0]" reflection] + ["[1][0]" parser]]]) + +(import java/lang/String + "[1]::[0]") + +(import java/lang/Object + "[1]::[0]" + (toString [] java/lang/String) + (getClass [] (java/lang/Class java/lang/Object))) + +(import java/lang/reflect/Type + "[1]::[0]" + (getTypeName [] java/lang/String)) + +(import java/lang/reflect/GenericArrayType + "[1]::[0]" + (getGenericComponentType [] java/lang/reflect/Type)) + +(import java/lang/reflect/ParameterizedType + "[1]::[0]" + (getRawType [] java/lang/reflect/Type) + (getActualTypeArguments [] [java/lang/reflect/Type])) + +(import (java/lang/reflect/TypeVariable d) + "[1]::[0]" + (getName [] java/lang/String) + (getBounds [] [java/lang/reflect/Type])) + +(import (java/lang/reflect/WildcardType d) + "[1]::[0]" + (getLowerBounds [] [java/lang/reflect/Type]) + (getUpperBounds [] [java/lang/reflect/Type])) + +(import java/lang/reflect/Modifier + "[1]::[0]" + ("static" isStatic [int] boolean) + ("static" isFinal [int] boolean) + ("static" isInterface [int] boolean) + ("static" isAbstract [int] boolean)) + +(import java/lang/annotation/Annotation + "[1]::[0]") + +(import java/lang/Deprecated + "[1]::[0]") + +(import java/lang/reflect/Field + "[1]::[0]" + (getDeclaringClass [] (java/lang/Class java/lang/Object)) + (getModifiers [] int) + (getGenericType [] java/lang/reflect/Type) + (getDeclaredAnnotations [] [java/lang/annotation/Annotation])) + +(import java/lang/ClassLoader + "[1]::[0]") + +(import (java/lang/Class c) + "[1]::[0]" + ("static" forName [java/lang/String boolean java/lang/ClassLoader] "try" (java/lang/Class java/lang/Object)) + (getName [] java/lang/String) + (isAssignableFrom [(java/lang/Class java/lang/Object)] boolean) + (getTypeParameters [] [(java/lang/reflect/TypeVariable (java/lang/Class c))]) + (getDeclaredField [java/lang/String] "try" java/lang/reflect/Field) + (isArray [] boolean) + (getComponentType [] (java/lang/Class java/lang/Object))) + +(exception.def .public (unknown_class class) + (Exception External) + (exception.report + (list ["Class" (%.text class)]))) + +(with_template [<name>] + [(exception.def .public (<name> jvm_type) + (Exception java/lang/reflect/Type) + (exception.report + (list ["Type" (java/lang/reflect/Type::getTypeName jvm_type)] + ["Class" (|> jvm_type java/lang/Object::getClass java/lang/Object::toString)])))] + + [not_a_class] + [cannot_convert_to_a_lux_type] + ) + +(def .public (load class_loader name) + (-> java/lang/ClassLoader External (Try (java/lang/Class java/lang/Object))) + (when (java/lang/Class::forName name false class_loader) + {try.#Failure _} + (exception.except ..unknown_class [name]) + + success + success)) + +(def .public (sub? class_loader super sub) + (-> java/lang/ClassLoader External External (Try Bit)) + (do try.monad + [super (..load class_loader super) + sub (..load class_loader sub)] + (in (java/lang/Class::isAssignableFrom sub super)))) + +(def (class' parameter reflection) + (-> (-> java/lang/reflect/Type (Try (/.Type Parameter))) + java/lang/reflect/Type + (Try (/.Type Class))) + (<| (when (ffi.as java/lang/Class reflection) + {.#Some class} + (let [class_name (|> class + (as (java/lang/Class java/lang/Object)) + java/lang/Class::getName)] + (`` (if (or (,, (with_template [<reflection>] + [(text#= (/reflection.reflection <reflection>) + class_name)] + + [/reflection.boolean] + [/reflection.byte] + [/reflection.short] + [/reflection.int] + [/reflection.long] + [/reflection.float] + [/reflection.double] + [/reflection.char])) + (text.starts_with? /descriptor.array_prefix class_name)) + (exception.except ..not_a_class [reflection]) + {try.#Success (/.class class_name (list))}))) + _) + (when (ffi.as java/lang/reflect/ParameterizedType reflection) + {.#Some reflection} + (let [raw (java/lang/reflect/ParameterizedType::getRawType reflection)] + (when (ffi.as java/lang/Class raw) + {.#Some raw'} + (let [! try.monad] + (|> reflection + java/lang/reflect/ParameterizedType::getActualTypeArguments + (array.list {.#None}) + (monad.each ! parameter) + (of ! each (/.class (|> raw' + (as (java/lang/Class java/lang/Object)) + java/lang/Class::getName))) + (exception.with ..cannot_convert_to_a_lux_type [reflection]))) + + _ + (exception.except ..not_a_class [reflection]))) + _) + ... else + (exception.except ..cannot_convert_to_a_lux_type [reflection]))) + +(def .public (parameter type reflection) + (-> (-> java/lang/reflect/Type (Try (/.Type Value))) + (-> java/lang/reflect/Type (Try (/.Type Parameter)))) + (<| (when (ffi.as java/lang/reflect/TypeVariable reflection) + {.#Some reflection} + {try.#Success (/.var (java/lang/reflect/TypeVariable::getName reflection))} + _) + (when (ffi.as java/lang/reflect/WildcardType reflection) + {.#Some reflection} + ... TODO: Instead of having single lower/upper bounds, should + ... allow for multiple ones. + (when [(array.item 0 (java/lang/reflect/WildcardType::getLowerBounds reflection)) + (array.item 0 (java/lang/reflect/WildcardType::getUpperBounds reflection))] + (^.with_template [<pattern> <kind>] + [<pattern> + (when (ffi.as java/lang/reflect/GenericArrayType bound) + {.#Some it} + ... TODO: Array bounds should not be "erased" as they + ... are right now. + {try.#Success /.wildcard} + + _ + (of try.monad each <kind> (parameter type bound)))]) + ([[_ {.#Some bound}] /.upper] + [[{.#Some bound} _] /.lower]) + + _ + {try.#Success /.wildcard}) + _) + (when (ffi.as java/lang/reflect/GenericArrayType reflection) + {.#Some reflection} + (|> reflection + java/lang/reflect/GenericArrayType::getGenericComponentType + type + (of try.monad each /.array)) + _) + (when (ffi.as java/lang/Class reflection) + {.#Some class} + (if (java/lang/Class::isArray class) + (|> class + java/lang/Class::getComponentType + type + (try#each /.array)) + (..class' (parameter type) reflection)) + _) + (..class' (parameter type) reflection))) + +(def .public (type reflection) + (-> java/lang/reflect/Type (Try (/.Type Value))) + (<| (when (ffi.as java/lang/Class reflection) + {.#Some reflection} + (let [class_name (|> reflection + (as (java/lang/Class java/lang/Object)) + java/lang/Class::getName)] + (`` (cond (,, (with_template [<reflection> <type>] + [(text#= (/reflection.reflection <reflection>) + class_name) + {try.#Success <type>}] + + [/reflection.boolean /.boolean] + [/reflection.byte /.byte] + [/reflection.short /.short] + [/reflection.int /.int] + [/reflection.long /.long] + [/reflection.float /.float] + [/reflection.double /.double] + [/reflection.char /.char])) + (if (text.starts_with? /descriptor.array_prefix class_name) + (<t>.result /parser.value (|> class_name //name.internal //name.read)) + {try.#Success (/.class class_name (list))})))) + _) + ... else + (..parameter type reflection))) + +(def .public class + (-> java/lang/reflect/Type + (Try (/.Type Class))) + (..class' (..parameter ..type))) + +(def .public (return reflection) + (-> java/lang/reflect/Type (Try (/.Type Return))) + (with_expansions [<else> (these (..type reflection))] + (when (ffi.as java/lang/Class reflection) + {.#Some class} + (let [class_name (|> reflection + (as (java/lang/Class java/lang/Object)) + java/lang/Class::getName)] + (if (text#= (/reflection.reflection /reflection.void) + class_name) + {try.#Success /.void} + <else>)) + + {.#None} + <else>))) + +(exception.def .public (cannot_correspond [class type]) + (Exception [(java/lang/Class java/lang/Object) Type]) + (exception.report + (list ["Class" (java/lang/Object::toString class)] + ["Type" (%.type type)]))) + +(exception.def .public (type_parameter_mismatch [expected actual class type]) + (Exception [Nat Nat (java/lang/Class java/lang/Object) Type]) + (exception.report + (list ["Expected" (%.nat expected)] + ["Actual" (%.nat actual)] + ["Class" (java/lang/Object::toString class)] + ["Type" (%.type type)]))) + +(exception.def .public (non_jvm_type type) + (Exception Type) + (exception.report + (list ["Type" (%.type type)]))) + +(def .public (correspond class type) + (-> (java/lang/Class java/lang/Object) Type (Try Mapping)) + (when type + {.#Nominal array.nominal (list :member:)} + (if (java/lang/Class::isArray class) + (correspond (java/lang/Class::getComponentType class) + :member:) + (exception.except ..cannot_correspond [class type])) + + {.#Nominal name params} + (let [class_name (java/lang/Class::getName class) + class_params (array.list {.#None} (java/lang/Class::getTypeParameters class)) + num_class_params (list.size class_params) + num_type_params (list.size params)] + (if (text#= class_name name) + (if (n.= num_class_params num_type_params) + (|> params + (list.zipped_2 (list#each (|>> java/lang/reflect/TypeVariable::getName) + class_params)) + (list#mix (function (_ [name paramT] mapping) + (dictionary.has name paramT mapping)) + /lux.fresh) + {try.#Success}) + (exception.except ..type_parameter_mismatch [num_class_params num_type_params class type])) + (exception.except ..cannot_correspond [class type]))) + + {.#Named name anonymousT} + (correspond class anonymousT) + + {.#Apply inputT abstractionT} + (when (type.applied (list inputT) abstractionT) + {.#Some outputT} + (correspond class outputT) + + {.#None} + (exception.except ..non_jvm_type [type])) + + _ + (exception.except ..non_jvm_type [type]))) + +(exception.def .public (mistaken_field_owner [field owner target]) + (Exception [java/lang/reflect/Field (java/lang/Class java/lang/Object) (java/lang/Class java/lang/Object)]) + (exception.report + (list ["Field" (java/lang/Object::toString field)] + ["Owner" (java/lang/Object::toString owner)] + ["Target" (java/lang/Object::toString target)]))) + +(with_template [<name>] + [(exception.def .public (<name> [field class]) + (Exception [Text (java/lang/Class java/lang/Object)]) + (exception.report + (list ["Field" (%.text field)] + ["Class" (java/lang/Object::toString class)])))] + + [unknown_field] + [not_a_static_field] + [not_a_virtual_field] + ) + +(def .public (field field target) + (-> Text (java/lang/Class java/lang/Object) (Try java/lang/reflect/Field)) + (when (java/lang/Class::getDeclaredField field target) + {try.#Success field} + (let [owner (java/lang/reflect/Field::getDeclaringClass field)] + (if (same? owner target) + {try.#Success field} + (exception.except ..mistaken_field_owner [field owner target]))) + + {try.#Failure _} + (exception.except ..unknown_field [field target]))) + +(def .public deprecated? + (-> (array.Array java/lang/annotation/Annotation) Bit) + (|>> (array.list {.#None}) + (list.all (|>> (ffi.as java/lang/Deprecated))) + list.empty? + not)) + +(with_template [<name> <exception> <then?> <else?>] + [(def .public (<name> field class) + (-> Text (java/lang/Class java/lang/Object) (Try [Bit Bit (/.Type Value)])) + (do [! try.monad] + [fieldJ (..field field class) + .let [modifiers (java/lang/reflect/Field::getModifiers fieldJ)]] + (when (java/lang/reflect/Modifier::isStatic modifiers) + <then?> (|> fieldJ + java/lang/reflect/Field::getGenericType + ..type + (of ! each (|>> [(java/lang/reflect/Modifier::isFinal modifiers) + (..deprecated? (java/lang/reflect/Field::getDeclaredAnnotations fieldJ))]))) + <else?> (exception.except <exception> [field class]))))] + + [static_field ..not_a_static_field #1 #0] + [virtual_field ..not_a_virtual_field #0 #1] + ) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/type.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/type.lux new file mode 100644 index 000000000..e1cbb4374 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/type.lux @@ -0,0 +1,227 @@ +(.require + [library + [lux (.except Type Declaration int char) + [abstract + [equivalence (.only Equivalence)] + [hash (.only Hash)]] + [control + ["[0]" maybe]] + [data + ["[0]" text (.only) + ["%" \\format (.only Format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor)]]] + [math + [number + ["n" nat]]] + [meta + [type + ["[0]" nominal (.except def #name)]]]]] + ["[0]" // + [encoding + ["[1][0]" name (.only External)]]] + ["[0]" / + [category (.only Void Value' Value Return' Return Method Primitive Object Class Array Var Parameter Declaration)] + ["[1][0]" signature (.only Signature)] + ["[1][0]" descriptor (.only Descriptor)] + ["[1][0]" reflection (.only Reflection)]]) + +(nominal.def .public (Type category) + [(Signature category) + (Descriptor category) + (Reflection category)] + + (type .public Argument + [Text (Type Value)]) + + (type .public (Typed a) + [(Type Value) a]) + + (type .public Constraint + (Record + [#name Text + #super_class (Type Class) + #super_interfaces (List (Type Class))])) + + (with_template [<name> <style>] + [(def .public (<name> type) + (All (_ category) + (-> (Type category) + (<style> category))) + (let [[signature descriptor reflection] (representation type)] + <name>))] + + [signature Signature] + [descriptor Descriptor] + ) + + (def .public (reflection type) + (All (_ category) + (-> (Type (<| Return' Value' category)) + (Reflection (<| Return' Value' category)))) + (let [[signature descriptor reflection] (representation type)] + reflection)) + + (with_template [<category> <name> <signature> <descriptor> <reflection>] + [(def .public <name> + (Type <category>) + (abstraction [<signature> <descriptor> <reflection>]))] + + [Void void /signature.void /descriptor.void /reflection.void] + [Primitive boolean /signature.boolean /descriptor.boolean /reflection.boolean] + [Primitive byte /signature.byte /descriptor.byte /reflection.byte] + [Primitive short /signature.short /descriptor.short /reflection.short] + [Primitive int /signature.int /descriptor.int /reflection.int] + [Primitive long /signature.long /descriptor.long /reflection.long] + [Primitive float /signature.float /descriptor.float /reflection.float] + [Primitive double /signature.double /descriptor.double /reflection.double] + [Primitive char /signature.char /descriptor.char /reflection.char] + ) + + (def .public (array type) + (-> (Type Value) + (Type Array)) + (abstraction + [(/signature.array (..signature type)) + (/descriptor.array (..descriptor type)) + (/reflection.array (..reflection type))])) + + (def .public (class name parameters) + (-> External (List (Type Parameter)) + (Type Class)) + (abstraction + [(/signature.class name (list#each ..signature parameters)) + (/descriptor.class name) + (/reflection.class name)])) + + (def .public (declaration name variables) + (-> External (List (Type Var)) + (Type Declaration)) + (abstraction + [(/signature.declaration name (list#each ..signature variables)) + (/descriptor.declaration name) + (/reflection.declaration name)])) + + (def .public (as_class type) + (-> (Type Declaration) + (Type Class)) + (abstraction + (let [[signature descriptor reflection] (representation type)] + [(/signature.as_class signature) + (/descriptor.as_class descriptor) + (/reflection.as_class reflection)]))) + + (def .public wildcard + (Type Parameter) + (abstraction + [/signature.wildcard + /descriptor.wildcard + /reflection.wildcard])) + + (def .public (var name) + (-> Text + (Type Var)) + (abstraction + [(/signature.var name) + /descriptor.var + /reflection.var])) + + (def .public (lower bound) + (-> (Type Parameter) + (Type Parameter)) + (abstraction + (let [[signature descriptor reflection] (representation bound)] + [(/signature.lower signature) + (/descriptor.lower descriptor) + (/reflection.lower reflection)]))) + + (def .public (upper bound) + (-> (Type Parameter) + (Type Parameter)) + (abstraction + (let [[signature descriptor reflection] (representation bound)] + [(/signature.upper signature) + (/descriptor.upper descriptor) + (/reflection.upper reflection)]))) + + (def .public (method [type_variables inputs output exceptions]) + (-> [(List (Type Var)) + (List (Type Value)) + (Type Return) + (List (Type Class))] + (Type Method)) + (abstraction + [(/signature.method [(list#each ..signature type_variables) + (list#each ..signature inputs) + (..signature output) + (list#each ..signature exceptions)]) + (/descriptor.method [(list#each ..descriptor inputs) + (..descriptor output)]) + (as_expected ..void)])) + + (def .public equivalence + (All (_ category) + (Equivalence (Type category))) + (implementation + (def (= parameter subject) + (of /signature.equivalence = + (..signature parameter) + (..signature subject))))) + + (def .public hash + (All (_ category) + (Hash (Type category))) + (implementation + (def equivalence ..equivalence) + (def hash (|>> ..signature (of /signature.hash hash))))) + + (def .public (primitive? type) + (-> (Type Value) + (Either (Type Object) + (Type Primitive))) + (if (`` (or (,, (with_template [<type>] + [(of ..equivalence = (is (Type Value) <type>) type)] + + [..boolean] + [..byte] + [..short] + [..int] + [..long] + [..float] + [..double] + [..char])))) + (|> type (as (Type Primitive)) {.#Right}) + (|> type (as (Type Object)) {.#Left}))) + + (def .public (void? type) + (-> (Type Return) + (Either (Type Value) + (Type Void))) + (if (`` (or (,, (with_template [<type>] + [(of ..equivalence = (is (Type Return) <type>) type)] + + [..void])))) + (|> type (as (Type Void)) {.#Right}) + (|> type (as (Type Value)) {.#Left}))) + ) + +(def .public (class? type) + (-> (Type Value) + (Maybe External)) + (let [repr (|> type ..descriptor /descriptor.descriptor)] + (if (and (text.starts_with? /descriptor.class_prefix repr) + (text.ends_with? /descriptor.class_suffix repr)) + (let [prefix_size (text.size /descriptor.class_prefix) + suffix_size (text.size /descriptor.class_suffix) + name_size (|> (text.size repr) + (n.- prefix_size) + (n.- suffix_size))] + (|> repr + (text.clip prefix_size name_size) + (of maybe.monad each (|>> //name.internal //name.external)))) + {.#None}))) + +(def .public format + (All (_ of) + (Format (Type of))) + (|>> ..signature /signature.signature)) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/type/alias.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/type/alias.lux new file mode 100644 index 000000000..8bc4f29e8 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/type/alias.lux @@ -0,0 +1,127 @@ +(.require + [library + [lux (.except Type int char parameter) + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser (.only)] + ["[0]" maybe] + ["[0]" try]] + [data + ["[0]" text (.only) + ["%" \\format (.only format)] + ["<[1]>" \\parser (.only Parser)]] + [collection + ["[0]" dictionary (.only Dictionary)]]]]] + ["[0]" // (.only Type) + [category (.only Void Value Return Method Primitive Object Class Array Var Parameter)] + ["[1][0]" descriptor] + ["[1][0]" signature (.only Signature)] + ["[1][0]" reflection] + ["[1][0]" parser]]) + +(type .public Aliasing + (Dictionary Text Text)) + +(def .public fresh + Aliasing + (dictionary.empty text.hash)) + +(def (var aliasing) + (-> Aliasing (Parser (Type Var))) + (do <>.monad + [var //parser.var'] + (in (|> aliasing + (dictionary.value var) + (maybe.else var) + //.var)))) + +(def (class parameter) + (-> (Parser (Type Parameter)) (Parser (Type Class))) + (|> (do <>.monad + [name //parser.class_name + parameters (|> (<>.some parameter) + (<>.after (<text>.this //signature.parameters_start)) + (<>.before (<text>.this //signature.parameters_end)) + (<>.else (list)))] + (in (//.class name parameters))) + (<>.after (<text>.this //descriptor.class_prefix)) + (<>.before (<text>.this //descriptor.class_suffix)))) + +(with_template [<name> <prefix> <bound> <constructor>] + [(def <name> + (-> (Parser (Type Class)) (Parser (Type Parameter))) + (|>> (<>.after (<text>.this <prefix>)) + (of <>.monad each <bound>)))] + + [lower //signature.lower_prefix //.lower ..Lower] + [upper //signature.upper_prefix //.upper ..Upper] + ) + +(def (parameter aliasing) + (-> Aliasing (Parser (Type Parameter))) + (<>.rec + (function (_ parameter) + (let [class (..class parameter)] + (all <>.either + (..var aliasing) + //parser.wildcard + (..lower class) + (..upper class) + class + ))))) + +(def (value aliasing) + (-> Aliasing (Parser (Type Value))) + (<>.rec + (function (_ value) + (all <>.either + //parser.primitive + (parameter aliasing) + (//parser.array' value) + )))) + +(def (inputs aliasing) + (-> Aliasing (Parser (List (Type Value)))) + (|> (<>.some (..value aliasing)) + (<>.after (<text>.this //signature.arguments_start)) + (<>.before (<text>.this //signature.arguments_end)))) + +(def (return aliasing) + (-> Aliasing (Parser (Type Return))) + (all <>.either + //parser.void + (..value aliasing) + )) + +(def (exception aliasing) + (-> Aliasing (Parser (Type Class))) + (|> (..class (..parameter aliasing)) + (<>.after (<text>.this //signature.exception_prefix)))) + +(def (bound aliasing) + (-> Aliasing (Parser (Type Class))) + (do <>.monad + [_ (<text>.this ":")] + (..class (..parameter aliasing)))) + +(def (bound_type_var aliasing) + (-> Aliasing (Parser (Type Var))) + (|> //parser.var_name + (of <>.monad each //.var) + (<>.before (<>.many (..bound aliasing))))) + +(def .public (method aliasing) + (-> Aliasing (-> (Type Method) (Type Method))) + (|>> //.signature + //signature.signature + (<text>.result (do <>.monad + [type_variables (|> (<>.some (..bound_type_var aliasing)) + (<>.after (<text>.this //signature.parameters_start)) + (<>.before (<text>.this //signature.parameters_end)) + (<>.else (list))) + inputs (..inputs aliasing) + return (..return aliasing) + exceptions (<>.some (..exception aliasing))] + (in (//.method [type_variables inputs return exceptions])))) + try.trusted)) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/type/box.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/type/box.lux new file mode 100644 index 000000000..367efa5ed --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/type/box.lux @@ -0,0 +1,19 @@ +(.require + [library + [lux (.except int char)]] + [/// + [encoding + [name (.only External)]]]) + +(with_template [<name> <box>] + [(def .public <name> External <box>)] + + [boolean "java.lang.Boolean"] + [byte "java.lang.Byte"] + [short "java.lang.Short"] + [int "java.lang.Integer"] + [long "java.lang.Long"] + [float "java.lang.Float"] + [double "java.lang.Double"] + [char "java.lang.Character"] + ) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/type/category.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/type/category.lux new file mode 100644 index 000000000..5ab489d09 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/type/category.lux @@ -0,0 +1,38 @@ +(.require + [library + [lux (.except Declaration) + [meta + [macro + ["[0]" template]] + [type + ["[0]" nominal (.except def)]]]]]) + +(nominal.def Void' Any) +(nominal.def .public (Value' kind) Any) +(nominal.def .public (Return' kind) Any) +(nominal.def .public Method Any) + +(type .public Return (<| Return' Any)) +(type .public Value (<| Return' Value' Any)) +(type .public Void (<| Return' Void')) + +(nominal.def (Object' brand) Any) +(type .public Object (<| Return' Value' Object' Any)) + +(nominal.def (Parameter' brand) Any) +(type .public Parameter (<| Return' Value' Object' Parameter' Any)) + +(with_template [<parents> <child>] + [(with_expansions [<raw> (template.symbol [<child> "'"])] + (nominal.def <raw> Any) + (type .public <child> + (`` (<| Return' Value' (,, (template.spliced <parents>)) <raw>))))] + + [[] Primitive] + [[Object' Parameter'] Var] + [[Object' Parameter'] Class] + [[Object' Parameter'] Array] + ) + +(nominal.def .public Declaration Any) +(nominal.def .public Inheritance Any) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/type/descriptor.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/type/descriptor.lux new file mode 100644 index 000000000..2327f07b2 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/type/descriptor.lux @@ -0,0 +1,125 @@ +(.require + [library + [lux (.except Declaration int char) + [abstract + [equivalence (.only Equivalence)]] + [control + ["[0]" maybe]] + [data + ["[0]" text (.use "[1]#[0]" equivalence) + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor)]]] + [math + [number + ["n" nat]]] + [meta + [type + ["[0]" nominal (.except def)]]]]] + ["[0]" // + [category (.only Void Value Return Method Primitive Object Class Array Var Parameter Declaration)] + ["/[1]" // + [encoding + ["[1][0]" name (.only Internal External)]]]]) + +(nominal.def .public (Descriptor category) + Text + + (def .public descriptor + (-> (Descriptor Any) Text) + (|>> representation)) + + (with_template [<sigil> <category> <name>] + [(def .public <name> + (Descriptor <category>) + (abstraction <sigil>))] + + ["V" Void void] + ["Z" Primitive boolean] + ["B" Primitive byte] + ["S" Primitive short] + ["I" Primitive int] + ["J" Primitive long] + ["F" Primitive float] + ["D" Primitive double] + ["C" Primitive char] + ) + + (def .public class_prefix "L") + (def .public class_suffix ";") + + (def .public class + (-> External (Descriptor Class)) + (|>> ///name.internal + ///name.read + (text.enclosed [..class_prefix ..class_suffix]) + abstraction)) + + (def .public (declaration name) + (-> External (Descriptor Declaration)) + (transmutation (..class name))) + + (def .public as_class + (-> (Descriptor Declaration) (Descriptor Class)) + (|>> transmutation)) + + (with_template [<name> <category>] + [(def .public <name> + (Descriptor <category>) + (transmutation + (..class "java.lang.Object")))] + + [var Var] + [wildcard Parameter] + ) + + (def .public (lower descriptor) + (-> (Descriptor Parameter) (Descriptor Parameter)) + ..wildcard) + + (def .public upper + (-> (Descriptor Parameter) (Descriptor Parameter)) + (|>> transmutation)) + + (def .public array_prefix "[") + + (def .public array + (-> (Descriptor Value) + (Descriptor Array)) + (|>> representation + (format ..array_prefix) + abstraction)) + + (def .public (method [inputs output]) + (-> [(List (Descriptor Value)) + (Descriptor Return)] + (Descriptor Method)) + (abstraction + (format (|> inputs + (list#each ..descriptor) + text.together + (text.enclosed ["(" ")"])) + (representation output)))) + + (def .public equivalence + (All (_ category) (Equivalence (Descriptor category))) + (implementation + (def (= parameter subject) + (text#= (representation parameter) (representation subject))))) + + (def .public class_name + (-> (Descriptor Object) Internal) + (let [prefix_size (text.size ..class_prefix) + suffix_size (text.size ..class_suffix)] + (function (_ descriptor) + (let [repr (representation descriptor)] + (if (text.starts_with? ..array_prefix repr) + (///name.internal repr) + (|> repr + (text.clip prefix_size + (|> (text.size repr) + (n.- prefix_size) + (n.- suffix_size))) + (of maybe.monad each ///name.internal) + maybe.trusted)))))) + ) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/type/lux.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/type/lux.lux new file mode 100644 index 000000000..5e9b87242 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/type/lux.lux @@ -0,0 +1,239 @@ +(.require + [library + [lux (.except int char parameter type) + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser (.use "[1]#[0]" monad)] + ["[0]" try] + ["[0]" exception (.only Exception)]] + [data + ["[0]" product] + ["[0]" text (.use "[1]#[0]" equivalence) + ["%" \\format (.only format)] + ["<[1]>" \\parser (.only Parser)]] + [collection + ["[0]" array] + ["[0]" dictionary (.only Dictionary)]]] + [meta + [type + [":" nominal] + ["[0]" check (.only Check) (.use "[1]#[0]" monad)]]]]] + ["[0]" // (.only) + [category (.only Void Value Return Method Primitive Object Class Array Var Parameter)] + ["[1][0]" descriptor] + ["[1][0]" signature] + ["[1][0]" reflection] + ["[1][0]" parser] + ["[1][0]" box] + ["/[1]" // + [encoding + ["[1][0]" name]]]]) + +(with_template [<name>] + [(:.def .public (<name> class) Any)] + + [Lower] + [Upper] + ) + +(.type .public Mapping + (Dictionary Text Type)) + +(def .public fresh + Mapping + (dictionary.empty text.hash)) + +(exception.def .public (unknown_var var) + (Exception Text) + (exception.report + (list ["Var" (%.text var)]))) + +(def void + (Parser (Check Type)) + (<>.after //parser.void + (<>#in (check#in .Any)))) + +(with_template [<name> <parser> <reflection>] + [(def <name> + (Parser (Check Type)) + (<>.after <parser> + (<>#in (check#in {.#Nominal (//reflection.reflection <reflection>) {.#End}}))))] + + [boolean //parser.boolean //reflection.boolean] + [byte //parser.byte //reflection.byte] + [short //parser.short //reflection.short] + [int //parser.int //reflection.int] + [long //parser.long //reflection.long] + [float //parser.float //reflection.float] + [double //parser.double //reflection.double] + [char //parser.char //reflection.char] + ) + +(with_template [<name> <parser> <box>] + [(def <name> + (Parser (Check Type)) + (<>.after <parser> + (<>#in (check#in {.#Nominal <box> {.#End}}))))] + + [boxed_boolean //parser.boolean //box.boolean] + [boxed_byte //parser.byte //box.byte] + [boxed_short //parser.short //box.short] + [boxed_int //parser.int //box.int] + [boxed_long //parser.long //box.long] + [boxed_float //parser.float //box.float] + [boxed_double //parser.double //box.double] + [boxed_char //parser.char //box.char] + ) + +(def primitive + (Parser (Check Type)) + (all <>.either + ..boolean + ..byte + ..short + ..int + ..long + ..float + ..double + ..char + )) + +(def boxed_primitive + (Parser (Check Type)) + (all <>.either + ..boxed_boolean + ..boxed_byte + ..boxed_short + ..boxed_int + ..boxed_long + ..boxed_float + ..boxed_double + ..boxed_char + )) + +(def wildcard + (Parser (Check Type)) + (<>.after //parser.wildcard + (<>#in (check#each product.right + check.existential)))) + +(def (var mapping) + (-> Mapping (Parser (Check Type))) + (do <>.monad + [var //parser.var'] + (in (when (dictionary.value var mapping) + {.#None} + (check.except ..unknown_var [var]) + + {.#Some type} + (check#in type))))) + +(def (class' parameter) + (-> (Parser (Check Type)) (Parser (Check Type))) + (|> (do <>.monad + [name //parser.class_name + parameters (|> (<>.some parameter) + (<>.after (<text>.this //signature.parameters_start)) + (<>.before (<text>.this //signature.parameters_end)) + (<>.else (list)))] + (in (do [! check.monad] + [parameters (monad.all ! parameters)] + (in {.#Nominal name parameters})))) + (<>.after (<text>.this //descriptor.class_prefix)) + (<>.before (<text>.this //descriptor.class_suffix)))) + +(with_template [<name> <prefix> <constructor>] + [(def <name> + (-> (Parser (Check Type)) (Parser (Check Type))) + (|> (<>.after (<text>.this <prefix>)) + ... TODO: Re-enable Lower and Upper, instead of using the simplified limit. + ... (<>#each (check#each (|>> <ctor> .type))) + ))] + + [lower //signature.lower_prefix ..Lower] + [upper //signature.upper_prefix ..Upper] + ) + +(def (parameter mapping) + (-> Mapping (Parser (Check Type))) + (<>.rec + (function (_ parameter) + (let [class (..class' parameter)] + (all <>.either + (..var mapping) + ..wildcard + (..lower class) + (..upper class) + class + ))))) + +(def .public class + (-> Mapping (Parser (Check Type))) + (|>> ..parameter ..class')) + +(def array + (-> (Parser (Check Type)) (Parser (Check Type))) + (|>> (<>#each (check#each (function (_ elementT) + (when elementT + {.#Nominal name {.#End}} + (if (`` (or (,, (with_template [<reflection>] + [(text#= (//reflection.reflection <reflection>) name)] + + [//reflection.boolean] + [//reflection.byte] + [//reflection.short] + [//reflection.int] + [//reflection.long] + [//reflection.float] + [//reflection.double] + [//reflection.char])))) + {.#Nominal (|> name //reflection.class //reflection.array //reflection.reflection) {.#End}} + (|> elementT array.Array type_literal)) + + _ + (|> elementT array.Array type_literal))))) + (<>.after (<text>.this //descriptor.array_prefix)))) + +(def .public (type mapping) + (-> Mapping (Parser (Check Type))) + (<>.rec + (function (_ type) + (all <>.either + ..primitive + (parameter mapping) + (..array type) + )))) + +(def .public (boxed_type mapping) + (-> Mapping (Parser (Check Type))) + (<>.rec + (function (_ type) + (all <>.either + ..boxed_primitive + (parameter mapping) + (..array type) + )))) + +(def .public (return mapping) + (-> Mapping (Parser (Check Type))) + (all <>.either + ..void + (..type mapping) + )) + +(def .public (boxed_return mapping) + (-> Mapping (Parser (Check Type))) + (all <>.either + ..void + (..boxed_type mapping) + )) + +(def .public (check operation input) + (All (_ a) (-> (Parser (Check a)) Text (Check a))) + (when (<text>.result operation input) + {try.#Success check} + check + + {try.#Failure error} + (check.failure error))) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/type/parser.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/type/parser.lux new file mode 100644 index 000000000..2ad5b09a2 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/type/parser.lux @@ -0,0 +1,277 @@ +(.require + [library + [lux (.except Type Declaration int char parameter) + [abstract + [monad (.only do)]] + [control + ["<>" parser (.use "[1]#[0]" monad)] + ["[0]" try] + ["[0]" function]] + [data + ["[0]" product] + ["[0]" text + ["%" \\format (.only format)] + ["<[1]>" \\parser (.only Parser)]] + [collection + ["[0]" list]]]]] + ["[0]" // (.only Type) + [category (.only Void Value Return Method Primitive Object Class Array Var Parameter Declaration)] + ["[1][0]" signature] + ["[1][0]" descriptor] + [// + [encoding + ["[1][0]" name (.only External)]]]]) + +(with_template [<category> <name> <signature> <type>] + [(def .public <name> + (Parser (Type <category>)) + (<>.after (<text>.this (//signature.signature <signature>)) + (<>#in <type>)))] + + [Void void //signature.void //.void] + [Primitive boolean //signature.boolean //.boolean] + [Primitive byte //signature.byte //.byte] + [Primitive short //signature.short //.short] + [Primitive int //signature.int //.int] + [Primitive long //signature.long //.long] + [Primitive float //signature.float //.float] + [Primitive double //signature.double //.double] + [Primitive char //signature.char //.char] + [Parameter wildcard //signature.wildcard //.wildcard] + ) + +(def .public primitive + (Parser (Type Primitive)) + (all <>.either + ..boolean + ..byte + ..short + ..int + ..long + ..float + ..double + ..char + )) + +(def var/head + (format "abcdefghijklmnopqrstuvwxyz" + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "_")) + +(def var/tail + (format var/head + "0123456789$")) + +(def class/set + (format var/tail //name.internal_separator)) + +(with_template [<type> <name> <head> <tail> <adapter>] + [(def .public <name> + (Parser <type>) + (of <>.functor each <adapter> + (<text>.slice (<text>.and! (<text>.one_of! <head>) + (<text>.some! (<text>.one_of! <tail>))))))] + + [External class_name class/set class/set (|>> //name.internal //name.external)] + [Text var_name var/head var/tail function.identity] + ) + +(def .public var' + (Parser Text) + (|> ..var_name + (<>.after (<text>.this //signature.var_prefix)) + (<>.before (<text>.this //descriptor.class_suffix)))) + +(def .public var + (Parser (Type Var)) + (<>#each //.var ..var')) + +(def .public var? + (-> (Type Value) (Maybe Text)) + (|>> //.signature + //signature.signature + (<text>.result ..var') + try.maybe)) + +(def .public name + (-> (Type Var) Text) + (|>> //.signature + //signature.signature + (<text>.result ..var') + try.trusted)) + +(with_template [<name> <prefix> <constructor>] + [(def <name> + (-> (Parser (Type Parameter)) (Parser (Type Parameter))) + (|>> (<>.after (<text>.this <prefix>)) + (<>#each <constructor>)))] + + [lower //signature.lower_prefix //.lower] + [upper //signature.upper_prefix //.upper] + ) + +(def (class'' parameter) + (-> (Parser (Type Parameter)) (Parser [External (List (Type Parameter))])) + (|> (do <>.monad + [name ..class_name + parameters (|> (<>.some parameter) + (<>.after (<text>.this //signature.parameters_start)) + (<>.before (<text>.this //signature.parameters_end)) + (<>.else (list)))] + (in [name parameters])) + (<>.after (<text>.this //descriptor.class_prefix)) + (<>.before (<text>.this //descriptor.class_suffix)))) + +(def class' + (-> (Parser (Type Parameter)) (Parser (Type Class))) + (|>> ..class'' + (of <>.monad each (product.uncurried //.class)))) + +(def .public array' + (-> (Parser (Type Value)) (Parser (Type Array))) + (|>> (<>.after (<text>.this //descriptor.array_prefix)) + (<>#each //.array))) + +(def (parameter' value) + (-> (Parser (Type Value)) (Parser (Type Parameter))) + (<>.rec + (function (_ parameter) + (let [class (..class' parameter)] + (all <>.either + ..var + ..wildcard + (..lower parameter) + (..upper parameter) + (..array' value) + class + ))))) + +(def .public value + (Parser (Type Value)) + (<>.rec + (function (_ value) + (all <>.either + ..primitive + (..parameter' value) + )))) + +(def .public parameter + (Parser (Type Parameter)) + (..parameter' ..value)) + +(def .public class + (Parser (Type Class)) + (..class' ..parameter)) + +(with_template [<name> <prefix> <constructor>] + [(def .public <name> + (-> (Type Value) (Maybe (Type Parameter))) + (|>> //.signature + //signature.signature + (<text>.result (<>.after (<text>.this <prefix>) ..parameter)) + try.maybe))] + + [lower? //signature.lower_prefix //.lower] + [upper? //signature.upper_prefix //.upper] + ) + +(def .public read_class + (-> (Type Class) [External (List (Type Parameter))]) + (|>> //.signature + //signature.signature + (<text>.result (..class'' ..parameter)) + try.trusted)) + +(def .public array + (Parser (Type Array)) + (..array' ..value)) + +(def .public object + (Parser (Type Object)) + (all <>.either + ..class + ..array)) + +(def inputs + (|> (<>.some ..value) + (<>.after (<text>.this //signature.arguments_start)) + (<>.before (<text>.this //signature.arguments_end)))) + +(def .public return + (Parser (Type Return)) + (<>.either ..void + ..value)) + +(def exception + (Parser (Type Class)) + (|> ..class + (<>.after (<text>.this //signature.exception_prefix)))) + +(def .public var_declaration + (Parser [(Type Var) (Type Class)]) + (do <>.monad + [name ..var_name + _ (<text>.this //signature.format_type_parameter_infix) + type ..class] + (in [(//.var name) type]))) + +(def .public method + (-> (Type Method) + [(List (Type Var)) + (List (Type Value)) + (Type Return) + (List (Type Class))]) + (let [parser (is (Parser [(List (Type Var)) + (List (Type Value)) + (Type Return) + (List (Type Class))]) + (all <>.and + (|> (<>.some (<>#each product.left ..var_declaration)) + (<>.after (<text>.this //signature.parameters_start)) + (<>.before (<text>.this //signature.parameters_end)) + (<>.else (list))) + ..inputs + ..return + (<>.some ..exception)))] + (|>> //.signature + //signature.signature + (<text>.result parser) + try.trusted))) + +(with_template [<name> <category> <parser>] + [(def .public <name> + (-> (Type Value) (Maybe <category>)) + (|>> //.signature + //signature.signature + (<text>.result <parser>) + try.maybe))] + + [array? (Type Value) + (do <>.monad + [_ (<text>.this //descriptor.array_prefix)] + ..value)] + [class? [External (List (Type Parameter))] + (..class'' ..parameter)] + + [primitive? (Type Primitive) ..primitive] + [wildcard? (Type Parameter) ..wildcard] + [parameter? (Type Parameter) ..parameter] + [object? (Type Object) ..object] + ) + +(def .public declaration' + (Parser [External (List (Type Var))]) + (|> (<>.and ..class_name + (|> (<>.some ..var) + (<>.after (<text>.this //signature.parameters_start)) + (<>.before (<text>.this //signature.parameters_end)) + (<>.else (list)))) + (<>.after (<text>.this //descriptor.class_prefix)) + (<>.before (<text>.this //descriptor.class_suffix)))) + +(def .public declaration + (-> (Type Declaration) [External (List (Type Var))]) + (|>> //.signature + //signature.signature + (<text>.result ..declaration') + try.trusted)) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/type/reflection.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/type/reflection.lux new file mode 100644 index 000000000..1478a0494 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/type/reflection.lux @@ -0,0 +1,105 @@ +(.require + [library + [lux (.except Declaration int char) + [abstract + [equivalence (.only Equivalence)]] + [data + ["[0]" text (.use "[1]#[0]" equivalence) + ["%" \\format (.only format)]]] + [meta + [type + ["[0]" nominal (.except def)]]]]] + ["[0]" // + [category (.only Void Value Return Method Primitive Object Class Array Var Parameter Declaration)] + ["[1][0]" descriptor] + [// + [encoding + ["[1][0]" name (.only External)]]]]) + +(nominal.def .public (Reflection category) + Text + + (def .public reflection + (-> (Reflection Any) Text) + (|>> representation)) + + (def .public equivalence + (All (_ category) (Equivalence (Reflection category))) + (implementation + (def (= parameter subject) + (text#= (representation parameter) (representation subject))))) + + (with_template [<category> <name> <reflection>] + [(def .public <name> + (Reflection <category>) + (abstraction <reflection>))] + + [Void void "void"] + [Primitive boolean "boolean"] + [Primitive byte "byte"] + [Primitive short "short"] + [Primitive int "int"] + [Primitive long "long"] + [Primitive float "float"] + [Primitive double "double"] + [Primitive char "char"] + ) + + (def .public class + (-> External (Reflection Class)) + (|>> abstraction)) + + (def .public (declaration name) + (-> External (Reflection Declaration)) + (transmutation (..class name))) + + (def .public as_class + (-> (Reflection Declaration) (Reflection Class)) + (|>> transmutation)) + + (def .public (array element) + (-> (Reflection Value) (Reflection Array)) + (let [element' (representation element) + elementR (`` (cond (text.starts_with? //descriptor.array_prefix element') + element' + + (,, (with_template [<primitive> <descriptor>] + [(of ..equivalence = <primitive> element) + (//descriptor.descriptor <descriptor>)] + + [..boolean //descriptor.boolean] + [..byte //descriptor.byte] + [..short //descriptor.short] + [..int //descriptor.int] + [..long //descriptor.long] + [..float //descriptor.float] + [..double //descriptor.double] + [..char //descriptor.char])) + + (|> element' + //descriptor.class + //descriptor.descriptor + (text.replaced //name.internal_separator + //name.external_separator))))] + (|> elementR + (format //descriptor.array_prefix) + abstraction))) + + (with_template [<name> <category>] + [(def .public <name> + (Reflection <category>) + (transmutation + (..class "java.lang.Object")))] + + [var Var] + [wildcard Parameter] + ) + + (def .public (lower reflection) + (-> (Reflection Parameter) (Reflection Parameter)) + ..wildcard) + + (def .public upper + (-> (Reflection Parameter) (Reflection Parameter)) + (|>> transmutation)) + ) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/type/signature.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/type/signature.lux new file mode 100644 index 000000000..1f7eb3a53 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/type/signature.lux @@ -0,0 +1,183 @@ +(.require + [library + [lux (.except Declaration int char) + [abstract + [equivalence (.only Equivalence)] + [hash (.only Hash)]] + [control + ["[0]" pipe]] + [data + ["[0]" text (.use "[1]#[0]" hash) + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor)]]] + [meta + [type + ["[0]" nominal (.except def)]]]]] + ["[0]" // + [category (.only Void Value Return Method Primitive Object Class Array Var Parameter Declaration Inheritance)] + ["[1][0]" descriptor] + ["/[1]" // + [encoding + ["[1][0]" name (.only External)]]]]) + +(nominal.def .public (Signature category) + Text + + (def .public signature + (-> (Signature Any) Text) + (|>> representation)) + + (with_template [<category> <name> <descriptor>] + [(def .public <name> + (Signature <category>) + (abstraction (//descriptor.descriptor <descriptor>)))] + + [Void void //descriptor.void] + [Primitive boolean //descriptor.boolean] + [Primitive byte //descriptor.byte] + [Primitive short //descriptor.short] + [Primitive int //descriptor.int] + [Primitive long //descriptor.long] + [Primitive float //descriptor.float] + [Primitive double //descriptor.double] + [Primitive char //descriptor.char] + ) + + (def .public array + (-> (Signature Value) (Signature Array)) + (|>> representation + (format //descriptor.array_prefix) + abstraction)) + + (def .public wildcard + (Signature Parameter) + (abstraction "*")) + + (with_template [<char> <name>] + [(def .public <name> <char>)] + + ["T" var_prefix] + ["-" lower_prefix] + ["+" upper_prefix] + + ["<" parameters_start] + [">" parameters_end] + [":" format_type_parameter_infix] + + ["(" arguments_start] + [")" arguments_end] + ["^" exception_prefix] + ) + + (with_template [<name> <prefix>] + [(def .public <name> + (-> (Signature Parameter) (Signature Parameter)) + (|>> representation (format <prefix>) abstraction))] + + [lower ..lower_prefix] + [upper ..upper_prefix] + ) + + (def .public var + (-> Text (Signature Var)) + (|>> (text.enclosed [..var_prefix //descriptor.class_suffix]) + abstraction)) + + (def .public var_name + (-> (Signature Var) Text) + (|>> representation + (text.replaced ..var_prefix "") + (text.replaced //descriptor.class_suffix ""))) + + (def .public (class name parameters) + (-> External (List (Signature Parameter)) (Signature Class)) + (abstraction + (format //descriptor.class_prefix + (|> name ///name.internal ///name.read) + (when parameters + {.#End} + "" + + _ + (format ..parameters_start + (|> parameters + (list#each ..signature) + text.together) + ..parameters_end)) + //descriptor.class_suffix))) + + (def .public (declaration name variables) + (-> External (List (Signature Var)) (Signature Declaration)) + (transmutation (..class name variables))) + + (def class_bound + (|> (..class "java.lang.Object" (list)) + ..signature + (format ..format_type_parameter_infix))) + + (def var_declaration/1 + (-> (Signature Var) Text) + (|>> ..var_name + (text.suffix ..class_bound))) + + (def var_declaration/+ + (-> (List (Signature Var)) Text) + (|>> (list#each ..var_declaration/1) + text.together + (text.enclosed [..parameters_start + ..parameters_end]))) + + (def var_declaration/* + (-> (List (Signature Var)) Text) + (|>> (pipe.when + {.#End} + "" + + it + (..var_declaration/+ it)))) + + (def .public (inheritance variables super interfaces) + (-> (List (Signature Var)) (Signature Class) (List (Signature Class)) (Signature Inheritance)) + (abstraction + (format (var_declaration/* variables) + (representation super) + (|> interfaces + (list#each ..signature) + text.together)))) + + (def .public as_class + (-> (Signature Declaration) (Signature Class)) + (|>> transmutation)) + + (def .public (method [type_variables inputs output exceptions]) + (-> [(List (Signature Var)) + (List (Signature Value)) + (Signature Return) + (List (Signature Class))] + (Signature Method)) + (abstraction + (format (var_declaration/* type_variables) + (|> inputs + (list#each ..signature) + text.together + (text.enclosed [..arguments_start + ..arguments_end])) + (representation output) + (|> exceptions + (list#each (|>> representation (format ..exception_prefix))) + text.together)))) + + (def .public equivalence + (All (_ category) (Equivalence (Signature category))) + (implementation + (def (= parameter subject) + (text#= (representation parameter) + (representation subject))))) + + (def .public hash + (All (_ category) (Hash (Signature category))) + (implementation + (def equivalence ..equivalence) + (def hash (|>> representation text#hash)))) + ) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/version.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/version.lux new file mode 100644 index 000000000..8e8b82dcc --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/version.lux @@ -0,0 +1,42 @@ +(.require + [library + [lux (.except) + [control + ["[0]" try]]]] + ["[0]" // + [encoding + ["[1][0]" unsigned (.only U2)]]]) + +(type .public Version U2) +(type .public Minor Version) +(type .public Major Version) + +(def .public default_minor + Minor + (|> 0 + //unsigned.u2 + try.trusted)) + +(with_template [<number> <name>] + [(def .public <name> + Major + (|> <number> + //unsigned.u2 + try.trusted))] + + [45 v1_1] + [46 v1_2] + [47 v1_3] + [48 v1_4] + [49 v5_0] + [50 v6_0] + [51 v7] + [52 v8] + [53 v9] + [54 v10] + [55 v11] + [56 v12] + ) + +(def .public format + //unsigned.format/2) |