aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/lang
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/lang')
-rw-r--r--new-luxc/source/luxc/lang/host.jvm.lux188
-rw-r--r--new-luxc/source/luxc/lang/host/jvm.lux51
-rw-r--r--new-luxc/source/luxc/lang/host/jvm/def.lux26
-rw-r--r--new-luxc/source/luxc/lang/host/jvm/inst.lux110
-rw-r--r--new-luxc/source/luxc/lang/host/jvm/type.lux14
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm.lux202
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux336
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux207
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/expression.jvm.lux115
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/primitive.jvm.lux46
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/reference.jvm.lux78
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux227
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/structure.jvm.lux62
13 files changed, 819 insertions, 843 deletions
diff --git a/new-luxc/source/luxc/lang/host.jvm.lux b/new-luxc/source/luxc/lang/host.jvm.lux
deleted file mode 100644
index b207fdad7..000000000
--- a/new-luxc/source/luxc/lang/host.jvm.lux
+++ /dev/null
@@ -1,188 +0,0 @@
-(.module:
- lux
- (lux (control [monad #+ do]
- ["ex" exception #+ exception:]
- pipe)
- (concurrency [atom #+ Atom atom])
- (data ["e" error]
- [text]
- text/format
- (coll (dictionary ["dict" unordered])
- [array]))
- [macro]
- [host #+ do-to object]
- [io]
- ["//" lang]
- (lang ["//." reference #+ Register]))
- (luxc [lang]
- (lang (translation (jvm [".T" common])))))
-
-(host.import: org/objectweb/asm/Label)
-
-(host.import: java/lang/reflect/AccessibleObject
- (setAccessible [boolean] void))
-
-(host.import: java/lang/reflect/Method
- (invoke [Object (Array Object)] #try Object))
-
-(host.import: (java/lang/Class a)
- (getDeclaredMethod [String (Array (Class Object))] #try Method))
-
-(host.import: java/lang/Object
- (getClass [] (Class Object)))
-
-(host.import: java/lang/Integer
- (#static TYPE (Class Integer)))
-
-(host.import: java/lang/ClassLoader)
-
-(def: ClassLoader::defineClass
- Method
- (case (Class::getDeclaredMethod ["defineClass"
- (|> (host.array (Class Object) +4)
- (host.array-write +0 (:coerce (Class Object) (host.class-for String)))
- (host.array-write +1 (Object::getClass [] (host.array byte +0)))
- (host.array-write +2 (:coerce (Class Object) Integer::TYPE))
- (host.array-write +3 (:coerce (Class Object) Integer::TYPE)))]
- (host.class-for java/lang/ClassLoader))
- (#e.Success method)
- (do-to method
- (AccessibleObject::setAccessible [#1]))
-
- (#e.Error error)
- (error! error)))
-
-(def: (define-class class-name byte-code loader)
- (-> Text commonT.Bytecode ClassLoader (e.Error Object))
- (Method::invoke [loader
- (array.from-list (list (:coerce Object class-name)
- (:coerce Object byte-code)
- (:coerce Object (host.long-to-int 0))
- (:coerce Object (host.long-to-int (.int (host.array-length byte-code))))))]
- ClassLoader::defineClass))
-
-(def: (fetch-byte-code class-name store)
- (-> Text commonT.Class-Store (Maybe commonT.Bytecode))
- (|> store atom.read io.run (dict.get class-name)))
-
-(def: (memory-class-loader store)
- (-> commonT.Class-Store ClassLoader)
- (object [] ClassLoader []
- []
- (ClassLoader (findClass [class-name String]) Class
- (case (fetch-byte-code class-name store)
- (#.Some bytecode)
- (case (define-class class-name bytecode (:coerce ClassLoader _jvm_this))
- (#e.Success class)
- (:assume class)
-
- (#e.Error error)
- (error! (format "Class definition error: " class-name "\n"
- error)))
-
- #.None
- (error! (format "Class not found: " class-name))))))
-
-(def: #export init-host
- (io.IO commonT.Host)
- (io.io (let [store (: commonT.Class-Store
- (atom (dict.new text.Hash<Text>)))]
- {#commonT.loader (memory-class-loader store)
- #commonT.store store
- #commonT.artifacts (dict.new text.Hash<Text>)
- #commonT.context ["" +0]
- #commonT.anchor #.None})))
-
-(def: #export (with-anchor anchor expr)
- (All [a] (-> [Label Register] (Meta a) (Meta a)))
- (.function (_ compiler)
- (let [old (:coerce commonT.Host (get@ #.host compiler))]
- (case (expr (set@ #.host
- (:coerce Nothing (set@ #commonT.anchor (#.Some anchor) old))
- compiler))
- (#e.Success [compiler' output])
- (#e.Success [(update@ #.host
- (|>> (:coerce commonT.Host)
- (set@ #commonT.anchor (get@ #commonT.anchor old))
- (:coerce Nothing))
- compiler')
- output])
-
- (#e.Error error)
- (#e.Error error)))))
-
-(exception: #export (No-Anchor {message Text})
- message)
-
-(def: #export anchor
- (Meta [Label Register])
- (.function (_ compiler)
- (case (|> compiler (get@ #.host) (:coerce commonT.Host) (get@ #commonT.anchor))
- (#.Some anchor)
- (#e.Success [compiler
- anchor])
-
- #.None
- ((//.throw No-Anchor "") compiler))))
-
-(def: #export (with-context name expr)
- (All [a] (-> Text (Meta a) (Meta a)))
- (.function (_ compiler)
- (let [old (:coerce commonT.Host (get@ #.host compiler))]
- (case (expr (set@ #.host
- (:coerce Nothing (set@ #commonT.context [(lang.normalize-name name) +0] old))
- compiler))
- (#e.Success [compiler' output])
- (#e.Success [(update@ #.host
- (|>> (:coerce commonT.Host)
- (set@ #commonT.context (get@ #commonT.context old))
- (:coerce Nothing))
- compiler')
- output])
-
- (#e.Error error)
- (#e.Error error)))))
-
-(def: #export (with-sub-context expr)
- (All [a] (-> (Meta a) (Meta [Text a])))
- (.function (_ compiler)
- (let [old (:coerce commonT.Host (get@ #.host compiler))
- [old-name old-sub] (get@ #commonT.context old)
- new-name (format old-name "$" (%i (.int old-sub)))]
- (case (expr (set@ #.host
- (:coerce Nothing (set@ #commonT.context [new-name +0] old))
- compiler))
- (#e.Success [compiler' output])
- (#e.Success [(update@ #.host
- (|>> (:coerce commonT.Host)
- (set@ #commonT.context [old-name (inc old-sub)])
- (:coerce Nothing))
- compiler')
- [new-name output]])
-
- (#e.Error error)
- (#e.Error error)))))
-
-(def: #export context
- (Meta Text)
- (.function (_ compiler)
- (#e.Success [compiler
- (|> (get@ #.host compiler)
- (:coerce commonT.Host)
- (get@ #commonT.context)
- (let> [name sub]
- name))])))
-
-(def: #export class-loader
- (Meta ClassLoader)
- (function (_ compiler)
- (#e.Success [compiler
- (|> compiler
- (get@ #.host)
- (:coerce commonT.Host)
- (get@ #commonT.loader))])))
-
-(def: #export runtime-class Text "LuxRuntime")
-(def: #export function-class Text "LuxFunction")
-(def: #export runnable-class Text "LuxRunnable")
-(def: #export unit Text "")
diff --git a/new-luxc/source/luxc/lang/host/jvm.lux b/new-luxc/source/luxc/lang/host/jvm.lux
index adb24b8c0..bbfc5e136 100644
--- a/new-luxc/source/luxc/lang/host/jvm.lux
+++ b/new-luxc/source/luxc/lang/host/jvm.lux
@@ -1,19 +1,28 @@
(.module:
- [lux #- Type]
- (lux (control monad
- ["p" parser])
- (data (coll [list "list/" Functor<List>]))
- [macro]
- (macro [code]
- ["s" syntax #+ syntax:])
- [host]))
+ [lux (#- Type Definition)
+ [control
+ monad
+ ["p" parser]]
+ [data
+ [collection
+ [list ("list/" Functor<List>)]]]
+ [macro
+ [code]
+ ["s" syntax (#+ syntax:)]]
+ [host (#+ import:)]
+ [world
+ [blob (#+ Blob)]]
+ [language
+ [reference (#+ Register)]
+ [compiler
+ ["." translation]]]])
## [Host]
-(host.import: org/objectweb/asm/MethodVisitor)
+(import: org/objectweb/asm/MethodVisitor)
-(host.import: org/objectweb/asm/ClassWriter)
+(import: org/objectweb/asm/ClassWriter)
-(host.import: #long org/objectweb/asm/Label
+(import: #long org/objectweb/asm/Label
(new []))
## [Type]
@@ -61,8 +70,6 @@
(type: #export Label
org/objectweb/asm/Label)
-(type: #export Register Nat)
-
(type: #export Visibility
#Public
#Protected
@@ -79,6 +86,24 @@
#V1_7
#V1_8)
+(type: #export ByteCode Blob)
+
+(type: #export Definition [Text ByteCode])
+
+(type: #export Anchor [Label Register])
+
+(type: #export Host
+ (translation.Host Inst Definition))
+
+(type: #export State
+ (translation.State ..Anchor Inst Definition))
+
+(type: #export Operation
+ (translation.Operation ..Anchor Inst Definition))
+
+(type: #export Compiler
+ (translation.Compiler ..Anchor Inst Definition))
+
## [Values]
(syntax: (config: {type s.local-symbol}
{none s.local-symbol}
diff --git a/new-luxc/source/luxc/lang/host/jvm/def.lux b/new-luxc/source/luxc/lang/host/jvm/def.lux
index 4c19f38f6..3d3f8d80d 100644
--- a/new-luxc/source/luxc/lang/host/jvm/def.lux
+++ b/new-luxc/source/luxc/lang/host/jvm/def.lux
@@ -1,16 +1,17 @@
(.module:
- lux
- (lux (data [text]
- text/format
- [product]
- (coll ["a" array]
- [list "list/" Functor<List>]))
- [host #+ do-to]
- [function])
- ["$" //]
- (// ["$t" type]))
-
-## [Host]
+ [lux #*
+ [data
+ ["." text
+ format]
+ ["." product]
+ [collection
+ ["a" array]
+ [list ("list/" Functor<List>)]]]
+ [host (#+ do-to)]
+ [function]]
+ ["$" //
+ ["$t" type]])
+
(host.import: #long java/lang/Object)
(host.import: #long java/lang/String)
@@ -59,7 +60,6 @@
(visitMethod [int String String String (Array String)] MethodVisitor)
(toByteArray [] (Array byte)))
-## [Defs]
(def: (string-array values)
(-> (List Text) (Array Text))
(let [output (host.array String (list.size values))]
diff --git a/new-luxc/source/luxc/lang/host/jvm/inst.lux b/new-luxc/source/luxc/lang/host/jvm/inst.lux
index 393200a28..9426fabe3 100644
--- a/new-luxc/source/luxc/lang/host/jvm/inst.lux
+++ b/new-luxc/source/luxc/lang/host/jvm/inst.lux
@@ -1,29 +1,35 @@
(.module:
- [lux #- int char]
- (lux (control monad
- ["p" parser])
- (data [maybe]
- ["e" error]
- text/format
- (coll [list "list/" Functor<List>]))
- [host #+ do-to]
- [macro]
- (macro [code]
- ["s" syntax #+ syntax:])
- [function])
- [//]
- [//type])
+ [lux (#- int char)
+ [control
+ [monad (#+ do)]
+ ["p" parser]]
+ [data
+ ["." maybe]
+ ["." error]
+ [text
+ format]
+ [collection
+ ["." list ("list/" Functor<List>)]]]
+ [host (#+ import: do-to)]
+ [macro
+ ["." code]
+ ["s" syntax (#+ syntax:)]]
+ [function]
+ [language
+ [compiler (#+ Operation)]]]
+ ["." // (#+ Primitive Inst)
+ ["." type]])
## [Host]
-(host.import: #long java/lang/Object)
-(host.import: #long java/lang/String)
+(import: #long java/lang/Object)
+(import: #long java/lang/String)
(syntax: (declare {codes (p.many s.local-symbol)})
(|> codes
(list/map (function (_ code) (` ((~' #static) (~ (code.local-symbol code)) (~' int)))))
wrap))
-(`` (host.import: org/objectweb/asm/Opcodes
+(`` (import: org/objectweb/asm/Opcodes
(#static NOP int)
## Conversion
@@ -90,10 +96,10 @@
(~~ (declare RETURN IRETURN LRETURN DRETURN ARETURN))
))
-(host.import: org/objectweb/asm/Label
+(import: org/objectweb/asm/Label
(new []))
-(host.import: org/objectweb/asm/MethodVisitor
+(import: org/objectweb/asm/MethodVisitor
(visitCode [] void)
(visitMaxs [int int] void)
(visitEnd [] void)
@@ -112,17 +118,17 @@
## [Insts]
(def: #export make-label
- (Meta Label)
- (function (_ compiler)
- (#e.Success [compiler (Label::new [])])))
+ (All [s] (Operation s Label))
+ (function (_ state)
+ (#error.Success [state (Label::new [])])))
(def: #export (with-label action)
- (-> (-> Label //.Inst) //.Inst)
+ (-> (-> Label Inst) Inst)
(action (Label::new [])))
(do-template [<name> <type> <prepare>]
[(def: #export (<name> value)
- (-> <type> //.Inst)
+ (-> <type> Inst)
(function (_ visitor)
(do-to visitor
(MethodVisitor::visitLdcInsn [(<prepare> value)]))))]
@@ -139,14 +145,14 @@
(wrap (list (code.local-symbol (format "Opcodes::" base)))))
(def: #export NULL
- //.Inst
+ Inst
(function (_ visitor)
(do-to visitor
(MethodVisitor::visitInsn [(prefix ACONST_NULL)]))))
(do-template [<name>]
[(def: #export <name>
- //.Inst
+ Inst
(function (_ visitor)
(do-to visitor
(MethodVisitor::visitInsn [(prefix <name>)]))))]
@@ -207,7 +213,7 @@
(do-template [<name>]
[(def: #export (<name> register)
- (-> Nat //.Inst)
+ (-> Nat Inst)
(function (_ visitor)
(do-to visitor
(MethodVisitor::visitVarInsn [(prefix <name>) (.int register)]))))]
@@ -218,10 +224,10 @@
(do-template [<name> <inst>]
[(def: #export (<name> class field type)
- (-> Text Text //.Type //.Inst)
+ (-> Text Text //.Type Inst)
(function (_ visitor)
(do-to visitor
- (MethodVisitor::visitFieldInsn [<inst> (//type.binary-name class) field (//type.descriptor type)]))))]
+ (MethodVisitor::visitFieldInsn [<inst> (type.binary-name class) field (type.descriptor type)]))))]
[GETSTATIC Opcodes::GETSTATIC]
[PUTSTATIC Opcodes::PUTSTATIC]
@@ -232,10 +238,10 @@
(do-template [<name> <inst>]
[(def: #export (<name> class)
- (-> Text //.Inst)
+ (-> Text Inst)
(function (_ visitor)
(do-to visitor
- (MethodVisitor::visitTypeInsn [<inst> (//type.binary-name class)]))))]
+ (MethodVisitor::visitTypeInsn [<inst> (type.binary-name class)]))))]
[CHECKCAST Opcodes::CHECKCAST]
[NEW Opcodes::NEW]
@@ -244,7 +250,7 @@
)
(def: #export (NEWARRAY type)
- (-> //.Primitive //.Inst)
+ (-> Primitive Inst)
(function (_ visitor)
(do-to visitor
(MethodVisitor::visitIntInsn [Opcodes::NEWARRAY (case type
@@ -259,10 +265,10 @@
(do-template [<name> <inst>]
[(def: #export (<name> class method-name method-signature interface?)
- (-> Text Text //.Method Bit //.Inst)
+ (-> Text Text //.Method Bit Inst)
(function (_ visitor)
(do-to visitor
- (MethodVisitor::visitMethodInsn [<inst> (//type.binary-name class) method-name (//type.method-descriptor method-signature) interface?]))))]
+ (MethodVisitor::visitMethodInsn [<inst> (type.binary-name class) method-name (type.method-descriptor method-signature) interface?]))))]
[INVOKESTATIC Opcodes::INVOKESTATIC]
[INVOKEVIRTUAL Opcodes::INVOKEVIRTUAL]
@@ -272,7 +278,7 @@
(do-template [<name>]
[(def: #export (<name> @where)
- (-> //.Label //.Inst)
+ (-> //.Label Inst)
(function (_ visitor)
(do-to visitor
(MethodVisitor::visitJumpInsn [(prefix <name>) @where]))))]
@@ -283,7 +289,7 @@
)
(def: #export (TABLESWITCH min max default labels)
- (-> Int Int //.Label (List //.Label) //.Inst)
+ (-> Int Int //.Label (List //.Label) Inst)
(function (_ visitor)
(let [num-labels (list.size labels)
labels-array (host.array Label num-labels)
@@ -298,19 +304,19 @@
(MethodVisitor::visitTableSwitchInsn [min max default labels-array])))))
(def: #export (try @from @to @handler exception)
- (-> //.Label //.Label //.Label Text //.Inst)
+ (-> //.Label //.Label //.Label Text Inst)
(function (_ visitor)
(do-to visitor
- (MethodVisitor::visitTryCatchBlock [@from @to @handler (//type.binary-name exception)]))))
+ (MethodVisitor::visitTryCatchBlock [@from @to @handler (type.binary-name exception)]))))
(def: #export (label @label)
- (-> //.Label //.Inst)
+ (-> //.Label Inst)
(function (_ visitor)
(do-to visitor
(MethodVisitor::visitLabel [@label]))))
(def: #export (array type)
- (-> //.Type //.Inst)
+ (-> //.Type Inst)
(case type
(#//.Primitive prim)
(NEWARRAY prim)
@@ -318,17 +324,17 @@
(#//.Generic generic)
(let [elem-class (case generic
(#//.Class class params)
- (//type.binary-name class)
+ (type.binary-name class)
_
- (//type.binary-name "java.lang.Object"))]
+ (type.binary-name "java.lang.Object"))]
(ANEWARRAY elem-class))
_
- (ANEWARRAY (//type.descriptor type))))
+ (ANEWARRAY (type.descriptor type))))
(def: (primitive-wrapper type)
- (-> //.Primitive Text)
+ (-> Primitive Text)
(case type
#//.Boolean "java.lang.Boolean"
#//.Byte "java.lang.Byte"
@@ -340,7 +346,7 @@
#//.Char "java.lang.Character"))
(def: (primitive-unwrap type)
- (-> //.Primitive Text)
+ (-> Primitive Text)
(case type
#//.Boolean "booleanValue"
#//.Byte "byteValue"
@@ -352,24 +358,24 @@
#//.Char "charValue"))
(def: #export (wrap type)
- (-> //.Primitive //.Inst)
+ (-> Primitive Inst)
(let [class (primitive-wrapper type)]
(|>> (INVOKESTATIC class "valueOf"
- (//type.method (list (#//.Primitive type))
- (#.Some (//type.class class (list)))
- (list))
+ (type.method (list (#//.Primitive type))
+ (#.Some (type.class class (list)))
+ (list))
#0))))
(def: #export (unwrap type)
- (-> //.Primitive //.Inst)
+ (-> Primitive Inst)
(let [class (primitive-wrapper type)]
(|>> (CHECKCAST class)
(INVOKEVIRTUAL class (primitive-unwrap type)
- (//type.method (list) (#.Some (#//.Primitive type)) (list))
+ (type.method (list) (#.Some (#//.Primitive type)) (list))
#0))))
(def: #export (fuse insts)
- (-> (List //.Inst) //.Inst)
+ (-> (List Inst) Inst)
(case insts
#.Nil
id
diff --git a/new-luxc/source/luxc/lang/host/jvm/type.lux b/new-luxc/source/luxc/lang/host/jvm/type.lux
index 0c36e6799..f9a956b86 100644
--- a/new-luxc/source/luxc/lang/host/jvm/type.lux
+++ b/new-luxc/source/luxc/lang/host/jvm/type.lux
@@ -1,8 +1,10 @@
(.module:
- [lux #- int char]
- (lux (data [text]
- text/format
- (coll [list "list/" Functor<List>])))
+ [lux (#- int char)
+ [data
+ ["." text
+ format]
+ [collection
+ [list ("list/" Functor<List>)]]]]
[//])
## Types
@@ -37,9 +39,9 @@
+0 elemT
_ (#//.Array (array (dec depth) elemT))))
-(def: #export (binary-name class)
+(def: #export binary-name
(-> Text Text)
- (text.replace-all "." "/" class))
+ (text.replace-all "." "/"))
(def: #export (descriptor type)
(-> //.Type Text)
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..152def2f5
--- /dev/null
+++ b/new-luxc/source/luxc/lang/translation/jvm.lux
@@ -0,0 +1,202 @@
+(.module:
+ [lux (#- Definition)
+ [control
+ [monad (#+ do)]
+ ["ex" exception (#+ exception:)]
+ pipe]
+ [concurrency
+ ["." atom (#+ Atom atom)]]
+ [data
+ ["." error (#+ Error)]
+ ["." text
+ format]
+ [collection
+ ["." array]
+ ["." dictionary (#+ Dictionary)]]]
+ [host (#+ import: do-to object)]
+ ["." io (#+ IO io)]
+ [world
+ [blob (#+ Blob)]]
+ [language
+ ["." name]
+ [compiler
+ ["." translation]]]]
+ [///
+ [host
+ ["." jvm (#+ Inst Definition Host State)
+ ["." type]
+ ["." def]
+ ["." inst]]]]
+ )
+
+(import: org/objectweb/asm/Label)
+
+(import: java/lang/reflect/AccessibleObject
+ (setAccessible [boolean] void))
+
+(import: java/lang/reflect/Field
+ (get [#? Object] #try #? Object))
+
+(import: java/lang/reflect/Method
+ (invoke [Object (Array Object)] #try Object))
+
+(import: (java/lang/Class a)
+ (getField [String] #try Field)
+ (getDeclaredMethod [String (Array (Class Object))] #try Method))
+
+(import: java/lang/Object
+ (getClass [] (Class Object)))
+
+(import: java/lang/Integer
+ (#static TYPE (Class Integer)))
+
+(import: java/lang/ClassLoader
+ (loadClass [String] #try (Class Object)))
+
+(def: ClassLoader::defineClass
+ Method
+ (case (Class::getDeclaredMethod ["defineClass"
+ (|> (host.array (Class Object) +4)
+ (host.array-write +0 (:coerce (Class Object) (host.class-for String)))
+ (host.array-write +1 (Object::getClass [] (host.array byte +0)))
+ (host.array-write +2 (:coerce (Class Object) Integer::TYPE))
+ (host.array-write +3 (:coerce (Class Object) Integer::TYPE)))]
+ (host.class-for java/lang/ClassLoader))
+ (#error.Success method)
+ (do-to method
+ (AccessibleObject::setAccessible [#1]))
+
+ (#error.Error error)
+ (error! error)))
+
+(type: #export ByteCode Blob)
+
+(def: (define-class class-name bytecode loader)
+ (-> Text ByteCode ClassLoader (Error Object))
+ (Method::invoke [loader
+ (array.from-list (list (:coerce Object class-name)
+ (:coerce Object bytecode)
+ (:coerce Object (host.long-to-int 0))
+ (:coerce Object (host.long-to-int (.int (host.array-length bytecode))))))]
+ ClassLoader::defineClass))
+
+(type: Store (Atom (Dictionary Text ByteCode)))
+
+(def: (fetch-bytecode class-name store)
+ (-> Text Store (Maybe ByteCode))
+ (|> store atom.read io.run (dictionary.get class-name)))
+
+(do-template [<name>]
+ [(exception: #export (<name> {class Text})
+ (ex.report ["Class" class]))]
+
+ [unknown-class]
+ [class-already-stored]
+ )
+
+(exception: #export (cannot-define-class {class Text} {error Text})
+ (ex.report ["Class" class]
+ ["Error" error]))
+
+(def: (memory-class-loader store)
+ (-> Store ClassLoader)
+ (object [] ClassLoader []
+ []
+ (ClassLoader (findClass [class-name String]) Class
+ (case (fetch-bytecode class-name store)
+ (#.Some bytecode)
+ (case (define-class class-name bytecode (:coerce ClassLoader _jvm_this))
+ (#error.Success class)
+ (:assume class)
+
+ (#error.Error error)
+ (error! (ex.construct cannot-define-class [class-name error])))
+
+ #.None
+ (error! (ex.construct unknown-class class-name))))))
+
+(def: (store! name bytecode store)
+ (-> Text ByteCode Store (Error Any))
+ (if (dictionary.contains? name (|> store atom.read io.run))
+ (ex.throw class-already-stored name)
+ (exec (io.run (atom.update (dictionary.put name bytecode) store))
+ (#error.Success []))))
+
+(def: (load! name loader)
+ (-> Text ClassLoader (Error (Class Object)))
+ (ClassLoader::loadClass [name] loader))
+
+(def: #export value-field Text "_value")
+(def: #export $Object jvm.Type (type.class "java.lang.Object" (list)))
+
+(exception: #export (cannot-load {class Text} {error Text})
+ (ex.report ["Class" class]
+ ["Error" error]))
+
+(exception: #export (invalid-field {class Text} {field Text})
+ (ex.report ["Class" class]
+ ["Field" field]))
+
+(exception: #export (invalid-value {class Text})
+ (ex.report ["Class" class]))
+
+(def: (class-value class-name class)
+ (-> Text (Class Object) (Error Any))
+ (case (Class::getField [..value-field] class)
+ (#error.Success field)
+ (case (Field::get [#.None] field)
+ (#error.Success ?value)
+ (case ?value
+ (#.Some value)
+ (#error.Success value)
+
+ #.None
+ (ex.throw invalid-value class-name))
+
+ (#error.Error error)
+ (ex.throw cannot-load [class-name error]))
+
+ (#error.Error error)
+ (ex.throw invalid-field [class-name ..value-field])))
+
+(def: (eval store loader valueI)
+ (-> Store ClassLoader Inst (Error Any))
+ (do error.Monad<Error>
+ [#let [eval-class "eval"
+ bytecode (def.class #jvm.V1_6
+ #jvm.Public jvm.noneC
+ eval-class
+ (list) ["java.lang.Object" (list)]
+ (list)
+ (|>> (def.field #jvm.Public ($_ jvm.++F jvm.finalF jvm.staticF)
+ ..value-field ..$Object)
+ (def.method #jvm.Public ($_ jvm.++M jvm.staticM jvm.strictM)
+ "<clinit>"
+ (type.method (list) #.None (list))
+ (|>> valueI
+ (inst.PUTSTATIC eval-class ..value-field ..$Object)
+ inst.RETURN))))]
+ _ (..store! eval-class bytecode store)
+ class (..load! eval-class loader)]
+ (class-value eval-class class)))
+
+(def: (define store loader [class-name class-bytecode])
+ (-> Store ClassLoader Definition (Error Any))
+ (do error.Monad<Error>
+ [_ (..store! class-name class-bytecode store)
+ class (..load! class-name loader)]
+ (class-value class-name class)))
+
+(def: #export init
+ (IO State)
+ (io (let [store (: Store (atom (dictionary.new text.Hash<Text>)))
+ loader (memory-class-loader store)]
+ (translation.init (: Host
+ (structure
+ (def: evaluate! (..eval store loader))
+ (def: execute! (..define store loader))))))))
+
+(def: #export runtime-class "LuxRuntime")
+(def: #export function-class "LuxFunction")
+(def: #export runnable-class "LuxRunnable")
+(def: #export unit "")
diff --git a/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux
index e47e123ad..2aa0586ab 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux
@@ -1,22 +1,26 @@
(.module:
- lux
- (lux (control [monad #+ do]
- ["ex" exception #+ exception:])
- (data text/format)
- [macro "macro/" Monad<Meta>])
- (luxc ["_" lang]
- (lang [".L" host]
- (host ["$" jvm]
- (jvm ["$t" type]
- ["$i" inst]))
- ["ls" synthesis]))
- [//runtime])
-
-(def: $Object $.Type ($t.class "java.lang.Object" (list)))
+ [lux (#- if let case)
+ [control
+ [monad (#+ do)]
+ ["ex" exception (#+ exception:)]]
+ [data
+ [text
+ format]]
+ [language
+ ["." compiler ("operation/" Monad<Operation>)
+ ["." synthesis (#+ Path Synthesis)]]]]
+ [luxc
+ [lang
+ [host
+ ["$" jvm (#+ Label Inst Operation Compiler)
+ ["$t" type]
+ ["$i" inst]]]]]
+ ["." // (#+ $Object)
+ [runtime]])
(def: (pop-altI stack-depth)
- (-> Nat $.Inst)
- (case stack-depth
+ (-> Nat Inst)
+ (.case stack-depth
+0 id
+1 $i.POP
+2 $i.POP2
@@ -25,203 +29,201 @@
(pop-altI (n/- +2 stack-depth)))))
(def: peekI
- $.Inst
+ Inst
(|>> $i.DUP
- ($i.INVOKESTATIC hostL.runtime-class
+ ($i.INVOKESTATIC //.runtime-class
"pm_peek"
- ($t.method (list //runtime.$Stack)
+ ($t.method (list runtime.$Stack)
(#.Some $Object)
(list))
#0)))
(def: popI
- $.Inst
- (|>> ($i.INVOKESTATIC hostL.runtime-class
+ Inst
+ (|>> ($i.INVOKESTATIC //.runtime-class
"pm_pop"
- ($t.method (list //runtime.$Stack)
- (#.Some //runtime.$Stack)
+ ($t.method (list runtime.$Stack)
+ (#.Some runtime.$Stack)
(list))
#0)))
(def: pushI
- $.Inst
- (|>> ($i.INVOKESTATIC hostL.runtime-class
+ Inst
+ (|>> ($i.INVOKESTATIC //.runtime-class
"pm_push"
- ($t.method (list //runtime.$Stack $Object)
- (#.Some //runtime.$Stack)
+ ($t.method (list runtime.$Stack $Object)
+ (#.Some runtime.$Stack)
(list))
#0)))
-(exception: #export (Unrecognized-Path {message Text})
- message)
+(def: (path' translate stack-depth @else @end path)
+ (-> (-> Synthesis (Operation Inst))
+ Nat Label Label Path (Operation Inst))
+ (.case path
+ #synthesis.Pop
+ (operation/wrap popI)
+
+ (#synthesis.Bind register)
+ (operation/wrap (|>> peekI
+ ($i.ASTORE register)))
-(def: (translate-path' translate stack-depth @else @end path)
- (-> (-> ls.Synthesis (Meta $.Inst))
- Nat $.Label $.Label ls.Path (Meta $.Inst))
- (case path
- (^ [_ (#.Form (list [_ (#.Text "lux case exec")] bodyS))])
- (do macro.Monad<Meta>
+ (^ (synthesis.path/bit value))
+ (operation/wrap (.let [jumpI (.if value $i.IFEQ $i.IFNE)]
+ (|>> peekI
+ ($i.unwrap #$.Boolean)
+ (jumpI @else))))
+
+ (^ (synthesis.path/i64 value))
+ (operation/wrap (|>> peekI
+ ($i.unwrap #$.Long)
+ ($i.long value)
+ $i.LCMP
+ ($i.IFNE @else)))
+
+ (^ (synthesis.path/f64 value))
+ (operation/wrap (|>> peekI
+ ($i.unwrap #$.Double)
+ ($i.double value)
+ $i.DCMPL
+ ($i.IFNE @else)))
+
+ (^ (synthesis.path/text value))
+ (operation/wrap (|>> peekI
+ ($i.string value)
+ ($i.INVOKEVIRTUAL "java.lang.Object"
+ "equals"
+ ($t.method (list $Object)
+ (#.Some $t.boolean)
+ (list))
+ #0)
+ ($i.IFEQ @else)))
+
+ (#synthesis.Then bodyS)
+ (do compiler.Monad<Operation>
[bodyI (translate bodyS)]
(wrap (|>> (pop-altI stack-depth)
bodyI
($i.GOTO @end))))
-
- (^ [_ (#.Form (list [_ (#.Text "lux case pop")]))])
- (macro/wrap popI)
-
- (^ [_ (#.Form (list [_ (#.Text "lux case bind")] [_ (#.Nat register)]))])
- (macro/wrap (|>> peekI
- ($i.ASTORE register)))
-
- [_ (#.Bit value)]
- (macro/wrap (let [jumpI (if value $i.IFEQ $i.IFNE)]
- (|>> peekI
- ($i.unwrap #$.Boolean)
- (jumpI @else))))
-
- [_ (#.Int value)]
- (macro/wrap (|>> peekI
- ($i.unwrap #$.Long)
- ($i.long value)
- $i.LCMP
- ($i.IFNE @else)))
-
- [_ (#.Frac value)]
- (macro/wrap (|>> peekI
- ($i.unwrap #$.Double)
- ($i.double value)
- $i.DCMPL
- ($i.IFNE @else)))
- [_ (#.Text value)]
- (macro/wrap (|>> peekI
- ($i.string value)
- ($i.INVOKEVIRTUAL "java.lang.Object"
- "equals"
- ($t.method (list $Object)
- (#.Some $t.boolean)
- (list))
- #0)
- ($i.IFEQ @else)))
-
- (^template [<special> <method>]
- (^ [_ (#.Form (list [_ (#.Text <special>)] [_ (#.Nat idx)]))])
- (macro/wrap (case idx
- +0
- (|>> peekI
- ($i.CHECKCAST ($t.descriptor //runtime.$Tuple))
- ($i.int 0)
- $i.AALOAD
- pushI)
-
- _
- (|>> peekI
- ($i.CHECKCAST ($t.descriptor //runtime.$Tuple))
- ($i.int (.int idx))
- ($i.INVOKESTATIC hostL.runtime-class
- <method>
- ($t.method (list //runtime.$Tuple $t.int)
- (#.Some $Object)
- (list))
- #0)
- pushI))))
- (["lux case tuple left" "pm_left"]
- ["lux case tuple right" "pm_right"])
-
- (^template [<special> <flag>]
- (^ [_ (#.Form (list [_ (#.Text <special>)] [_ (#.Nat idx)]))])
- (macro/wrap (<| $i.with-label (function (_ @success))
- $i.with-label (function (_ @fail))
- (|>> peekI
- ($i.CHECKCAST ($t.descriptor //runtime.$Variant))
- ($i.int (.int idx))
- <flag>
- ($i.INVOKESTATIC hostL.runtime-class "pm_variant"
- ($t.method (list //runtime.$Variant //runtime.$Tag //runtime.$Flag)
- (#.Some //runtime.$Datum)
- (list))
- #0)
- $i.DUP
- ($i.IFNULL @fail)
- ($i.GOTO @success)
- ($i.label @fail)
- $i.POP
- ($i.GOTO @else)
- ($i.label @success)
- pushI))))
- (["lux case variant left" $i.NULL]
- ["lux case variant right" ($i.string "")])
- (^ [_ (#.Form (list [_ (#.Text "lux case seq")] leftP rightP))])
- (do macro.Monad<Meta>
- [leftI (translate-path' translate stack-depth @else @end leftP)
- rightI (translate-path' translate stack-depth @else @end rightP)]
- (wrap (|>> leftI
- rightI)))
-
- (^ [_ (#.Form (list [_ (#.Text "lux case alt")] leftP rightP))])
- (do macro.Monad<Meta>
+ (^template [<pattern> <method> <mod>]
+ (^ (<pattern> idx))
+ (operation/wrap (.case (<mod> idx)
+ +0
+ (|>> peekI
+ ($i.CHECKCAST ($t.descriptor runtime.$Tuple))
+ ($i.int 0)
+ $i.AALOAD
+ pushI)
+
+ idx
+ (|>> peekI
+ ($i.CHECKCAST ($t.descriptor runtime.$Tuple))
+ ($i.int (.int idx))
+ ($i.INVOKESTATIC //.runtime-class
+ <method>
+ ($t.method (list runtime.$Tuple $t.int)
+ (#.Some $Object)
+ (list))
+ #0)
+ pushI))))
+ ([synthesis.member/left "pm_left" .id]
+ [synthesis.member/right "pm_right" .inc])
+
+ (^template [<pattern> <flag> <mod>]
+ (^ (<pattern> idx))
+ (.let [idx (<mod> idx)]
+ (operation/wrap (<| $i.with-label (function (_ @success))
+ $i.with-label (function (_ @fail))
+ (|>> peekI
+ ($i.CHECKCAST ($t.descriptor runtime.$Variant))
+ ($i.int (.int idx))
+ <flag>
+ ($i.INVOKESTATIC //.runtime-class "pm_variant"
+ ($t.method (list runtime.$Variant runtime.$Tag runtime.$Flag)
+ (#.Some runtime.$Datum)
+ (list))
+ #0)
+ $i.DUP
+ ($i.IFNULL @fail)
+ ($i.GOTO @success)
+ ($i.label @fail)
+ $i.POP
+ ($i.GOTO @else)
+ ($i.label @success)
+ pushI)))))
+ ([synthesis.side/left $i.NULL .id]
+ [synthesis.side/right ($i.string "") .inc])
+
+ (#synthesis.Alt leftP rightP)
+ (do compiler.Monad<Operation>
[@alt-else $i.make-label
- leftI (translate-path' translate (inc stack-depth) @alt-else @end leftP)
- rightI (translate-path' translate stack-depth @else @end rightP)]
+ leftI (path' translate (inc stack-depth) @alt-else @end leftP)
+ rightI (path' translate stack-depth @else @end rightP)]
(wrap (|>> $i.DUP
leftI
($i.label @alt-else)
$i.POP
rightI)))
+
+ (#synthesis.Seq leftP rightP)
+ (do compiler.Monad<Operation>
+ [leftI (path' translate stack-depth @else @end leftP)
+ rightI (path' translate stack-depth @else @end rightP)]
+ (wrap (|>> leftI
+ rightI)))
+ ))
- _
- (_.throw Unrecognized-Path (%code path))))
-
-(def: (translate-path translate path @end)
- (-> (-> ls.Synthesis (Meta $.Inst))
- ls.Path $.Label (Meta $.Inst))
- (do macro.Monad<Meta>
+(def: (path translate path @end)
+ (-> Compiler Path Label (Operation Inst))
+ (do compiler.Monad<Operation>
[@else $i.make-label
- pathI (translate-path' translate +1 @else @end path)]
+ pathI (..path' translate +1 @else @end path)]
(wrap (|>> pathI
($i.label @else)
$i.POP
- ($i.INVOKESTATIC hostL.runtime-class
+ ($i.INVOKESTATIC //.runtime-class
"pm_fail"
($t.method (list) #.None (list))
#0)
$i.NULL
($i.GOTO @end)))))
-(def: #export (translate-if testI thenI elseI)
- (-> $.Inst $.Inst $.Inst $.Inst)
- (<| $i.with-label (function (_ @else))
- $i.with-label (function (_ @end))
- (|>> testI
- ($i.unwrap #$.Boolean)
- ($i.IFEQ @else)
- thenI
- ($i.GOTO @end)
- ($i.label @else)
- elseI
- ($i.label @end))))
+(def: #export (if translate testS thenS elseS)
+ (-> Compiler Synthesis Synthesis Synthesis (Operation Inst))
+ (do compiler.Monad<Operation>
+ [testI (translate testS)
+ thenI (translate thenS)
+ elseI (translate elseS)]
+ (wrap (<| $i.with-label (function (_ @else))
+ $i.with-label (function (_ @end))
+ (|>> testI
+ ($i.unwrap #$.Boolean)
+ ($i.IFEQ @else)
+ thenI
+ ($i.GOTO @end)
+ ($i.label @else)
+ elseI
+ ($i.label @end))))))
+
+(def: #export (let translate inputS register exprS)
+ (-> Compiler Synthesis Nat Synthesis (Operation Inst))
+ (do compiler.Monad<Operation>
+ [inputI (translate inputS)
+ exprI (translate exprS)]
+ (wrap (|>> inputI
+ ($i.ASTORE register)
+ exprI))))
-(def: #export (translate-case translate valueS path)
- (-> (-> ls.Synthesis (Meta $.Inst))
- ls.Synthesis ls.Path (Meta $.Inst))
- (do macro.Monad<Meta>
+(def: #export (case translate valueS path)
+ (-> Compiler Synthesis Path (Operation Inst))
+ (do compiler.Monad<Operation>
[@end $i.make-label
valueI (translate valueS)
- pathI (translate-path translate path @end)]
+ pathI (..path translate path @end)]
(wrap (|>> valueI
$i.NULL
$i.SWAP
pushI
pathI
($i.label @end)))))
-
-(def: #export (translate-let translate register inputS exprS)
- (-> (-> ls.Synthesis (Meta $.Inst))
- Nat ls.Synthesis ls.Synthesis (Meta $.Inst))
- (do macro.Monad<Meta>
- [inputI (translate inputS)
- exprI (translate exprS)]
- (wrap (|>> inputI
- ($i.ASTORE register)
- exprI))))
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>]
- 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 [<name>]
- [(exception: #export (<name> {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<Text>)
+ 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<Text>))
- (: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<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)
- (//.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<Text>))
+## (: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<Meta>
+## [_ (..store-class class-name def-bytecode)
+## class (..load-class class-name)]
+## (case (do error.Monad<Error>
+## [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))))))))
diff --git a/new-luxc/source/luxc/lang/translation/jvm/expression.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/expression.jvm.lux
index b6fed434e..ed2023476 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/expression.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/expression.jvm.lux
@@ -1,86 +1,67 @@
(.module:
- lux
- (lux (control monad
- ["ex" exception #+ exception:]
- ["p" parser])
- (data ["e" error]
- text/format)
- [macro]
- (macro ["s" syntax])
- ["//" lang]
- (lang ["//." reference #+ Register]
- ["//." synthesis #+ Synthesis]
- ["//." extension]))
- (luxc (lang (host ["$" jvm])))
- (// [".T" common]
- [".T" primitive]
- [".T" structure]
- [".T" eval]
- [".T" function]
- [".T" reference]
- [".T" case]
- [".T" procedure]))
-
-(do-template [<name>]
- [(exception: #export (<name> {message Text})
- message)]
-
- [Invalid-Function-Syntax]
- [Unrecognized-Synthesis]
- )
+ [lux #*
+ [language
+ [compiler
+ [synthesis (#+ Synthesis)]
+ [extension]]]]
+ [luxc
+ [lang
+ [host
+ ["_" jvm (#+ Compiler)]]]]
+ [//
+ ["." common]
+ ["." primitive]
+ ["." structure]
+ ["." reference]
+ ["." case]
+ ## ["." function]
+ ## ["." procedure]
+ ])
(def: #export (translate synthesis)
- (-> Synthesis (Meta $.Inst))
+ Compiler
(case synthesis
- (^ (//synthesis.bit value))
- (primitiveT.translate-bit value)
+ (^ (synthesis.bit value))
+ (primitive.bit value)
- (^ (//synthesis.i64 value))
- (primitiveT.translate-i64 value)
+ (^ (synthesis.i64 value))
+ (primitive.i64 value)
- (^ (//synthesis.f64 value))
- (primitiveT.translate-f64 value)
+ (^ (synthesis.f64 value))
+ (primitive.f64 value)
- (^ (//synthesis.text value))
- (primitiveT.translate-text value)
+ (^ (synthesis.text value))
+ (primitive.text value)
- (^code ((~ [_ (#.Nat tag)]) (~ [_ (#.Bit last?)]) (~ valueS)))
- (structureT.translate-variant translate tag last? valueS)
+ (^ (synthesis.variant [lefts right? value]))
+ (structure.variant translate lefts right? value)
- (^code [(~+ members)])
- (structureT.translate-tuple translate members)
+ (^ (synthesis.tuple members))
+ (structure.tuple translate members)
- (^ [_ (#.Form (list [_ (#.Int var)]))])
- (if (variableL.captured? var)
- (referenceT.translate-captured var)
- (referenceT.translate-local var))
+ (^ (synthesis.variable variable))
+ (reference.variable variable)
- [_ (#.Symbol definition)]
- (referenceT.translate-definition definition)
+ (^ (synthesis.constant constant))
+ (reference.constant constant)
- (^code ("lux let" (~ [_ (#.Nat register)]) (~ inputS) (~ exprS)))
- (caseT.translate-let translate register inputS exprS)
+ (^ (synthesis.branch/let [input register expr]))
+ (case.let translate input register expr)
- (^code ("lux case" (~ inputS) (~ pathPS)))
- (caseT.translate-case translate inputS pathPS)
+ (^ (synthesis.branch/if [test then else]))
+ (case.if translate test then else)
- (^code ("lux function" (~ [_ (#.Nat arity)]) [(~+ environment)] (~ bodyS)))
- (case (s.run environment (p.some s.int))
- (#e.Success environment)
- (functionT.translate-function translate environment arity bodyS)
+ (^ (synthesis.branch/case [input path]))
+ (case.case translate input path)
- _
- (//.throw Invalid-Function-Syntax (%code synthesis)))
+ ## (^code ("lux function" (~ [_ (#.Nat arity)]) [(~+ environment)] (~ bodyS)))
+ ## (function.translate-function translate environment arity bodyS)
- (^code ("lux call" (~ functionS) (~+ argsS)))
- (functionT.translate-call translate functionS argsS)
+ ## (^code ("lux call" (~ functionS) (~+ argsS)))
+ ## (function.translate-call translate functionS argsS)
- (^code ((~ [_ (#.Text procedure)]) (~+ argsS)))
- (procedureT.translate-procedure translate procedure argsS)
- ## (do macro.Monad<Meta>
- ## [translation (extensionL.find-translation procedure)]
- ## (translation argsS))
+ ## (^code ((~ [_ (#.Text extension)]) (~+ args)))
+ ## (extension.apply [extension args])
_
- (//.throw Unrecognized-Synthesis (%code synthesis))
- ))
+ (undefined)))
diff --git a/new-luxc/source/luxc/lang/translation/jvm/primitive.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/primitive.jvm.lux
index 250b0db52..f1d639b72 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/primitive.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/primitive.jvm.lux
@@ -1,29 +1,31 @@
(.module:
- lux
- (lux (control monad)
- (data text/format)
- [macro "macro/" Monad<Meta>])
- (luxc ["&" lang]
- (lang [".L" host]
- (host ["$" jvm]
- (jvm ["$i" inst]
- ["$t" type]))
- ["la" analysis]
- ["ls" synthesis]))
- (// [".T" common]))
+ [lux (#- i64)
+ [control
+ monad]
+ [data
+ [text
+ format]]
+ [language
+ [compiler ("operation/" Monad<Operation>)]]]
+ [luxc
+ [lang
+ [host
+ [jvm (#+ Inst Operation)
+ ["$i" inst]
+ ["$t" type]]]]])
-(def: #export (translate-bit value)
- (-> Bit (Meta $.Inst))
- (macro/wrap ($i.GETSTATIC "java.lang.Boolean"
- (if value "TRUE" "FALSE")
- ($t.class "java.lang.Boolean" (list)))))
+(def: #export (bit value)
+ (-> Bit (Operation Inst))
+ (operation/wrap ($i.GETSTATIC "java.lang.Boolean"
+ (if value "TRUE" "FALSE")
+ ($t.class "java.lang.Boolean" (list)))))
(do-template [<name> <type> <load> <wrap>]
[(def: #export (<name> value)
- (-> <type> (Meta $.Inst))
- (macro/wrap (|>> (<load> value) <wrap>)))]
+ (-> <type> (Operation Inst))
+ (operation/wrap (|>> (<load> value) <wrap>)))]
- [translate-i64 Int $i.long ($i.wrap #$.Long)]
- [translate-f64 Frac $i.double ($i.wrap #$.Double)]
- [translate-text Text $i.string id]
+ [i64 Int $i.long ($i.wrap #jvm.Long)]
+ [f64 Frac $i.double ($i.wrap #jvm.Double)]
+ [text Text $i.string (<|)]
)
diff --git a/new-luxc/source/luxc/lang/translation/jvm/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/reference.jvm.lux
index 9271efe8f..f82a674e3 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/reference.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/reference.jvm.lux
@@ -1,49 +1,55 @@
(.module:
- lux
- (lux (control [monad #+ do])
- (data [text "text/" Hash<Text>]
- text/format)
- [macro "macro/" Monad<Meta>])
- (luxc ["&" lang]
- (lang [".L" host]
- (host ["$" jvm]
- (jvm ["$t" type]
- ["$i" inst]))
- ["ls" synthesis]
- [".L" variable #+ Variable]))
- (// [".T" common]))
+ [lux #*
+ [control
+ [monad (#+ do)]]
+ [data
+ [text ("text/" Hash<Text>)
+ format]]
+ [language
+ ["." name]
+ ["." reference (#+ Register Variable)]
+ ["." compiler ("operation/" Monad<Operation>)
+ ["." translation]]]]
+ [luxc
+ [lang
+ [host
+ [jvm (#+ Inst Operation)
+ ["$t" type]
+ ["$i" inst]]]]]
+ ["." //])
(do-template [<name> <prefix>]
- [(def: #export (<name> idx)
+ [(def: (<name> idx)
(-> Nat Text)
(|> idx .int %i (format <prefix>)))]
- [captured "c"]
- [partial "p"]
+ [foreign-name "f"]
+ [partial-name "p"]
)
-(def: #export (translate-captured variable)
- (-> Variable (Meta $.Inst))
- (do macro.Monad<Meta>
- [this-module macro.current-module-name
- function-class hostL.context
- #let [function-class (format (text.replace-all "/" "." this-module) "." function-class)]]
+(def: (foreign variable)
+ (-> Register (Operation Inst))
+ (do compiler.Monad<Operation>
+ [function-class translation.context]
(wrap (|>> ($i.ALOAD +0)
($i.GETFIELD function-class
- (|> variable inc (i/* -1) .nat captured)
- commonT.$Object)))))
+ (|> variable .nat foreign-name)
+ //.$Object)))))
-(def: #export (translate-local variable)
- (-> Variable (Meta $.Inst))
- (macro/wrap ($i.ALOAD (.nat variable))))
+(def: local
+ (-> Register (Operation Inst))
+ (|>> $i.ALOAD operation/wrap))
-(def: #export (translate-variable variable)
- (-> Variable (Meta $.Inst))
- (if (variableL.captured? variable)
- (translate-captured variable)
- (translate-local variable)))
+(def: #export (variable variable)
+ (-> Variable (Operation Inst))
+ (case variable
+ (#reference.Local variable)
+ (local variable)
+
+ (#reference.Foreign variable)
+ (foreign variable)))
-(def: #export (translate-definition [def-module def-name])
- (-> Ident (Meta $.Inst))
- (let [bytecode-name (format def-module "/" (&.normalize-name def-name) (%n (text/hash def-name)))]
- (macro/wrap ($i.GETSTATIC bytecode-name commonT.value-field commonT.$Object))))
+(def: #export (constant [def-module def-name])
+ (-> Ident (Operation Inst))
+ (let [bytecode-name (format def-module "/" (name.normalize def-name) (%n (text/hash def-name)))]
+ (operation/wrap ($i.GETSTATIC bytecode-name //.value-field //.$Object))))
diff --git a/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux
index 0d37031e0..86fe53d1e 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux
@@ -1,19 +1,25 @@
(.module:
- lux
- (lux (control monad)
- (data text/format
- (coll [list "list/" Functor<List>]))
- [math]
- [macro])
- (luxc ["&" lang]
- (lang [".L" host]
- (host ["$" jvm]
- (jvm ["$t" type]
- ["$d" def]
- ["$i" inst]))
- ["la" analysis]
- ["ls" synthesis]))
- (// [".T" common]))
+ [lux #*
+ [control
+ [monad (#+ do)]]
+ [data
+ [text
+ format]
+ [collection
+ [list ("list/" Functor<List>)]]]
+ ["." math]
+ [language
+ ["." compiler
+ [analysis (#+ Arity)]
+ ["." translation]]]]
+ [luxc
+ [lang
+ [host
+ ["$" jvm (#+ Inst Method Def Operation)
+ ["$t" type]
+ ["$d" def]
+ ["$i" inst]]]]]
+ ["." // (#+ ByteCode)])
(def: $Object $.Type ($t.class "java.lang.Object" (list)))
(def: $Object-Array $.Type ($t.array +1 $Object))
@@ -24,28 +30,28 @@
(def: #export $Tag $.Type $t.int)
(def: #export $Flag $.Type $Object)
(def: #export $Datum $.Type $Object)
-(def: #export $Function $.Type ($t.class hostL.function-class (list)))
+(def: #export $Function $.Type ($t.class //.function-class (list)))
(def: $Throwable $.Type ($t.class "java.lang.Throwable" (list)))
(def: $Runtime $.Type ($t.class "java.lang.Runtime" (list)))
(def: $Runnable $.Type ($t.class "java.lang.Runnable" (list)))
(def: #export logI
- $.Inst
+ Inst
(let [outI ($i.GETSTATIC "java.lang.System" "out" ($t.class "java.io.PrintStream" (list)))
printI (function (_ method) ($i.INVOKEVIRTUAL "java.io.PrintStream" method ($t.method (list $Object) #.None (list)) #0))]
(|>> outI ($i.string "LOG: ") (printI "print")
outI $i.SWAP (printI "println"))))
(def: variant-method
- $.Method
+ Method
($t.method (list $t.int $Object $Object) (#.Some $Object-Array) (list)))
(def: #export variantI
- $.Inst
- ($i.INVOKESTATIC hostL.runtime-class "variant_make" variant-method #0))
+ Inst
+ ($i.INVOKESTATIC //.runtime-class "variant_make" variant-method #0))
(def: #export leftI
- $.Inst
+ Inst
(|>> ($i.int 0)
$i.NULL
$i.DUP2_X1
@@ -53,24 +59,24 @@
variantI))
(def: #export rightI
- $.Inst
+ Inst
(|>> ($i.int 1)
($i.string "")
$i.DUP2_X1
$i.POP2
variantI))
-(def: #export someI $.Inst rightI)
+(def: #export someI Inst rightI)
(def: #export noneI
- $.Inst
+ Inst
(|>> ($i.int 0)
$i.NULL
- ($i.string hostL.unit)
+ ($i.string //.unit)
variantI))
(def: (try-methodI unsafeI)
- (-> $.Inst $.Inst)
+ (-> Inst Inst)
(<| $i.with-label (function (_ @from))
$i.with-label (function (_ @to))
$i.with-label (function (_ @handler))
@@ -85,7 +91,7 @@
$i.ARETURN)))
(def: #export string-concatI
- $.Inst
+ Inst
($i.INVOKEVIRTUAL "java.lang.String" "concat" ($t.method (list $String) (#.Some $String) (list)) #0))
(def: #export partials-field Text "partials")
@@ -93,11 +99,11 @@
(def: #export num-apply-variants Nat +8)
(def: #export (apply-signature arity)
- (-> ls.Arity $.Method)
+ (-> Arity Method)
($t.method (list.repeat arity $Object) (#.Some $Object) (list)))
(def: adt-methods
- $.Def
+ Def
(let [store-tagI (|>> $i.DUP ($i.int 0) ($i.ILOAD +0) ($i.wrap #$.Int) $i.AASTORE)
store-flagI (|>> $i.DUP ($i.int 1) ($i.ALOAD +1) $i.AASTORE)
store-valueI (|>> $i.DUP ($i.int 2) ($i.ALOAD +2) $i.AASTORE)
@@ -115,7 +121,7 @@
on-null-objectI ($i.string "NULL")
arrayI (|>> ($i.ALOAD +0)
($i.CHECKCAST ($t.descriptor $Object-Array)))
- recurseI ($i.INVOKESTATIC hostL.runtime-class "force_text" force-textMT #0)
+ recurseI ($i.INVOKESTATIC //.runtime-class "force_text" force-textMT #0)
force-elemI (|>> $i.DUP arrayI $i.SWAP $i.AALOAD recurseI)
swap2 (|>> $i.DUP2_X2 ## X,Y => Y,X,Y
$i.POP2 ## Y,X,Y => Y,X
@@ -164,13 +170,13 @@
$i.ARETURN)))))
(def: #export force-textI
- $.Inst
- ($i.INVOKESTATIC hostL.runtime-class "force_text" ($t.method (list $Object) (#.Some $String) (list)) #0))
+ Inst
+ ($i.INVOKESTATIC //.runtime-class "force_text" ($t.method (list $Object) (#.Some $String) (list)) #0))
-(def: frac-shiftI $.Inst ($i.double (math.pow 32.0 2.0)))
+(def: frac-shiftI Inst ($i.double (math.pow 32.0 2.0)))
(def: frac-methods
- $.Def
+ Def
(|>> ($d.method #$.Public $.staticM "decode_frac" ($t.method (list $String) (#.Some $Object-Array) (list))
(try-methodI
(|>> ($i.ALOAD +0)
@@ -178,10 +184,10 @@
($i.wrap #$.Double))))
))
-(def: clz-method $.Method ($t.method (list $t.long) (#.Some $t.int) (list)))
+(def: clz-method Method ($t.method (list $t.long) (#.Some $t.int) (list)))
(def: text-methods
- $.Def
+ Def
(|>> ($d.method #$.Public $.staticM "text_clip" ($t.method (list $String $t.int $t.int) (#.Some $Variant) (list))
(try-methodI
(|>> ($i.ALOAD +0)
@@ -198,7 +204,7 @@
))
(def: pm-methods
- $.Def
+ Def
(let [tuple-sizeI (|>> ($i.ALOAD +0) $i.ARRAYLENGTH)
tuple-elemI (|>> ($i.ALOAD +0) ($i.ILOAD +1) $i.AALOAD)
expected-last-sizeI (|>> ($i.ILOAD +1) ($i.int 1) $i.IADD)
@@ -245,10 +251,10 @@
$i.with-label (function (_ @further))
$i.with-label (function (_ @shorten))
$i.with-label (function (_ @wrong))
- (let [variant-partI (: (-> Nat $.Inst)
+ (let [variant-partI (: (-> Nat Inst)
(function (_ idx)
(|>> ($i.int (.int idx)) $i.AALOAD)))
- tagI (: $.Inst
+ tagI (: Inst
(|>> (variant-partI +0) ($i.unwrap #$.Int)))
flagI (variant-partI +1)
datumI (variant-partI +2)
@@ -332,7 +338,7 @@
)))
(def: io-methods
- $.Def
+ Def
(let [string-writerI (|>> ($i.NEW "java.io.StringWriter")
$i.DUP
($i.INVOKESPECIAL "java.io.StringWriter" "<init>" ($t.method (list) #.None (list)) #0))
@@ -352,7 +358,7 @@
($i.label @from)
($i.ALOAD +0)
$i.NULL
- ($i.INVOKEVIRTUAL hostL.function-class apply-method (apply-signature +1) #0)
+ ($i.INVOKEVIRTUAL //.function-class apply-method (apply-signature +1) #0)
rightI
$i.ARETURN
($i.label @to)
@@ -367,19 +373,19 @@
)))
(def: process-methods
- $.Def
+ Def
(let [executor-class "java.util.concurrent.ScheduledThreadPoolExecutor"
executorT ($t.class executor-class (list))
executor-field "executor"
- endI (|>> ($i.string hostL.unit)
+ endI (|>> ($i.string //.unit)
$i.ARETURN)
- runnableI (: (-> $.Inst $.Inst)
+ runnableI (: (-> Inst Inst)
(function (_ functionI)
- (|>> ($i.NEW hostL.runnable-class)
+ (|>> ($i.NEW //.runnable-class)
$i.DUP
functionI
- ($i.INVOKESPECIAL hostL.runnable-class "<init>" ($t.method (list $Function) #.None (list)) #0))))
- threadI (: (-> $.Inst $.Inst)
+ ($i.INVOKESPECIAL //.runnable-class "<init>" ($t.method (list $Function) #.None (list)) #0))))
+ threadI (: (-> Inst Inst)
(function (_ runnableI)
(|>> ($i.NEW "java.lang.Thread")
$i.DUP
@@ -394,7 +400,7 @@
parallelism-levelI
($i.INVOKESPECIAL executor-class "<init>" ($t.method (list $t.int) #.None (list)) #0))]
(|>> executorI
- ($i.PUTSTATIC hostL.runtime-class executor-field executorT)
+ ($i.PUTSTATIC //.runtime-class executor-field executorT)
$i.RETURN)))
($d.method #$.Public $.staticM "schedule"
($t.method (list $t.long $Function) (#.Some $Object) (list))
@@ -405,7 +411,7 @@
time-unit-class "java.util.concurrent.TimeUnit"
time-unitT ($t.class time-unit-class (list))
futureT ($t.class "java.util.concurrent.ScheduledFuture" (list))
- executorI ($i.GETSTATIC hostL.runtime-class executor-field executorT)
+ executorI ($i.GETSTATIC //.runtime-class executor-field executorT)
schedule-laterI (|>> executorI
(runnableI ($i.ALOAD +2))
delayI
@@ -425,77 +431,74 @@
)))
(def: translate-runtime
- (Meta commonT.Bytecode)
- (do macro.Monad<Meta>
- [_ (wrap [])
- #let [bytecode ($d.class #$.V1_6 #$.Public $.finalC hostL.runtime-class (list) ["java.lang.Object" (list)] (list)
- (|>> adt-methods
- frac-methods
- text-methods
- pm-methods
- io-methods
- process-methods))]
- _ (commonT.store-class hostL.runtime-class bytecode)]
- (wrap bytecode)))
+ (Operation ByteCode)
+ (let [bytecode ($d.class #$.V1_6 #$.Public $.finalC //.runtime-class (list) ["java.lang.Object" (list)] (list)
+ (|>> adt-methods
+ frac-methods
+ text-methods
+ pm-methods
+ io-methods
+ process-methods))]
+ (do compiler.Monad<Operation>
+ [_ (translation.execute! [//.runtime-class bytecode])]
+ (wrap bytecode))))
(def: translate-function
- (Meta commonT.Bytecode)
- (do macro.Monad<Meta>
- [_ (wrap [])
- #let [applyI (|> (list.n/range +2 num-apply-variants)
- (list/map (function (_ arity)
- ($d.method #$.Public $.noneM apply-method (apply-signature arity)
- (let [preI (|> (list.n/range +0 (dec arity))
- (list/map $i.ALOAD)
- $i.fuse)]
- (|>> preI
- ($i.INVOKEVIRTUAL hostL.function-class apply-method (apply-signature (dec arity)) #0)
- ($i.CHECKCAST hostL.function-class)
- ($i.ALOAD arity)
- ($i.INVOKEVIRTUAL hostL.function-class apply-method (apply-signature +1) #0)
- $i.ARETURN)))))
- (list& ($d.abstract-method #$.Public $.noneM apply-method (apply-signature +1)))
- $d.fuse)
- bytecode ($d.abstract #$.V1_6 #$.Public $.noneC hostL.function-class (list) ["java.lang.Object" (list)] (list)
- (|>> ($d.field #$.Public $.finalF partials-field $t.int)
- ($d.method #$.Public $.noneM "<init>" ($t.method (list $t.int) #.None (list))
- (|>> ($i.ALOAD +0)
- ($i.INVOKESPECIAL "java.lang.Object" "<init>" ($t.method (list) #.None (list)) #0)
- ($i.ALOAD +0)
- ($i.ILOAD +1)
- ($i.PUTFIELD hostL.function-class partials-field $t.int)
- $i.RETURN))
- applyI))]
- _ (commonT.store-class hostL.function-class bytecode)]
- (wrap bytecode)))
-
-(def: translate-runnable
- (Meta commonT.Bytecode)
- (do macro.Monad<Meta>
- [_ (wrap [])
- #let [procedure-field "procedure"
- bytecode ($d.class #$.V1_6 #$.Public $.finalC hostL.runnable-class (list) ["java.lang.Object" (list)] (list ["java.lang.Runnable" (list)])
- (|>> ($d.field #$.Public $.finalF procedure-field $Function)
- ($d.method #$.Public $.noneM "<init>" ($t.method (list $Function) #.None (list))
+ (Operation ByteCode)
+ (let [applyI (|> (list.n/range +2 num-apply-variants)
+ (list/map (function (_ arity)
+ ($d.method #$.Public $.noneM apply-method (apply-signature arity)
+ (let [preI (|> (list.n/range +0 (dec arity))
+ (list/map $i.ALOAD)
+ $i.fuse)]
+ (|>> preI
+ ($i.INVOKEVIRTUAL //.function-class apply-method (apply-signature (dec arity)) #0)
+ ($i.CHECKCAST //.function-class)
+ ($i.ALOAD arity)
+ ($i.INVOKEVIRTUAL //.function-class apply-method (apply-signature +1) #0)
+ $i.ARETURN)))))
+ (list& ($d.abstract-method #$.Public $.noneM apply-method (apply-signature +1)))
+ $d.fuse)
+ bytecode ($d.abstract #$.V1_6 #$.Public $.noneC //.function-class (list) ["java.lang.Object" (list)] (list)
+ (|>> ($d.field #$.Public $.finalF partials-field $t.int)
+ ($d.method #$.Public $.noneM "<init>" ($t.method (list $t.int) #.None (list))
(|>> ($i.ALOAD +0)
($i.INVOKESPECIAL "java.lang.Object" "<init>" ($t.method (list) #.None (list)) #0)
($i.ALOAD +0)
- ($i.ALOAD +1)
- ($i.PUTFIELD hostL.runnable-class procedure-field $Function)
- $i.RETURN))
- ($d.method #$.Public $.noneM "run" ($t.method (list) #.None (list))
- (|>> ($i.ALOAD +0)
- ($i.GETFIELD hostL.runnable-class procedure-field $Function)
- $i.NULL
- ($i.INVOKEVIRTUAL hostL.function-class apply-method (apply-signature +1) #0)
+ ($i.ILOAD +1)
+ ($i.PUTFIELD //.function-class partials-field $t.int)
$i.RETURN))
- ))]
- _ (commonT.store-class hostL.runnable-class bytecode)]
- (wrap bytecode)))
+ applyI))]
+ (do compiler.Monad<Operation>
+ [_ (translation.execute! [//.function-class bytecode])]
+ (wrap bytecode))))
+
+(def: translate-runnable
+ (Operation ByteCode)
+ (let [procedure-field "procedure"
+ bytecode ($d.class #$.V1_6 #$.Public $.finalC //.runnable-class (list) ["java.lang.Object" (list)] (list ["java.lang.Runnable" (list)])
+ (|>> ($d.field #$.Public $.finalF procedure-field $Function)
+ ($d.method #$.Public $.noneM "<init>" ($t.method (list $Function) #.None (list))
+ (|>> ($i.ALOAD +0)
+ ($i.INVOKESPECIAL "java.lang.Object" "<init>" ($t.method (list) #.None (list)) #0)
+ ($i.ALOAD +0)
+ ($i.ALOAD +1)
+ ($i.PUTFIELD //.runnable-class procedure-field $Function)
+ $i.RETURN))
+ ($d.method #$.Public $.noneM "run" ($t.method (list) #.None (list))
+ (|>> ($i.ALOAD +0)
+ ($i.GETFIELD //.runnable-class procedure-field $Function)
+ $i.NULL
+ ($i.INVOKEVIRTUAL //.function-class apply-method (apply-signature +1) #0)
+ $i.RETURN))
+ ))]
+ (do compiler.Monad<Operation>
+ [_ (translation.execute! [//.runnable-class bytecode])]
+ (wrap bytecode))))
(def: #export translate
- (Meta [commonT.Bytecode commonT.Bytecode commonT.Bytecode])
- (do macro.Monad<Meta>
+ (Operation [ByteCode ByteCode ByteCode])
+ (do compiler.Monad<Operation>
[runtime-bc translate-runtime
function-bc translate-function
runnable-bc translate-runnable]
diff --git a/new-luxc/source/luxc/lang/translation/jvm/structure.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/structure.jvm.lux
index 8b636b1cf..bc4a3cb95 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/structure.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/structure.jvm.lux
@@ -1,32 +1,36 @@
(.module:
- lux
- (lux (control [monad #+ do]
- ["ex" exception #+ exception:])
- (data text/format
- (coll [list]))
- [macro]
- [host #+ do-to])
- (luxc ["&" lang]
- (lang [".L" host]
- (host ["$" jvm]
- (jvm ["$t" type]
- ["$d" def]
- ["$i" inst]))
- ["la" analysis]
- ["ls" synthesis]))
- (// [".T" common]))
+ [lux #*
+ [control
+ [monad (#+ do)]
+ ["ex" exception (#+ exception:)]]
+ [data
+ [text
+ format]
+ [collection
+ ["." list]]]
+ [language
+ ["." compiler
+ [synthesis (#+ Synthesis)]]]]
+ [luxc
+ [lang
+ [host
+ ["." jvm (#+ Inst Operation Compiler)
+ ["$t" type]
+ ["$i" inst]]]]]
+ [//])
-(exception: #export (Not-A-Tuple {message Text})
- message)
+(exception: #export (not-a-tuple {size Nat})
+ (ex.report ["Expected size" ">= 2"]
+ ["Actual size" (%n size)]))
-(def: $Object $.Type ($t.class "java.lang.Object" (list)))
+(def: $Object jvm.Type ($t.class "java.lang.Object" (list)))
-(def: #export (translate-tuple translate members)
- (-> (-> ls.Synthesis (Meta $.Inst)) (List ls.Synthesis) (Meta $.Inst))
- (do macro.Monad<Meta>
+(def: #export (tuple translate members)
+ (-> Compiler (List Synthesis) (Operation Inst))
+ (do compiler.Monad<Operation>
[#let [size (list.size members)]
- _ (&.assert Not-A-Tuple (%code (` [(~+ members)]))
- (n/>= +2 size))
+ _ (compiler.assert not-a-tuple size
+ (n/>= +2 size))
membersI (|> members
list.enumerate
(monad.map @ (function (_ [idx member])
@@ -42,19 +46,19 @@
membersI))))
(def: (flagI tail?)
- (-> Bit $.Inst)
+ (-> Bit Inst)
(if tail?
($i.string "")
$i.NULL))
-(def: #export (translate-variant translate tag tail? member)
- (-> (-> ls.Synthesis (Meta $.Inst)) Nat Bit ls.Synthesis (Meta $.Inst))
- (do macro.Monad<Meta>
+(def: #export (variant translate tag tail? member)
+ (-> Compiler Nat Bit Synthesis (Operation Inst))
+ (do compiler.Monad<Operation>
[memberI (translate member)]
(wrap (|>> ($i.int (.int tag))
(flagI tail?)
memberI
- ($i.INVOKESTATIC hostL.runtime-class
+ ($i.INVOKESTATIC //.runtime-class
"variant_make"
($t.method (list $t.int $Object $Object)
(#.Some ($t.array +1 $Object))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-25 17:01:23 +0000