aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/host/jvm.lux69
-rw-r--r--stdlib/source/lux/host/jvm/attribute.lux22
-rw-r--r--stdlib/source/lux/host/jvm/constant.lux39
-rw-r--r--stdlib/source/lux/host/jvm/constant/pool.lux83
-rw-r--r--stdlib/source/lux/host/jvm/index.lux32
5 files changed, 149 insertions, 96 deletions
diff --git a/stdlib/source/lux/host/jvm.lux b/stdlib/source/lux/host/jvm.lux
index cc2216502..b8139760c 100644
--- a/stdlib/source/lux/host/jvm.lux
+++ b/stdlib/source/lux/host/jvm.lux
@@ -1,22 +1,26 @@
(.module:
[lux #*
+ [control
+ ["." monad (#+ do)]
+ ["." state (#+ State)]]
[data
[format
["." binary (#+ Format)]]
[collection
- [list ("list/." Fold<List>)]
["." row (#+ Row)]]]]
[/
["/." version (#+ Version Minor Major)]
["/." name (#+ Internal)]
+ ["/." magic (#+ Magic)]
+ ["/." index (#+ Index)]
+ ["/." attribute (#+ Attribute)]
[modifier
["/.M" class]]
- ["/." magic (#+ Magic)]
- ["/." constant (#+ Constant)]
- ["/." index (#+ Index)]])
+ ["/." constant (#+ Constant)
+ ["/." pool (#+ Pool)]]])
(type: #export Interface
- Index)
+ (Index /constant.Class))
(type: #export Field
Any)
@@ -24,19 +28,14 @@
(type: #export Method
Any)
-(type: #export Attribute
- Any)
-
-(type: #export Pool (Row Constant))
-
(type: #export Class
{#magic Magic
#minor-version Minor
#major-version Major
#constant-pool Pool
#access-flags /classM.Modifier
- #this Index
- #super Index
+ #this (Index /constant.Class)
+ #super (Index /constant.Class)
#interfaces (Row Interface)
#fields (Row Field)
#methods (Row Method)
@@ -44,38 +43,32 @@
(def: default-minor-version Minor (/version.version 0))
+(def: (install-classes this super interfaces)
+ (-> Internal Internal (List Internal)
+ (State Pool [(Index /constant.Class) (Index /constant.Class) (Row Interface)]))
+ (do state.Monad<State>
+ [@this (/pool.class (/name.read this))
+ @super (/pool.class (/name.read super))
+ @interfaces (monad.fold @ (function (_ interface @interfaces)
+ (do @
+ [@interface (/pool.class (/name.read interface))]
+ (wrap (row.add @interface @interfaces))))
+ (: (Row Interface) row.empty)
+ interfaces)]
+ (wrap [@this @super @interfaces])))
+
(def: #export (class version access super this interfaces)
(-> Major /classM.Modifier Internal Internal (List Internal) Class)
- (let [with-classes (: (-> Pool Pool)
- (|>> (row.add (#/constant.UTF8 (/name.read this)))
- (row.add (#/constant.Class (/index.index 1)))
- (row.add (#/constant.UTF8 (/name.read super)))
- (row.add (#/constant.Class (/index.index 3)))))
- with-interfaces (: (-> Nat Pool [(Row Index) Pool])
- (function (_ offset pool)
- (let [[_last-index indices pool']
- (list/fold (function (_ interface [index interface-indices' pool'])
- [(n/+ 2 index)
- (row.add (/index.index (n/+ 1 index))
- interface-indices')
- (|> pool'
- (row.add (#/constant.UTF8 (/name.read interface)))
- (row.add (#/constant.Class (/index.index index))))])
- [offset (: (Row Index) row.empty) pool]
- interfaces)]
- [indices pool'])))
- interfaces-offset 5
- [interface-indices pool] (|> row.empty
- with-classes
- (with-interfaces interfaces-offset))]
+ (let [[pool [@this @super @interfaces]] (state.run (: Pool row.empty)
+ (install-classes this super interfaces))]
{#magic /magic.code
#minor-version ..default-minor-version
#major-version version
#constant-pool pool
#access-flags access
- #this (/index.index 2)
- #super (/index.index 4)
- #interfaces interface-indices
+ #this @this
+ #super @super
+ #interfaces @interfaces
#fields row.empty
#methods row.empty
#attributes row.empty}))
@@ -86,7 +79,7 @@
/magic.format
/version.format
/version.format
- (binary.row/16' 1 /constant.format)
+ /pool.format
/classM.format
/index.format
/index.format
diff --git a/stdlib/source/lux/host/jvm/attribute.lux b/stdlib/source/lux/host/jvm/attribute.lux
new file mode 100644
index 000000000..3f0dd9b61
--- /dev/null
+++ b/stdlib/source/lux/host/jvm/attribute.lux
@@ -0,0 +1,22 @@
+(.module:
+ [lux #*
+ [data
+ [format
+ ["." binary (#+ Format)]]]]
+ [//
+ ["//." encoding (#+ U2 U4)]
+ ["//." index (#+ Index)]])
+
+(type: #export Constant-Value
+ {#name Index
+ #length U4
+ #index Index})
+
+(def: #export constant-value
+ ($_ binary.and
+ //index.format
+ //encoding.u4-format
+ //index.format))
+
+(type: #export Attribute
+ Any)
diff --git a/stdlib/source/lux/host/jvm/constant.lux b/stdlib/source/lux/host/jvm/constant.lux
index d20e34d31..d2c9018ae 100644
--- a/stdlib/source/lux/host/jvm/constant.lux
+++ b/stdlib/source/lux/host/jvm/constant.lux
@@ -2,7 +2,8 @@
[lux #*
[control
[monad (#+ do)]
- ["." parser]]
+ ["." parser]
+ ["." equivalence (#+ Equivalence)]]
[data
[format
["." binary (#+ Format) ("mutation/." Monoid<Mutation>)]]
@@ -15,14 +16,42 @@
[/
["/." tag ("tag/." Equivalence<Tag>)]])
+(type: #export UTF8 Text)
+
+(def: utf8-format
+ (Format UTF8)
+ binary.utf8/16)
+
+(abstract: #export Class
+ {}
+
+ (Index UTF8)
+
+ (def: #export class
+ (-> (Index UTF8) Class)
+ (|>> :abstraction))
+
+ (def: #export Equivalence<Class>
+ (Equivalence Class)
+ (:: equivalence.Contravariant<Equivalence> map-1
+ (|>> :representation)
+ //index.Equivalence<Index>))
+
+ (def: class-format
+ (Format Class)
+ (binary.adapt (|>> :abstraction)
+ (|>> :representation)
+ //index.format))
+ )
+
(type: #export Constant
- (#UTF8 Text)
- (#Class Index))
+ (#UTF8 UTF8)
+ (#Class Class))
(def: #export format
(Format Constant)
- (with-expansions [<constants> (as-is [#UTF8 /tag.utf8 binary.utf8/16]
- [#Class /tag.class //index.format])]
+ (with-expansions [<constants> (as-is [#UTF8 /tag.utf8 ..utf8-format]
+ [#Class /tag.class ..class-format])]
{#binary.reader (do parser.Monad<Parser>
[tag (get@ #binary.reader /tag.format)]
(`` (cond (~~ (do-template [<case> <tag> <format>]
diff --git a/stdlib/source/lux/host/jvm/constant/pool.lux b/stdlib/source/lux/host/jvm/constant/pool.lux
index 8d221712b..b21477b61 100644
--- a/stdlib/source/lux/host/jvm/constant/pool.lux
+++ b/stdlib/source/lux/host/jvm/constant/pool.lux
@@ -1,67 +1,60 @@
(.module:
[lux #*
+ [control
+ [monad (#+ do)]
+ ["." state (#+ State)]]
[data
[text ("text/." Equivalence<Text>)]
[format
["." binary (#+ Format)]]
[collection
[list ("list/." Fold<List>)]
- ["." row (#+ Row)]]]]
- ["." // (#+ Constant)
+ ["." row (#+ Row)]]]
+ [type
+ abstract]]
+ ["." // (#+ UTF8 Class Constant) ("class/." Equivalence<Class>)
[//
- ["." encoding ("u2/." Equivalence<U2>)]
+ ["." encoding]
["." index (#+ Index)]]])
(def: offset 1)
(type: #export Pool (Row Constant))
-(def: #export (utf8 value pool)
- (-> Text Pool [Pool Index])
- (with-expansions [<index> (as-is (index.index (n/+ offset idx)))
- <try-again> (as-is (recur (.inc idx)))]
- (loop [idx 0]
- (case (row.nth idx pool)
- (#.Some entry)
- (case entry
- (#//.UTF8 reference)
- (if (text/= reference value)
- [pool
- <index>]
+(template: (!add <value> <tag> <=>)
+ (function (_ pool)
+ (with-expansions [<index> (as-is (index.index (encoding.to-u2 (n/+ offset idx))))
+ <try-again> (as-is (recur (.inc idx)))]
+ (loop [idx 0]
+ (case (row.nth idx pool)
+ (#.Some entry)
+ (case entry
+ (<tag> reference)
+ (if (<=> reference <value>)
+ [pool
+ <index>]
+ <try-again>)
+
+ _
<try-again>)
- _
- <try-again>)
-
- #.None
- [(row.add (#//.UTF8 value) pool)
- <index>]))))
+ #.None
+ [(row.add (<tag> <value>) pool)
+ <index>])))))
-(def: (class' value pool)
- (-> Index Pool [Pool Index])
- (with-expansions [<index> (as-is (index.index (n/+ offset idx)))
- <try-again> (as-is (recur (.inc idx)))]
- (loop [idx 0]
- (case (row.nth idx pool)
- (#.Some entry)
- (case entry
- (#//.Class reference)
- (if (u2/= reference value)
- [pool
- <index>]
- <try-again>)
-
- _
- <try-again>)
-
- #.None
- [(row.add (#//.Class value) pool)
- <index>]))))
+(def: #export (utf8 value)
+ (-> UTF8 (State Pool (Index UTF8)))
+ (!add value #//.UTF8 text/=))
+
+(def: (class' value)
+ (-> Class (State Pool (Index Class)))
+ (!add value #//.Class class/=))
-(def: #export (class name pool)
- (-> Text Pool [Pool Index])
- (let [[pool @name] (utf8 name pool)]
- (class' @name pool)))
+(def: #export (class name)
+ (-> UTF8 (State Pool (Index Class)))
+ (do state.Monad<State>
+ [@name (utf8 name)]
+ (class' (//.class @name))))
(def: #export format
(Format Pool)
diff --git a/stdlib/source/lux/host/jvm/index.lux b/stdlib/source/lux/host/jvm/index.lux
index 60d6211c6..3bf7e150b 100644
--- a/stdlib/source/lux/host/jvm/index.lux
+++ b/stdlib/source/lux/host/jvm/index.lux
@@ -1,17 +1,33 @@
(.module:
[lux #*
+ [control
+ ["." equivalence (#+ Equivalence)]]
[data
[format
- [binary (#+ Format)]]]]
+ ["." binary (#+ Format)]]]
+ [type
+ abstract]]
[//
["//." encoding (#+ U2)]])
-(type: #export Index U2)
+(abstract: #export (Index kind)
+ {}
-(def: #export index
- (-> Nat Index)
- //encoding.to-u2)
+ U2
-(def: #export format
- (Format Index)
- //encoding.u2-format)
+ (def: #export index
+ (All [kind] (-> U2 (Index kind)))
+ (|>> :abstraction))
+
+ (def: #export Equivalence<Index>
+ (All [kind] (Equivalence (Index kind)))
+ (:: equivalence.Contravariant<Equivalence> map-1
+ (|>> :representation)
+ //encoding.Equivalence<U2>))
+
+ (def: #export format
+ (All [kind] (Format (Index kind)))
+ (binary.adapt (|>> :abstraction)
+ (|>> :representation)
+ //encoding.u2-format))
+ )
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-09 20:07:37 +0000