From 8b4f0ded7bddaa42cf432f74523bfd6aa1e76fed Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 18 Jul 2018 23:44:29 -0400 Subject: WIP: Fix new-luxc's JVM back-end. --- .../luxc/lang/translation/jvm/common.jvm.lux | 207 +++++++-------------- 1 file changed, 69 insertions(+), 138 deletions(-) (limited to 'new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux') diff --git a/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux index 2dab7b6ac..b01a68c3d 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux @@ -1,141 +1,72 @@ (.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:]) - [io] - (concurrency [atom #+ Atom atom]) - (data ["e" error #+ Error] - [text "text/" Hash] - text/format - (coll (dictionary ["dict" unordered #+ Dict]))) - [macro] - [host] - (world [blob #+ Blob] - [file #+ File]) - ["//" lang] - (lang ["//." reference #+ Register])) - (luxc [lang] - (lang (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 - {#context [Text Nat] - #anchor (Maybe [Label Register]) - #loader ClassLoader - #store Class-Store - #artifacts Artifacts}) - -(do-template [] - [(exception: #export ( {message Text}) - message)] - - [Unknown-Class] - [Class-Already-Stored] - [No-Function-Being-Compiled] - [Cannot-Overwrite-Artifact] - [Cannot-Load-Definition] - [Invalid-Definition-Value] + [lux #* + [control + [monad (#+ do)] + ["ex" exception (#+ exception:)]] + [io] + [concurrency + [atom (#+ Atom atom)]] + [data + [error (#+ Error)] + [text ("text/" Hash) + format] + [collection + [dictionary (#+ Dictionary)]]] + [macro] + [host (#+ import:)] + [world + [blob (#+ Blob)]] + [language + [name] + [reference (#+ Register)] + ["." compiler]]] + ## [luxc + ## [lang + ## [host + ## ["." jvm + ## [type]]]]] ) -(def: #export (with-artifacts action) - (All [a] (-> (Meta a) (Meta [Artifacts a]))) - (function (_ compiler) - (case (action (update@ #.host - (|>> (:coerce Host) - (set@ #artifacts (dict.new text.Hash)) - (:coerce Nothing)) - compiler)) - (#e.Success [compiler' output]) - (#e.Success [(update@ #.host - (|>> (:coerce Host) - (set@ #artifacts (|> (get@ #.host compiler) (:coerce Host) (get@ #artifacts))) - (:coerce Nothing)) - compiler') - [(|> compiler' (get@ #.host) (:coerce Host) (get@ #artifacts)) - output]]) - - (#e.Error error) - (#e.Error error)))) - -(def: #export (record-artifact name content) - (-> Text Blob (Meta Any)) - (function (_ compiler) - (if (|> compiler (get@ #.host) (:coerce Host) (get@ #artifacts) (dict.contains? name)) - (ex.throw Cannot-Overwrite-Artifact name) - (#e.Success [(update@ #.host - (|>> (:coerce Host) - (update@ #artifacts (dict.put name content)) - (:coerce Nothing)) - compiler) - []])))) - -(def: #export (store-class name byte-code) - (-> Text Bytecode (Meta Any)) - (function (_ compiler) - (let [store (|> (get@ #.host compiler) - (:coerce Host) - (get@ #store))] - (if (dict.contains? name (|> store atom.read io.run)) - (ex.throw Class-Already-Stored name) - (exec (io.run (atom.update (dict.put name byte-code) store)) - (#e.Success [compiler []])))))) - -(def: #export (load-class name) - (-> Text (Meta (Class Object))) - (function (_ compiler) - (let [host (:coerce 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) - (-> Lux (-> Ident Blob (Error Any))) - (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 - [_ (..store-class class-name def-bytecode) - class (..load-class class-name)] - (case (do e.Monad - [field (Class::getField [..value-field] class)] - (Field::get [#.None] field)) - (#e.Success (#.Some def-value)) - (wrap def-value) - - (#e.Success #.None) - (//.throw Invalid-Definition-Value (%ident def-ident)) - - (#e.Error error) - (//.throw Cannot-Load-Definition - (format "Definition: " (%ident def-ident) "\n" - "Error:\n" - error)))))))) +## (def: #export (with-artifacts action) +## (All [a] (-> (Meta a) (Meta [Artifacts a]))) +## (function (_ compiler) +## (case (action (update@ #.host +## (|>> (:coerce Host) +## (set@ #artifacts (dictionary.new text.Hash)) +## (:coerce Nothing)) +## compiler)) +## (#error.Success [compiler' output]) +## (#error.Success [(update@ #.host +## (|>> (:coerce Host) +## (set@ #artifacts (|> (get@ #.host compiler) (:coerce Host) (get@ #artifacts))) +## (:coerce Nothing)) +## compiler') +## [(|> compiler' (get@ #.host) (:coerce Host) (get@ #artifacts)) +## output]]) + +## (#error.Error error) +## (#error.Error error)))) + +## (def: #export (load-definition compiler) +## (-> Lux (-> Ident Blob (Error Any))) +## (function (_ (^@ def-ident [def-module def-name]) def-bytecode) +## (let [normal-name (format (name.normalize def-name) (%n (text/hash def-name))) +## class-name (format (text.replace-all "/" "." def-module) "." normal-name)] +## (<| (macro.run compiler) +## (do macro.Monad +## [_ (..store-class class-name def-bytecode) +## class (..load-class class-name)] +## (case (do error.Monad +## [field (Class::getField [..value-field] class)] +## (Field::get [#.None] field)) +## (#error.Success (#.Some def-value)) +## (wrap def-value) + +## (#error.Success #.None) +## (compiler.throw invalid-definition-value (%ident def-ident)) + +## (#error.Error error) +## (compiler.throw cannot-load-definition +## (format "Definition: " (%ident def-ident) "\n" +## "Error:\n" +## error)))))))) -- cgit v1.2.3