diff options
Diffstat (limited to '')
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}) |