aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/tool/compiler/default/platform.lux3
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/generation.lux42
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux7
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux8
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm.lux2
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux16
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux12
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux12
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux2
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux2
-rw-r--r--stdlib/source/lux/tool/compiler/meta/archive.lux85
-rw-r--r--stdlib/source/lux/tool/compiler/meta/archive/artifact.lux16
-rw-r--r--stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux6
13 files changed, 146 insertions, 67 deletions
diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux
index f51711289..fa519d8a2 100644
--- a/stdlib/source/lux/tool/compiler/default/platform.lux
+++ b/stdlib/source/lux/tool/compiler/default/platform.lux
@@ -182,7 +182,8 @@
(Promise (Try [Archive <State+>])))
recur})]
(do (try.with promise.monad)
- [input (context.read (get@ #&file-system platform)
+ [[_module-id archive] (promise@wrap (archive.reserve module archive))
+ input (context.read (get@ #&file-system platform)
(get@ #cli.sources configuration)
partial-host-extension
module)]
diff --git a/stdlib/source/lux/tool/compiler/language/lux/generation.lux b/stdlib/source/lux/tool/compiler/language/lux/generation.lux
index 84f4f35d4..aedb38f61 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/generation.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/generation.lux
@@ -11,6 +11,8 @@
["." name ("#@." equivalence)]
["." text ("#@." equivalence)
["%" format (#+ format)]]
+ [number
+ ["n" nat]]
[collection
["." row (#+ Row)]
["." list ("#@." functor)]]]]
@@ -25,6 +27,9 @@
["." descriptor (#+ Module)]
["." artifact]]]]])
+(type: #export Context [archive.ID artifact.ID])
+(type: #export (Buffer directive) (Row [Name directive]))
+
(exception: #export (cannot-interpret {error Text})
(exception.report
["Error" error]))
@@ -43,12 +48,9 @@
evaluate!)
(: (-> Text directive (Try Any))
execute!)
- (: (-> Module artifact.ID expression (Try [Text Any directive]))
+ (: (-> Context expression (Try [Text Any directive]))
define!))
-(type: #export (Buffer directive) (Row [Name directive]))
-(type: #export Context [Module artifact.ID])
-
(type: #export (State anchor expression directive)
{#module Module
#anchor (Maybe anchor)
@@ -168,11 +170,11 @@
[execute! directive]
)
-(def: #export (define! module id code)
+(def: #export (define! context code)
(All [anchor expression directive]
- (-> Module artifact.ID expression (Operation anchor expression directive [Text Any directive])))
+ (-> Context expression (Operation anchor expression directive [Text Any directive])))
(function (_ (^@ stateE [bundle state]))
- (case (:: (get@ #host state) define! module id code)
+ (case (:: (get@ #host state) define! context code)
(#try.Success output)
(#try.Success [stateE output])
@@ -192,11 +194,11 @@
(case ?buffer
(#.Some buffer)
(if (row.any? (|>> product.left (name@= name)) buffer)
- (phase.throw ..cannot-overwrite-output name)
+ (phase.throw ..cannot-overwrite-output [name])
(extension.update (set@ #buffer (#.Some (row.add [name code] buffer)))))
#.None
- (phase.throw ..no-buffer-for-saving-code name))))
+ (phase.throw ..no-buffer-for-saving-code [name]))))
(def: #export (learn name)
(All [anchor expression directive]
@@ -219,7 +221,8 @@
(function (_ (^@ stateE [bundle state]))
(let [[_module _name] name]
(do try.monad
- [registry (if (text@= (get@ #module state) _module)
+ [module-id (archive.id _module archive)
+ registry (if (text@= (get@ #module state) _module)
(#try.Success (get@ #registry state))
(do try.monad
[[descriptor document] (archive.find _module archive)]
@@ -229,20 +232,22 @@
(exception.throw ..unknown-definition [name (artifact.definitions registry)])
(#.Some id)
- (#try.Success [stateE [_module id]]))))))
+ (#try.Success [stateE [module-id id]]))))))
(exception: #export no-context)
-(def: #export context
+(def: #export (context archive)
(All [anchor expression directive]
- (Operation anchor expression directive Context))
+ (-> Archive (Operation anchor expression directive Context)))
(function (_ (^@ stateE [bundle state]))
(case (get@ #context state)
#.None
(exception.throw ..no-context [])
(#.Some id)
- (#try.Success [stateE [(get@ #module state) id]]))))
+ (do try.monad
+ [module-id (archive.id (get@ #module state) archive)]
+ (wrap [stateE [module-id id]])))))
(def: #export (with-context id body)
(All [anchor expression directive a]
@@ -255,16 +260,17 @@
(wrap [[bundle' (set@ #context (get@ #context state) state')]
output]))))
-(def: #export (with-new-context body)
+(def: #export (with-new-context archive body)
(All [anchor expression directive a]
- (-> (Operation anchor expression directive a)
+ (-> Archive (Operation anchor expression directive a)
(Operation anchor expression directive [Context a])))
(function (_ (^@ stateE [bundle state]))
(let [[id registry'] (artifact.resource (get@ #registry state))]
(do try.monad
[[[bundle' state'] output] (body [bundle (|> state
(set@ #registry registry')
- (set@ #context (#.Some id)))])]
+ (set@ #context (#.Some id)))])
+ module-id (archive.id (get@ #module state) archive)]
(wrap [[bundle' (set@ #context (get@ #context state) state')]
- [[(get@ #module state) id]
+ [[module-id id]
output]])))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux
index efceba1d9..d8cba75ff 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux
@@ -36,7 +36,7 @@
[///
["." phase]
[meta
- [archive (#+ Archive)]]]]]])
+ ["." archive (#+ Archive)]]]]]])
(def: #export (custom [syntax handler])
(All [anchor expression directive s]
@@ -100,8 +100,9 @@
(do phase.monad
[codeG (generate archive codeS)
id (/////generation.learn name)
- [target-name value directive] (/////generation.define! module id codeG)
- _ (/////generation.save! false [module name] directive)]
+ module-id (phase.lift (archive.id module archive))
+ [target-name value directive] (/////generation.define! [module-id id] codeG)
+ _ (/////generation.save! false [(%.nat module-id) (%.nat id)] directive)]
(wrap [code//type codeG target-name value]))))
(def: (definition archive name expected codeC)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux
index 3a7691134..266985b68 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux
@@ -64,7 +64,7 @@
["#" phase]
["#." reference (#+ Variable)]
[meta
- [archive (#+ Archive)]]]]]])
+ ["." archive (#+ Archive)]]]]]])
(template [<name> <0> <1>]
[(def: <name>
@@ -943,10 +943,10 @@
store-capturedG
_.return)))))
-(def: (anonymous-instance class env)
- (-> (Type category.Class) Environment (Operation (Bytecode Any)))
+(def: (anonymous-instance archive class env)
+ (-> Archive (Type category.Class) Environment (Operation (Bytecode Any)))
(do //////.monad
- [captureG+ (monad.map @ ///reference.variable env)]
+ [captureG+ (monad.map @ (///reference.variable archive) env)]
(wrap ($_ _.compose
(_.new class)
_.dup
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm.lux
index 38fd9fec8..b552f16d5 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm.lux
@@ -39,7 +39,7 @@
(#synthesis.Reference reference)
(case reference
(#reference.Variable variable)
- (/reference.variable variable)
+ (/reference.variable archive variable)
(#reference.Constant constant)
(/reference.constant archive constant))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux
index 891d74f71..7694b6b34 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux
@@ -26,7 +26,11 @@
[pool (#+ Resource)]]
[encoding
["." name (#+ External Internal)]
- ["." unsigned]]]]]
+ ["." unsigned]]]]
+ [tool
+ [compiler
+ [meta
+ ["." archive (#+ Archive)]]]]]
["." / #_
["#." abstract]
[field
@@ -52,8 +56,8 @@
["." arity (#+ Arity)]
["." phase]]]]])
-(def: #export (with @begin class environment arity body)
- (-> Label External Environment Arity (Bytecode Any)
+(def: #export (with archive @begin class environment arity body)
+ (-> Archive Label External Environment Arity (Bytecode Any)
(Operation [(List (Resource Field))
(List (Resource Method))
(Bytecode Any)]))
@@ -72,7 +76,7 @@
(list& (/implementation.method arity @begin body)))
(list (/implementation.method' //runtime.apply::name arity @begin body)))))]
(do phase.monad
- [instance (/new.instance classT environment arity)]
+ [instance (/new.instance archive classT environment arity)]
(wrap [fields methods instance]))))
(def: modifier
@@ -93,11 +97,11 @@
(Generator Abstraction)
(do phase.monad
[@begin //runtime.forge-label
- [function-context bodyG] (generation.with-new-context
+ [function-context bodyG] (generation.with-new-context archive
(generation.with-anchor [@begin ..this-offset]
(generate archive bodyS)))
#let [function-class (//runtime.class-name function-context)]
- [fields methods instance] (..with @begin function-class environment arity bodyG)
+ [fields methods instance] (..with archive @begin function-class environment arity bodyG)
class (phase.lift (class.class version.v6_0
..modifier
(name.internal function-class)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux
index a307650dd..991745ff0 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux
@@ -16,7 +16,11 @@
["." constant
[pool (#+ Resource)]]
[type (#+ Type)
- ["." category (#+ Class Value Return)]]]]]
+ ["." category (#+ Class Value Return)]]]]
+ [tool
+ [compiler
+ [meta
+ ["." archive (#+ Archive)]]]]]
["." //
["#." init]
["#." implementation]
@@ -46,10 +50,10 @@
(///partial.new arity)
(_.invokespecial class //init.name (//init.type environment arity))))
-(def: #export (instance class environment arity)
- (-> (Type Class) Environment Arity (Operation (Bytecode Any)))
+(def: #export (instance archive class environment arity)
+ (-> Archive (Type Class) Environment Arity (Operation (Bytecode Any)))
(do phase.monad
- [foreign* (monad.map @ ////reference.variable environment)]
+ [foreign* (monad.map @ (////reference.variable archive) environment)]
(wrap (instance' foreign* class environment arity))))
(def: #export (method class environment arity)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux
index 913b28793..d60f9a8b3 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux
@@ -37,25 +37,25 @@
[partial-name "p"]
)
-(def: (foreign variable)
- (-> Register (Operation (Bytecode Any)))
+(def: (foreign archive variable)
+ (-> Archive Register (Operation (Bytecode Any)))
(do ////.monad
[bytecode-name (:: @ map //runtime.class-name
- generation.context)]
+ (generation.context archive))]
(wrap ($_ _.compose
..this
(_.getfield (type.class bytecode-name (list))
(..foreign-name variable)
//type.value)))))
-(def: #export (variable variable)
- (-> Variable (Operation (Bytecode Any)))
+(def: #export (variable archive variable)
+ (-> Archive Variable (Operation (Bytecode Any)))
(case variable
(#reference.Local variable)
(operation@wrap (_.aload variable))
(#reference.Foreign variable)
- (..foreign variable)))
+ (..foreign archive variable)))
(def: #export (constant archive name)
(-> Archive Name (Operation (Bytecode Any)))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux
index 14df69e42..54c2f615a 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux
@@ -80,7 +80,7 @@
(def: #export (class-name [module id])
(-> generation.Context Text)
- (format ..prefix module "/" (%.nat id)))
+ (format ..prefix (%.nat module) "/" (%.nat id)))
(def: #export class (type.class "LuxRuntime" (list)))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux
index 86fb57f0a..84efa7c50 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux
@@ -57,7 +57,7 @@
(def: #export (artifact-name [module id])
(-> Context Text)
- (format "lux_" "m" module "a" (%.nat id)))
+ (format "lux_" "m" (%.nat module) "a" (%.nat id)))
(def: #export (system constant variable)
(All [expression]
diff --git a/stdlib/source/lux/tool/compiler/meta/archive.lux b/stdlib/source/lux/tool/compiler/meta/archive.lux
index edab30124..6db7cc0bb 100644
--- a/stdlib/source/lux/tool/compiler/meta/archive.lux
+++ b/stdlib/source/lux/tool/compiler/meta/archive.lux
@@ -8,9 +8,11 @@
["." exception (#+ exception:)]
["." function]]
[data
+ ["." product]
["." name]
["." text]
[collection
+ ["." list]
["." dictionary (#+ Dictionary)]]]
[type
abstract]
@@ -36,34 +38,83 @@
["Old key" (signature.description (document.signature old))]
["New key" (signature.description (document.signature new))]))
+(exception: #export (module-has-already-been-reserved {module Module})
+ (exception.report
+ ["Module" module]))
+
+(exception: #export (module-must-be-reserved-before-it-can-be-added {module Module})
+ (exception.report
+ ["Module" module]))
+
+(exception: #export (module-is-only-reserved {module Module})
+ (exception.report
+ ["Module" module]))
+
+(type: #export ID Nat)
+
(abstract: #export Archive
{}
- (Dictionary Module [Descriptor (Document Any)])
+ (Dictionary Module [ID (Maybe [Descriptor (Document Any)])])
(def: #export empty
Archive
(:abstraction (dictionary.new text.hash)))
+ (def: next
+ (-> Archive ID)
+ (|>> :representation dictionary.size))
+
+ (def: #export (id module archive)
+ (-> Module Archive (Try ID))
+ (case (dictionary.get module (:representation archive))
+ (#.Some [id _])
+ (#try.Success id)
+
+ #.None
+ (exception.throw ..unknown-document [module
+ (dictionary.keys (:representation archive))])))
+
+ (def: #export (reserve module archive)
+ (-> Module Archive (Try [ID Archive]))
+ (case (dictionary.get module (:representation archive))
+ (#.Some _)
+ (exception.throw ..module-has-already-been-reserved [module])
+
+ #.None
+ (let [id (..next archive)]
+ (#try.Success [id
+ (|> archive
+ :representation
+ (dictionary.put module [id #.None])
+ :abstraction)]))))
+
(def: #export (add module [descriptor document] archive)
(-> Module [Descriptor (Document Any)] Archive (Try Archive))
(case (dictionary.get module (:representation archive))
- (#.Some [existing-descriptor existing-document])
+ (#.Some [id #.None])
+ (#try.Success (|> archive
+ :representation
+ (dictionary.put module [id (#.Some [descriptor document])])
+ :abstraction))
+
+ (#.Some [id (#.Some [existing-descriptor existing-document])])
(if (is? document existing-document)
+ ## TODO: Find out why this code allows for the same module to be added more than once. It looks fishy...
(#try.Success archive)
- (exception.throw cannot-replace-document [module existing-document document]))
+ (exception.throw ..cannot-replace-document [module existing-document document]))
#.None
- (#try.Success (|> archive
- :representation
- (dictionary.put module [descriptor document])
- :abstraction))))
+ (exception.throw ..module-must-be-reserved-before-it-can-be-added [module])))
(def: #export (find module archive)
(-> Module Archive (Try [Descriptor (Document Any)]))
(case (dictionary.get module (:representation archive))
- (#.Some document)
+ (#.Some [id (#.Some document)])
(#try.Success document)
+
+ (#.Some [id #.None])
+ (exception.throw ..module-is-only-reserved [module])
#.None
(exception.throw ..unknown-document [module
@@ -80,13 +131,25 @@
(def: #export archived
(-> Archive (List Module))
- (|>> :representation dictionary.keys))
+ (|>> :representation
+ dictionary.entries
+ (list.search-all (function (_ [module [id descriptor+document]])
+ (case descriptor+document
+ (#.Some _) (#.Some module)
+ #.None #.None)))))
(def: #export (merge additions archive)
(-> Archive Archive (Try Archive))
(monad.fold try.monad
- (function (_ [module' descriptor+document'] archive')
- (..add module' descriptor+document' archive'))
+ (function (_ [module' [id descriptor+document']] archive')
+ (case descriptor+document'
+ (#.Some descriptor+document')
+ (if (archived? archive' module')
+ (#try.Success archive')
+ (..add module' descriptor+document' archive'))
+
+ #.None
+ (#try.Success archive')))
archive
(dictionary.entries (:representation additions))))
)
diff --git a/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux b/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux
index 256c10a22..2d4559275 100644
--- a/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux
+++ b/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux
@@ -17,34 +17,34 @@
(abstract: #export Registry
{}
- {#next ID
- #artifacts (Row Artifact)
+ {#artifacts (Row Artifact)
#resolver (Dictionary Text ID)}
(def: #export empty
Registry
- (:abstraction {#next 0
- #artifacts row.empty
+ (:abstraction {#artifacts row.empty
#resolver (dictionary.new text.hash)}))
+ (def: next
+ (-> Registry ID)
+ (|>> :representation (get@ #artifacts) row.size))
+
(def: #export (resource registry)
(-> Registry [ID Registry])
- (let [id (get@ #next (:representation registry))]
+ (let [id (..next registry)]
[id
(|> registry
:representation
- (update@ #next inc)
(update@ #artifacts (row.add {#id id
#name #.None}))
:abstraction)]))
(def: #export (definition name registry)
(-> Text Registry [ID Registry])
- (let [id (get@ #next (:representation registry))]
+ (let [id (..next registry)]
[id
(|> registry
:representation
- (update@ #next inc)
(update@ #artifacts (row.add {#id id
#name (#.Some name)}))
(update@ #resolver (dictionary.put name id))
diff --git a/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux b/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux
index 4582ab702..c6e1e7841 100644
--- a/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux
+++ b/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux
@@ -11,9 +11,9 @@
(type: #export Module Text)
(type: #export Descriptor
- {#hash Nat
- #name Module
+ {#name Module
#file Path
- #references (Set Module)
+ #hash Nat
#state Module-State
+ #references (Set Module)
#registry Registry})