From e8a0d92c252e8cb87a5fdbb206cb9c4905516f53 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 27 Dec 2018 01:13:32 -0400 Subject: - Some improvements to Index. - Some improvements to Constant. - Some improvements to Pool. - WIP: Attribute --- stdlib/source/lux/host/jvm.lux | 69 +++++++++++------------ stdlib/source/lux/host/jvm/attribute.lux | 22 ++++++++ stdlib/source/lux/host/jvm/constant.lux | 39 +++++++++++-- stdlib/source/lux/host/jvm/constant/pool.lux | 83 +++++++++++++--------------- stdlib/source/lux/host/jvm/index.lux | 32 ++++++++--- 5 files changed, 149 insertions(+), 96 deletions(-) create mode 100644 stdlib/source/lux/host/jvm/attribute.lux (limited to 'stdlib/source') 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)] ["." 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 + [@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)]] @@ -15,14 +16,42 @@ [/ ["/." tag ("tag/." Equivalence)]]) +(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 + (Equivalence Class) + (:: equivalence.Contravariant map-1 + (|>> :representation) + //index.Equivalence)) + + (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 [ (as-is [#UTF8 /tag.utf8 binary.utf8/16] - [#Class /tag.class //index.format])] + (with-expansions [ (as-is [#UTF8 /tag.utf8 ..utf8-format] + [#Class /tag.class ..class-format])] {#binary.reader (do parser.Monad [tag (get@ #binary.reader /tag.format)] (`` (cond (~~ (do-template [ ] 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)] [format ["." binary (#+ Format)]] [collection [list ("list/." Fold)] - ["." row (#+ Row)]]]] - ["." // (#+ Constant) + ["." row (#+ Row)]]] + [type + abstract]] + ["." // (#+ UTF8 Class Constant) ("class/." Equivalence) [// - ["." encoding ("u2/." Equivalence)] + ["." encoding] ["." index (#+ Index)]]]) (def: offset 1) (type: #export Pool (Row Constant)) -(def: #export (utf8 value pool) - (-> Text Pool [Pool Index]) - (with-expansions [ (as-is (index.index (n/+ offset idx))) - (as-is (recur (.inc idx)))] - (loop [idx 0] - (case (row.nth idx pool) - (#.Some entry) - (case entry - (#//.UTF8 reference) - (if (text/= reference value) - [pool - ] +(template: (!add <=>) + (function (_ pool) + (with-expansions [ (as-is (index.index (encoding.to-u2 (n/+ offset idx)))) + (as-is (recur (.inc idx)))] + (loop [idx 0] + (case (row.nth idx pool) + (#.Some entry) + (case entry + ( reference) + (if (<=> reference ) + [pool + ] + ) + + _ ) - _ - ) - - #.None - [(row.add (#//.UTF8 value) pool) - ])))) + #.None + [(row.add ( ) pool) + ]))))) -(def: (class' value pool) - (-> Index Pool [Pool Index]) - (with-expansions [ (as-is (index.index (n/+ offset idx))) - (as-is (recur (.inc idx)))] - (loop [idx 0] - (case (row.nth idx pool) - (#.Some entry) - (case entry - (#//.Class reference) - (if (u2/= reference value) - [pool - ] - ) - - _ - ) - - #.None - [(row.add (#//.Class value) pool) - ])))) +(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 + [@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 + (All [kind] (Equivalence (Index kind))) + (:: equivalence.Contravariant map-1 + (|>> :representation) + //encoding.Equivalence)) + + (def: #export format + (All [kind] (Format (Index kind))) + (binary.adapt (|>> :abstraction) + (|>> :representation) + //encoding.u2-format)) + ) -- cgit v1.2.3