aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/library/lux/target/jvm/constant
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source/library/lux/target/jvm/constant')
-rw-r--r--stdlib/source/library/lux/target/jvm/constant/pool.lux158
-rw-r--r--stdlib/source/library/lux/target/jvm/constant/tag.lux50
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))
+ )