aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/lang/host
diff options
context:
space:
mode:
Diffstat (limited to '')
-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
5 files changed, 117 insertions, 272 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)
generated by cgit v1.2.3 (git 2.25.1) at 2024-08-27 21:17:08 +0000