diff options
author | Eduardo Julian | 2018-01-08 21:40:06 -0400 |
---|---|---|
committer | Eduardo Julian | 2018-01-08 21:40:06 -0400 |
commit | 9eaaaf953ba7ce1eeb805603f4e113aa15f5178f (patch) | |
tree | ef134eecc8a5767a997fce0637cd64e0ebcee6b1 /new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux | |
parent | f523bc14d43286348aeb200bd0554812dc6ef28d (diff) |
- Moved all translation code under the JVM path (in preparation for porting the JS back-end).
Diffstat (limited to 'new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux')
-rw-r--r-- | new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux | 136 |
1 files changed, 136 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux new file mode 100644 index 000000000..a4eb5b93b --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux @@ -0,0 +1,136 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + [io] + (concurrency [atom #+ Atom atom]) + (data ["e" error #+ Error] + [text "text/" Hash<Text>] + text/format + (coll [dict #+ Dict])) + [macro] + [host] + (world [blob #+ Blob] + [file #+ File])) + (luxc [lang] + (lang [".L" variable #+ Register] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst]))))) + +(host.import org/objectweb/asm/Opcodes + (#static V1_6 int)) + +(host.import org/objectweb/asm/Label) + +(host.import java/lang/Object) + +(host.import java/lang/reflect/Field + (get [#? Object] #try #? Object)) + +(host.import (java/lang/Class c) + (getField [String] #try Field)) + +(host.import java/lang/ClassLoader + (loadClass [String] (Class Object))) + +(type: #export Bytecode Blob) + +(type: #export Class-Store (Atom (Dict Text Bytecode))) + +(type: #export Artifacts (Dict File Blob)) + +(type: #export Host + {#loader ClassLoader + #store Class-Store + #artifacts Artifacts + #context [Text Nat] + #anchor (Maybe [Label Register])}) + +(exception: #export Unknown-Class) +(exception: #export Class-Already-Stored) +(exception: #export No-Function-Being-Compiled) +(exception: #export Cannot-Overwrite-Artifact) +(exception: #export Cannot-Load-Definition) +(exception: #export Invalid-Definition-Value) + +(def: #export (with-artifacts action) + (All [a] (-> (Meta a) (Meta [Artifacts a]))) + (function [compiler] + (case (action (update@ #.host + (|>> (:! Host) + (set@ #artifacts (dict.new text.Hash<Text>)) + (:! Void)) + compiler)) + (#e.Success [compiler' output]) + (#e.Success [(update@ #.host + (|>> (:! Host) + (set@ #artifacts (|> (get@ #.host compiler) (:! Host) (get@ #artifacts))) + (:! Void)) + compiler') + [(|> compiler' (get@ #.host) (:! Host) (get@ #artifacts)) + output]]) + + (#e.Error error) + (#e.Error error)))) + +(def: #export (record-artifact name content) + (-> Text Blob (Meta Unit)) + (function [compiler] + (if (|> compiler (get@ #.host) (:! Host) (get@ #artifacts) (dict.contains? name)) + (ex.throw Cannot-Overwrite-Artifact name) + (#e.Success [(update@ #.host + (|>> (:! Host) + (update@ #artifacts (dict.put name content)) + (:! Void)) + compiler) + []])))) + +(def: #export (store-class name byte-code) + (-> Text Bytecode (Meta Unit)) + (function [compiler] + (let [store (|> (get@ #.host compiler) + (:! Host) + (get@ #store))] + (if (dict.contains? name (|> store atom.read io.run)) + (ex.throw Class-Already-Stored name) + (#e.Success [compiler (io.run (atom.update (dict.put name byte-code) store))]) + )))) + +(def: #export (load-class name) + (-> Text (Meta (Class Object))) + (function [compiler] + (let [host (:! Host (get@ #.host compiler)) + store (|> host (get@ #store) atom.read io.run)] + (if (dict.contains? name store) + (#e.Success [compiler (ClassLoader::loadClass [name] (get@ #loader host))]) + (ex.throw Unknown-Class name))))) + +(def: #export value-field Text "_value") +(def: #export $Object $.Type ($t.class "java.lang.Object" (list))) + +(def: #export (load-definition compiler) + (-> Compiler + (-> Ident Blob (Error Top))) + (function [(^@ def-ident [def-module def-name]) def-bytecode] + (let [normal-name (format (lang.normalize-name def-name) (%n (text/hash def-name))) + class-name (format (text.replace-all "/" "." def-module) "." normal-name)] + (<| (macro.run compiler) + (do macro.Monad<Meta> + [_ (..store-class class-name def-bytecode) + class (..load-class class-name)] + (case (do e.Monad<Error> + [field (Class::getField [..value-field] class)] + (Field::get [#.None] field)) + (#e.Success (#.Some def-value)) + (wrap def-value) + + (#e.Success #.None) + (lang.throw Invalid-Definition-Value (%ident def-ident)) + + (#e.Error error) + (lang.throw Cannot-Load-Definition + (format "Definition: " (%ident def-ident) "\n" + "Error:\n" + error)))))))) |