aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm.lux154
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/common.lux39
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/function.lux6
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/program.lux82
4 files changed, 257 insertions, 24 deletions
diff --git a/new-luxc/source/luxc/lang/translation/jvm.lux b/new-luxc/source/luxc/lang/translation/jvm.lux
new file mode 100644
index 000000000..fccbd14bf
--- /dev/null
+++ b/new-luxc/source/luxc/lang/translation/jvm.lux
@@ -0,0 +1,154 @@
+(.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/luxc/lang/translation/jvm/common.lux b/new-luxc/source/luxc/lang/translation/jvm/common.lux
index 8b2a83526..6cd7f4f2f 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/common.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/common.lux
@@ -1,24 +1,25 @@
(.module:
[lux #*
- [abstract
- [monad (#+ do)]]
- [control
- ["." try (#+ Try)]
- ["ex" exception (#+ exception:)]
- ["." io]]
- [data
- [binary (#+ Binary)]
- ["." text ("#/." hash)
- format]
- [collection
- ["." dictionary (#+ Dictionary)]]]
- ["." macro]
- [host (#+ import:)]
- [tool
- [compiler
- [reference (#+ Register)]
- ["." name]
- ["." phase]]]]
+ ## [abstract
+ ## [monad (#+ do)]]
+ ## [control
+ ## ["." try (#+ Try)]
+ ## ["ex" exception (#+ exception:)]
+ ## ["." io]]
+ ## [data
+ ## [binary (#+ Binary)]
+ ## ["." text ("#/." hash)
+ ## format]
+ ## [collection
+ ## ["." dictionary (#+ Dictionary)]]]
+ ## ["." macro]
+ ## [host (#+ import:)]
+ ## [tool
+ ## [compiler
+ ## [reference (#+ Register)]
+ ## ["." name]
+ ## ["." phase]]]
+ ]
## [luxc
## [lang
## [host
diff --git a/new-luxc/source/luxc/lang/translation/jvm/function.lux b/new-luxc/source/luxc/lang/translation/jvm/function.lux
index 34a4c890e..7a4bbef4e 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/function.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/function.lux
@@ -240,16 +240,12 @@
(_.INVOKESPECIAL class "<init>" (init-method env function-arity))
_.ARETURN))
))))
- _.fuse)
- failureI (|>> (_.INVOKESTATIC //.$Runtime "apply_fail" (type.method [(list) type.void (list)]))
- _.NULL
- _.ARETURN)]
+ _.fuse)]
(def.method #$.Public $.noneM runtime.apply-method (runtime.apply-signature apply-arity)
(|>> get-amount-of-partialsI
(_.TABLESWITCH +0 (|> num-partials dec .int)
@default @labels)
casesI
- failureI
))))
(def: #export with-environment
diff --git a/new-luxc/source/luxc/lang/translation/jvm/program.lux b/new-luxc/source/luxc/lang/translation/jvm/program.lux
new file mode 100644
index 000000000..7ac897009
--- /dev/null
+++ b/new-luxc/source/luxc/lang/translation/jvm/program.lux
@@ -0,0 +1,82 @@
+(.module:
+ [lux #*
+ [target
+ [jvm
+ ["$t" type]]]]
+ [luxc
+ [lang
+ [host
+ ["_" jvm
+ ["$d" def]
+ ["$i" inst]]]
+ [translation
+ ["." jvm
+ ["." runtime]]]]])
+
+(def: #export class "LuxProgram")
+
+(def: ^Object ($t.class "java.lang.Object" (list)))
+
+(def: #export (program programI)
+ (-> _.Inst _.Definition)
+ (let [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)])]
+ [..class
+ ($d.class #_.V1_6
+ #_.Public _.finalC
+ ..class
+ (list) ..^Object
+ (list)
+ (|>> ($d.method #_.Public _.staticM "main" main-type
+ (|>> programI
+ prepare-input-listI
+ feed-inputsI
+ run-ioI
+ $i.RETURN))))]))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-26 00:49:04 +0000