diff options
Diffstat (limited to 'new-luxc')
| -rw-r--r-- | new-luxc/source/luxc/lang/directive/jvm.lux | 263 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/packager.lux | 112 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/jvm.lux | 154 | ||||
| -rw-r--r-- | new-luxc/source/program.lux | 112 |
4 files changed, 20 insertions, 621 deletions
diff --git a/new-luxc/source/luxc/lang/directive/jvm.lux b/new-luxc/source/luxc/lang/directive/jvm.lux deleted file mode 100644 index 5c1ddee0d..000000000 --- a/new-luxc/source/luxc/lang/directive/jvm.lux +++ /dev/null @@ -1,263 +0,0 @@ -(.module: - [lux (#- Type Definition) - [abstract - ["." monad (#+ do)]] - [control - ["<>" parser - ["<c>" code (#+ Parser)] - ["<t>" text]]] - [data - ["." product] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#@." functor fold)] - ["." dictionary]]] - [type - ["." check (#+ Check)]] - [target - [jvm - ["." type (#+ Type Constraint Argument Typed) - [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)] - [".T" lux] - ["." signature] - ["." descriptor (#+ Descriptor)] - ["." parser]]]] - [tool - [compiler - ["." directive (#+ Handler Bundle)] - ["." phase - ["." generation] - [analysis - [".A" type]] - ["." extension - ["." bundle] - [analysis - ["." jvm]] - [directive - ["/" lux]]]]]]] - [luxc - [lang - [host - ["$" jvm (#+ Anchor Inst Definition Operation Phase) - ["_." def]]]]]) - -(def: signature (|>> type.signature signature.signature)) - -(type: Declaration - [Text (List (Type Var))]) - -(def: declaration - (Parser Declaration) - (<c>.form (<>.and <c>.text (<>.some jvm.var)))) - -(type: Inheritance - #FinalI - #AbstractI - #DefaultI) - -(def: inheritance - (Parser Inheritance) - ($_ <>.or - (<c>.text! "final") - (<c>.text! "abstract") - (<c>.text! "default"))) - -(type: State - #VolatileS - #FinalS - #DefaultS) - -(def: state - (Parser State) - ($_ <>.or - (<c>.text! "volatile") - (<c>.text! "final") - (<c>.text! "default"))) - -(type: Annotation Any) - -(def: annotation - (Parser Annotation) - <c>.any) - -(def: field-type - (Parser (Type Value)) - (<t>.embed parser.value <c>.text)) - -(type: Constant - [Text (List Annotation) (Type Value) Code]) - -(def: constant - (Parser Constant) - (<| <c>.form - (<>.after (<c>.text! "constant")) - ($_ <>.and - <c>.text - (<c>.tuple (<>.some ..annotation)) - ..field-type - <c>.any - ))) - -(type: Variable - [Text jvm.Visibility State (List Annotation) (Type Value)]) - -(def: variable - (Parser Variable) - (<| <c>.form - (<>.after (<c>.text! "variable")) - ($_ <>.and - <c>.text - jvm.visibility - ..state - (<c>.tuple (<>.some ..annotation)) - ..field-type - ))) - -(type: Field - (#Constant Constant) - (#Variable Variable)) - -(def: field - (Parser Field) - ($_ <>.or - ..constant - ..variable - )) - -(type: Method-Definition - (#Constructor (jvm.Constructor Code)) - (#Virtual-Method (jvm.Virtual-Method Code)) - (#Static-Method (jvm.Static-Method Code)) - (#Overriden-Method (jvm.Overriden-Method Code))) - -(def: method - (Parser Method-Definition) - ($_ <>.or - jvm.constructor-definition - jvm.virtual-method-definition - jvm.static-method-definition - jvm.overriden-method-definition - )) - -(def: (constraint name) - (-> Text Constraint) - {#type.name name - #type.super-class (type.class "java.lang.Object" (list)) - #type.super-interfaces (list)}) - -(def: jvm::class - (Handler Anchor Inst Definition) - (/.custom - [($_ <>.and - ..declaration - jvm.class - (<c>.tuple (<>.some jvm.class)) - ..inheritance - (<c>.tuple (<>.some ..annotation)) - (<c>.tuple (<>.some ..field)) - (<c>.tuple (<>.some ..method))) - (function (_ extension phase - [[name parameters] - super-class - super-interfaces - inheritance - ## TODO: Handle annotations. - annotations - fields - methods]) - (do phase.monad - [parameters (directive.lift-analysis - (typeA.with-env - (jvm.parameter-types parameters))) - #let [mapping (list@fold (function (_ [parameterJ parameterT] mapping) - (dictionary.put (parser.name parameterJ) parameterT mapping)) - luxT.fresh - parameters) - field-definitions (|> fields - (list@map (function (_ field) - (case field - ## TODO: Handle annotations. - (#Constant [name annotations type value]) - (case value - (^template [<tag> <field>] - [_ (<tag> value)] - (<field> #$.Public ($.++F $.staticF $.finalF) name value)) - ([#.Bit _def.boolean-field] - [#.Int _def.byte-field] - [#.Int _def.short-field] - [#.Int _def.int-field] - [#.Int _def.long-field] - [#.Frac _def.float-field] - [#.Frac _def.double-field] - [#.Nat _def.char-field] - [#.Text _def.string-field]) - - _ - (undefined)) - - ## TODO: Handle annotations. - (#Variable [name visibility state annotations type]) - (_def.field visibility - (case state - ## TODO: Handle transient & static. - #VolatileS $.volatileF - #FinalS $.finalF - #DefaultS $.noneF) - name - type)))) - _def.fuse)] - super-classT (directive.lift-analysis - (typeA.with-env - (luxT.check (luxT.class mapping) (..signature super-class)))) - super-interfaceT+ (directive.lift-analysis - (typeA.with-env - (monad.map check.monad - (|>> ..signature (luxT.check (luxT.class mapping))) - super-interfaces))) - #let [selfT (jvm.inheritance-relationship-type (#.Primitive name (list@map product.right parameters)) - super-classT - super-interfaceT+)] - state (extension.lift phase.get-state) - #let [analyse (get@ [#directive.analysis #directive.phase] state) - synthesize (get@ [#directive.synthesis #directive.phase] state) - generate (get@ [#directive.generation #directive.phase] state)] - methods (monad.map @ (function (_ methodC) - (do @ - [methodA (directive.lift-analysis - (case methodC - (#Constructor method) - (jvm.analyse-constructor-method analyse selfT mapping method) - - (#Virtual-Method method) - (jvm.analyse-virtual-method analyse selfT mapping method) - - (#Static-Method method) - (jvm.analyse-static-method analyse mapping method) - - (#Overriden-Method method) - (jvm.analyse-overriden-method analyse selfT mapping method)))] - (directive.lift-synthesis - (synthesize methodA)))) - methods) - _ (directive.lift-generation - (generation.save! true ["" name] - [name - (_def.class #$.V1_6 #$.Public - (case inheritance - #FinalI $.finalC - ## TODO: Handle abstract classes. - #AbstractI (undefined) - #DefaultI $.noneC) - name (list@map (|>> product.left parser.name ..constraint) parameters) - super-class super-interfaces - field-definitions)])) - #let [_ (log! (format "Class " name))]] - (wrap directive.no-requirements)))])) - -(def: #export bundle - (Bundle Anchor Inst Definition) - (<| (bundle.prefix "jvm") - (|> bundle.empty - (dictionary.put "class" jvm::class) - ))) diff --git a/new-luxc/source/luxc/lang/packager.lux b/new-luxc/source/luxc/lang/packager.lux deleted file mode 100644 index d72506da2..000000000 --- a/new-luxc/source/luxc/lang/packager.lux +++ /dev/null @@ -1,112 +0,0 @@ -(.module: - [lux #* - ["." host (#+ import: do-to)] - [data - ["." binary (#+ Binary)] - ["." text] - [number - ["n" nat]] - [collection - ["." row] - ["." list ("#@." fold)]]] - [target - [jvm - [encoding - ["." name (#+ External)]]]] - [tool - [compiler - [phase - [generation (#+ Buffer Output)]] - [meta - [archive - [descriptor (#+ Module)]]]]]] - [// - [host - [jvm (#+ Definition)]]]) - -(import: #long java/lang/Object) - -(import: #long java/lang/String) - -(import: #long java/util/jar/Attributes - (put [java/lang/Object java/lang/Object] #? java/lang/Object)) - -(import: #long java/util/jar/Attributes$Name - (#static MAIN_CLASS java/util/jar/Attributes$Name) - (#static MANIFEST_VERSION java/util/jar/Attributes$Name)) - -(import: #long java/util/jar/Manifest - (new []) - (getMainAttributes [] java/util/jar/Attributes)) - -(import: #long java/io/Flushable - (flush [] void)) - -(import: #long java/io/Closeable - (close [] void)) - -(import: #long java/io/OutputStream) - -(import: #long java/io/ByteArrayOutputStream - (new [int]) - (toByteArray [] [byte])) - -(import: #long java/util/zip/ZipEntry) - -(import: #long java/util/zip/ZipOutputStream - (write [[byte] int int] void) - (closeEntry [] void)) - -(import: #long java/util/jar/JarEntry - (new [java/lang/String])) - -(import: #long java/util/jar/JarOutputStream - (new [java/io/OutputStream java/util/jar/Manifest]) - (putNextEntry [java/util/zip/ZipEntry] void)) - -(def: byte 1) -## https://en.wikipedia.org/wiki/Kibibyte -(def: kibi-byte (n.* 1,024 byte)) -## https://en.wikipedia.org/wiki/Mebibyte -(def: mebi-byte (n.* 1,024 kibi-byte)) - -(def: manifest-version "1.0") - -(def: class-name - (-> Text Text) - (text.suffix ".class")) - -(def: (manifest program-class) - (-> External java/util/jar/Manifest) - (let [manifest (java/util/jar/Manifest::new)] - (exec (do-to (java/util/jar/Manifest::getMainAttributes manifest) - (java/util/jar/Attributes::put (java/util/jar/Attributes$Name::MAIN_CLASS) program-class) - (java/util/jar/Attributes::put (java/util/jar/Attributes$Name::MANIFEST_VERSION) ..manifest-version)) - manifest))) - -(def: (write-class [def-name [class-name bytecode]] sink) - (-> [Name Definition] java/util/jar/JarOutputStream java/util/jar/JarOutputStream) - (let [class-name (|> class-name name.internal name.read ..class-name)] - (do-to sink - (java/util/jar/JarOutputStream::putNextEntry (java/util/jar/JarEntry::new class-name)) - (java/util/zip/ZipOutputStream::write bytecode +0 (.int (binary.size bytecode))) - (java/io/Flushable::flush) - (java/util/zip/ZipOutputStream::closeEntry)))) - -(def: (write-module [module classes] sink) - (-> [Module (Buffer Definition)] java/util/jar/JarOutputStream java/util/jar/JarOutputStream) - (|> classes - row.to-list - (list@fold ..write-class sink))) - -(def: #export (package program-class outputs) - (-> External (Output Definition) Binary) - (let [buffer (java/io/ByteArrayOutputStream::new (.int ..mebi-byte)) - sink (java/util/jar/JarOutputStream::new buffer (manifest program-class))] - (exec (|> outputs - row.to-list - (list@fold ..write-module sink)) - (do-to sink - (java/io/Flushable::flush) - (java/io/Closeable::close)) - (java/io/ByteArrayOutputStream::toByteArray buffer)))) diff --git a/new-luxc/source/luxc/lang/translation/jvm.lux b/new-luxc/source/luxc/lang/translation/jvm.lux deleted file mode 100644 index fccbd14bf..000000000 --- a/new-luxc/source/luxc/lang/translation/jvm.lux +++ /dev/null @@ -1,154 +0,0 @@ -(.module: - [lux (#- Definition) - ["." host (#+ import: do-to object)] - [abstract - [monad (#+ do)]] - [control - pipe - ["." try (#+ Try)] - ["." exception (#+ exception:)] - ["." io (#+ IO io)] - [concurrency - ["." atom (#+ Atom atom)]]] - [data - [binary (#+ Binary)] - ["." product] - ["." text ("#@." hash) - ["%" format (#+ format)]] - [collection - ["." array] - ["." dictionary (#+ Dictionary)]]] - [target - [jvm - ["." loader (#+ Library)] - ["." type - ["." descriptor]]]] - [tool - [compiler - ["." name]]]] - [/// - [host - ["." jvm (#+ Inst Definition Host State) - ["." def] - ["." inst]]]] - ) - -(import: org/objectweb/asm/Label) - -(import: java/lang/reflect/Field - (get [#? Object] #try #? Object)) - -(import: (java/lang/Class a) - (getField [String] #try Field)) - -(import: java/lang/Object - (getClass [] (Class Object))) - -(import: java/lang/ClassLoader) - -(type: #export ByteCode Binary) - -(def: #export value-field Text "_value") -(def: #export $Value (type.class "java.lang.Object" (list))) - -(exception: #export (cannot-load {class Text} {error Text}) - (exception.report - ["Class" class] - ["Error" error])) - -(exception: #export (invalid-field {class Text} {field Text} {error Text}) - (exception.report - ["Class" class] - ["Field" field] - ["Error" error])) - -(exception: #export (invalid-value {class Text}) - (exception.report - ["Class" class])) - -(def: (class-value class-name class) - (-> Text (Class Object) (Try Any)) - (case (Class::getField ..value-field class) - (#try.Success field) - (case (Field::get #.None field) - (#try.Success ?value) - (case ?value - (#.Some value) - (#try.Success value) - - #.None - (exception.throw invalid-value class-name)) - - (#try.Failure error) - (exception.throw cannot-load [class-name error])) - - (#try.Failure error) - (exception.throw invalid-field [class-name ..value-field error]))) - -(def: class-path-separator ".") - -(def: (evaluate! library loader eval-class valueI) - (-> Library ClassLoader Text Inst (Try [Any Definition])) - (let [bytecode-name (text.replace-all class-path-separator .module-separator eval-class) - bytecode (def.class #jvm.V1_6 - #jvm.Public jvm.noneC - bytecode-name - (list) $Value - (list) - (|>> (def.field #jvm.Public ($_ jvm.++F jvm.finalF jvm.staticF) - ..value-field ..$Value) - (def.method #jvm.Public ($_ jvm.++M jvm.staticM jvm.strictM) - "<clinit>" - (type.method [(list) type.void (list)]) - (|>> valueI - (inst.PUTSTATIC (type.class bytecode-name (list)) ..value-field ..$Value) - inst.RETURN))))] - (io.run (do (try.with io.monad) - [_ (loader.store eval-class bytecode library) - class (loader.load eval-class loader) - value (:: io.monad wrap (class-value eval-class class))] - (wrap [value - [eval-class bytecode]]))))) - -(def: (execute! library loader temp-label [class-name class-bytecode]) - (-> Library ClassLoader Text Definition (Try Any)) - (io.run (do (try.with io.monad) - [existing-class? (|> (atom.read library) - (:: io.monad map (dictionary.contains? class-name)) - (try.lift io.monad) - (: (IO (Try Bit)))) - _ (if existing-class? - (wrap []) - (loader.store class-name class-bytecode library))] - (loader.load class-name loader)))) - -(def: (define! library loader [module name] valueI) - (-> Library ClassLoader Name Inst (Try [Text Any Definition])) - (let [class-name (format (text.replace-all .module-separator class-path-separator module) - class-path-separator (name.normalize name) - "___" (%.nat (text@hash name)))] - (do try.monad - [[value definition] (evaluate! library loader class-name valueI)] - (wrap [class-name value definition])))) - -(def: #export host - (IO Host) - (io (let [library (loader.new-library []) - loader (loader.memory library)] - (: Host - (structure - (def: (evaluate! temp-label valueI) - (let [eval-class (|> temp-label name.normalize (text.replace-all " " "$"))] - (:: try.monad map product.left - (..evaluate! library loader eval-class valueI)))) - - (def: execute! - (..execute! library loader)) - - (def: define! - (..define! library loader))))))) - -(def: #export $Variant (type.array ..$Value)) -(def: #export $Tuple (type.array ..$Value)) -(def: #export $Function (type.class "LuxFunction" (list))) -(def: #export $Runtime (type.class "LuxRuntime" (list))) diff --git a/new-luxc/source/program.lux b/new-luxc/source/program.lux index f975d2a87..2b2278cec 100644 --- a/new-luxc/source/program.lux +++ b/new-luxc/source/program.lux @@ -1,5 +1,5 @@ (.module: - [lux #* + [lux (#- Definition) ["@" target] ["." host (#+ import:)] [abstract @@ -19,33 +19,28 @@ ["." file]] [target [jvm - ["$t" type]]] + [bytecode (#+ Bytecode)]]] [tool [compiler [phase ["." macro (#+ Expander)] [extension (#+ Phase Bundle Operation Handler Extender) ["." analysis #_ - ["#" jvm]]]] + ["#" jvm]] + ["." directive #_ + ["#" jvm]]] + ["." generation #_ + ["#" jvm/extension] + ["." jvm + ["." runtime (#+ Anchor Definition)] + ["#/." program] + ["." packager] + ["#/." host]]]] [default ["." platform (#+ Platform)]]]]] [program ["/" compositor - ["/." cli]]] - [luxc - [lang - ["." packager] - [host - ["_" jvm - ["$d" def] - ["$i" inst]]] - ["." directive #_ - ["#" jvm]] - [translation - ["." jvm - ["." runtime] - ["." expression] - ["translation" extension]]]]]) + ["/." cli]]]) (import: #long java/lang/reflect/Method (invoke [java/lang/Object [java/lang/Object]] #try java/lang/Object)) @@ -90,81 +85,14 @@ apply-method)))) (def: #export platform - (IO (Platform IO _.Anchor _.Inst _.Definition)) + (IO (Platform IO Anchor (Bytecode Any) Definition)) (do io.monad - [host jvm.host] + [host jvm/host.host] (wrap {#platform.&monad io.monad #platform.&file-system file.system #platform.host host - #platform.phase expression.translate - #platform.runtime runtime.translate}))) - -(def: program-class "LuxProgram") - -(def: #export (program programI) - (-> _.Inst _.Definition) - (let [$Object ($t.class "java.lang.Object" (list)) - nilI runtime.noneI - num-inputsI (|>> ($i.ALOAD 0) $i.ARRAYLENGTH) - decI (|>> ($i.int +1) $i.ISUB) - headI (|>> $i.DUP - ($i.ALOAD 0) - $i.SWAP - $i.AALOAD - $i.SWAP - $i.DUP_X2 - $i.POP) - pairI (|>> ($i.int +2) - ($i.ANEWARRAY $Object) - $i.DUP_X1 - $i.SWAP - ($i.int +0) - $i.SWAP - $i.AASTORE - $i.DUP_X1 - $i.SWAP - ($i.int +1) - $i.SWAP - $i.AASTORE) - consI (|>> ($i.int +1) - ($i.string "") - $i.DUP2_X1 - $i.POP2 - runtime.variantI) - prepare-input-listI (<| $i.with-label (function (_ @loop)) - $i.with-label (function (_ @end)) - (|>> nilI - num-inputsI - ($i.label @loop) - decI - $i.DUP - ($i.IFLT @end) - headI - pairI - consI - $i.SWAP - ($i.GOTO @loop) - ($i.label @end) - $i.POP)) - feed-inputsI ($i.INVOKEVIRTUAL jvm.$Function runtime.apply-method (runtime.apply-signature 1)) - run-ioI (|>> ($i.CHECKCAST jvm.$Function) - $i.NULL - ($i.INVOKEVIRTUAL jvm.$Function runtime.apply-method (runtime.apply-signature 1))) - main-type ($t.method [(list ($t.array ($t.class "java.lang.String" (list)))) - $t.void - (list)])] - [..program-class - ($d.class #_.V1_6 - #_.Public _.finalC - ..program-class - (list) $Object - (list) - (|>> ($d.method #_.Public _.staticM "main" main-type - (|>> programI - prepare-input-listI - feed-inputsI - run-ioI - $i.RETURN))))])) + #platform.phase jvm.generate + #platform.runtime runtime.generate}))) (def: extender Extender @@ -204,9 +132,9 @@ ..expander analysis.bundle ..platform - translation.bundle + generation.bundle directive.bundle - ..program + jvm/program.program ..extender service - [(packager.package ..program-class) jar-path]))) + [(packager.package jvm/program.class) jar-path]))) |