diff options
Diffstat (limited to 'stdlib/source/library/lux/target/jvm/constant')
-rw-r--r-- | stdlib/source/library/lux/target/jvm/constant/pool.lux | 158 | ||||
-rw-r--r-- | stdlib/source/library/lux/target/jvm/constant/tag.lux | 50 |
2 files changed, 208 insertions, 0 deletions
diff --git a/stdlib/source/library/lux/target/jvm/constant/pool.lux b/stdlib/source/library/lux/target/jvm/constant/pool.lux new file mode 100644 index 000000000..e7fa465d8 --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/constant/pool.lux @@ -0,0 +1,158 @@ +(.module: + [library + [lux #* + ["." ffi] + [abstract + [equivalence (#+ Equivalence)] + [monad (#+ Monad do)]] + [control + ["." state (#+ State')] + ["." try (#+ Try)]] + [data + ["." product] + ["." text] + ["." format #_ + ["#" binary (#+ Writer) ("specification\." monoid)]] + [collection + ["." row (#+ Row) ("#\." fold)]]] + [macro + ["." template]] + [math + [number + ["." i32] + ["n" nat] + ["." int] + ["." frac]]] + [type + abstract]]] + ["." // (#+ UTF8 String Class Integer Float Long Double Constant Name_And_Type Reference) + [// + [encoding + ["#." name (#+ Internal External)] + ["#." unsigned]] + ["#." index (#+ Index)] + [type + [category (#+ Value Method)] + ["#." descriptor (#+ Descriptor)]]]]) + +(type: #export Pool [Index (Row [Index Constant])]) + +(def: #export equivalence + (Equivalence Pool) + (product.equivalence //index.equivalence + (row.equivalence (product.equivalence //index.equivalence + //.equivalence)))) + +(type: #export (Resource a) + (State' Try Pool a)) + +(def: #export monad + (Monad Resource) + (state.with try.monad)) + +(template: (!add <tag> <equivalence> <value>) + (function (_ [current pool]) + (let [<value>' <value>] + (with_expansions [<try_again> (as_is (recur (.inc idx)))] + (loop [idx 0] + (case (row.nth idx pool) + (#try.Success entry) + (case entry + [index (<tag> reference)] + (if (\ <equivalence> = reference <value>') + (#try.Success [[current pool] + index]) + <try_again>) + + _ + <try_again>) + + (#try.Failure _) + (let [new (<tag> <value>')] + (do {! try.monad} + [@new (//unsigned.u2 (//.size new)) + next (: (Try Index) + (|> current + //index.value + (//unsigned.+/2 @new) + (\ ! map //index.index)))] + (wrap [[next + (row.add [current new] pool)] + current]))))))))) + +(template: (!index <index>) + (|> <index> //index.value //unsigned.value)) + +(type: (Adder of) + (-> of (Resource (Index of)))) + +(template [<name> <type> <tag> <equivalence>] + [(def: #export (<name> value) + (Adder <type>) + (!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: #export (string value) + (-> Text (Resource (Index String))) + (do ..monad + [@value (utf8 value) + #let [value (//.string @value)]] + (!add #//.String (//.value_equivalence //index.equivalence) value))) + +(def: #export (class name) + (-> Internal (Resource (Index Class))) + (do ..monad + [@name (utf8 (//name.read name)) + #let [value (//.class @name)]] + (!add #//.Class //.class_equivalence value))) + +(def: #export (descriptor value) + (All [kind] + (-> (Descriptor kind) + (Resource (Index (Descriptor kind))))) + (let [value (//descriptor.descriptor value)] + (!add #//.UTF8 text.equivalence value))) + +(type: #export (Member of) + {#name UTF8 + #descriptor (Descriptor of)}) + +(def: #export (name_and_type [name descriptor]) + (All [of] + (-> (Member of) (Resource (Index (Name_And_Type of))))) + (do ..monad + [@name (utf8 name) + @descriptor (..descriptor descriptor)] + (!add #//.Name_And_Type //.name_and_type_equivalence {#//.name @name #//.descriptor @descriptor}))) + +(template [<name> <tag> <of>] + [(def: #export (<name> class member) + (-> External (Member <of>) (Resource (Index (Reference <of>)))) + (do ..monad + [@class (..class (//name.internal class)) + @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: #export writer + (Writer Pool) + (function (_ [next pool]) + (row\fold (function (_ [_index post] pre) + (specification\compose pre (//.writer post))) + (format.bits/16 (!index next)) + pool))) + +(def: #export empty + Pool + [(|> 1 //unsigned.u2 try.assume //index.index) + row.empty]) diff --git a/stdlib/source/library/lux/target/jvm/constant/tag.lux b/stdlib/source/library/lux/target/jvm/constant/tag.lux new file mode 100644 index 000000000..414de077b --- /dev/null +++ b/stdlib/source/library/lux/target/jvm/constant/tag.lux @@ -0,0 +1,50 @@ +(.module: + [library + [lux #* + [abstract + [equivalence (#+ Equivalence)]] + [control + ["." try]] + [data + [format + [binary (#+ Writer)]]] + [type + abstract]]] + ["." /// #_ + [encoding + ["#." unsigned (#+ U1) ("u1//." equivalence)]]]) + +(abstract: #export Tag + U1 + + (implementation: #export equivalence + (Equivalence Tag) + (def: (= reference sample) + (u1//= (:representation reference) + (:representation sample)))) + + (template [<code> <name>] + [(def: #export <name> + Tag + (|> <code> ///unsigned.u1 try.assume :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: #export writer + (Writer Tag) + (|>> :representation ///unsigned.writer/1)) + ) |