aboutsummaryrefslogtreecommitdiff
path: root/lux-jvm/source/luxc/lang/host/jvm/def.lux
diff options
context:
space:
mode:
Diffstat (limited to 'lux-jvm/source/luxc/lang/host/jvm/def.lux')
-rw-r--r--lux-jvm/source/luxc/lang/host/jvm/def.lux298
1 files changed, 298 insertions, 0 deletions
diff --git a/lux-jvm/source/luxc/lang/host/jvm/def.lux b/lux-jvm/source/luxc/lang/host/jvm/def.lux
new file mode 100644
index 000000000..f274da61f
--- /dev/null
+++ b/lux-jvm/source/luxc/lang/host/jvm/def.lux
@@ -0,0 +1,298 @@
+(.module:
+ [lux (#- Type)
+ ["." host (#+ import: do-to)]
+ [control
+ ["." function]]
+ [data
+ ["." product]
+ [number
+ ["i" int]]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." array (#+ Array)]
+ ["." list ("#@." functor)]]]
+ [target
+ [jvm
+ [encoding
+ ["." name]]
+ ["." type (#+ Type Constraint)
+ [category (#+ Class Value Method)]
+ ["." signature]
+ ["." descriptor]]]]]
+ ["." //])
+
+(def: signature (|>> type.signature signature.signature))
+(def: descriptor (|>> type.descriptor descriptor.descriptor))
+(def: class-name (|>> type.descriptor descriptor.class-name name.read))
+
+(import: #long java/lang/Object)
+(import: #long java/lang/String)
+
+(import: org/objectweb/asm/Opcodes
+ (#static ACC_PUBLIC int)
+ (#static ACC_PROTECTED int)
+ (#static ACC_PRIVATE int)
+
+ (#static ACC_TRANSIENT int)
+ (#static ACC_VOLATILE int)
+
+ (#static ACC_ABSTRACT int)
+ (#static ACC_FINAL int)
+ (#static ACC_STATIC int)
+ (#static ACC_SYNCHRONIZED int)
+ (#static ACC_STRICT int)
+
+ (#static ACC_SUPER int)
+ (#static ACC_INTERFACE int)
+
+ (#static V1_1 int)
+ (#static V1_2 int)
+ (#static V1_3 int)
+ (#static V1_4 int)
+ (#static V1_5 int)
+ (#static V1_6 int)
+ (#static V1_7 int)
+ (#static V1_8 int)
+ )
+
+(import: org/objectweb/asm/FieldVisitor
+ (visitEnd [] void))
+
+(import: org/objectweb/asm/MethodVisitor
+ (visitCode [] void)
+ (visitMaxs [int int] void)
+ (visitEnd [] void))
+
+(import: org/objectweb/asm/ClassWriter
+ (#static COMPUTE_MAXS int)
+ (#static COMPUTE_FRAMES int)
+ (new [int])
+ (visit [int int String String String [String]] void)
+ (visitEnd [] void)
+ (visitField [int String String String Object] FieldVisitor)
+ (visitMethod [int String String String [String]] MethodVisitor)
+ (toByteArray [] [byte]))
+
+(def: (string-array values)
+ (-> (List Text) (Array Text))
+ (let [output (host.array String (list.size values))]
+ (exec (list@map (function (_ [idx value])
+ (host.array-write idx value output))
+ (list.enumerate values))
+ output)))
+
+(def: (version-flag version)
+ (-> //.Version Int)
+ (case version
+ #//.V1_1 (Opcodes::V1_1)
+ #//.V1_2 (Opcodes::V1_2)
+ #//.V1_3 (Opcodes::V1_3)
+ #//.V1_4 (Opcodes::V1_4)
+ #//.V1_5 (Opcodes::V1_5)
+ #//.V1_6 (Opcodes::V1_6)
+ #//.V1_7 (Opcodes::V1_7)
+ #//.V1_8 (Opcodes::V1_8)))
+
+(def: (visibility-flag visibility)
+ (-> //.Visibility Int)
+ (case visibility
+ #//.Public (Opcodes::ACC_PUBLIC)
+ #//.Protected (Opcodes::ACC_PROTECTED)
+ #//.Private (Opcodes::ACC_PRIVATE)
+ #//.Default +0))
+
+(def: (class-flags config)
+ (-> //.Class-Config Int)
+ ($_ i.+
+ (if (get@ #//.finalC config) (Opcodes::ACC_FINAL) +0)))
+
+(def: (method-flags config)
+ (-> //.Method-Config Int)
+ ($_ i.+
+ (if (get@ #//.staticM config) (Opcodes::ACC_STATIC) +0)
+ (if (get@ #//.finalM config) (Opcodes::ACC_FINAL) +0)
+ (if (get@ #//.synchronizedM config) (Opcodes::ACC_SYNCHRONIZED) +0)
+ (if (get@ #//.strictM config) (Opcodes::ACC_STRICT) +0)))
+
+(def: (field-flags config)
+ (-> //.Field-Config Int)
+ ($_ i.+
+ (if (get@ #//.staticF config) (Opcodes::ACC_STATIC) +0)
+ (if (get@ #//.finalF config) (Opcodes::ACC_FINAL) +0)
+ (if (get@ #//.transientF config) (Opcodes::ACC_TRANSIENT) +0)
+ (if (get@ #//.volatileF config) (Opcodes::ACC_VOLATILE) +0)))
+
+(def: param-signature
+ (-> (Type Class) Text)
+ (|>> ..signature (format ":")))
+
+(def: (formal-param [name super interfaces])
+ (-> Constraint Text)
+ (format name
+ (param-signature super)
+ (|> interfaces
+ (list@map param-signature)
+ (text.join-with ""))))
+
+(def: (constraints-signature constraints super interfaces)
+ (-> (List Constraint) (Type Class) (List (Type Class))
+ Text)
+ (let [formal-params (if (list.empty? constraints)
+ ""
+ (format "<"
+ (|> constraints
+ (list@map formal-param)
+ (text.join-with ""))
+ ">"))]
+ (format formal-params
+ (..signature super)
+ (|> interfaces
+ (list@map ..signature)
+ (text.join-with "")))))
+
+(def: class-computes
+ Int
+ ($_ i.+
+ (ClassWriter::COMPUTE_MAXS)
+ ## (ClassWriter::COMPUTE_FRAMES)
+ ))
+
+(def: binary-name (|>> name.internal name.read))
+
+(template [<name> <flag>]
+ [(def: #export (<name> version visibility config name constraints super interfaces
+ definitions)
+ (-> //.Version //.Visibility //.Class-Config Text (List Constraint) (Type Class) (List (Type Class)) //.Def
+ (host.type [byte]))
+ (let [writer (|> (do-to (ClassWriter::new class-computes)
+ (ClassWriter::visit (version-flag version)
+ ($_ i.+
+ (Opcodes::ACC_SUPER)
+ <flag>
+ (visibility-flag visibility)
+ (class-flags config))
+ (..binary-name name)
+ (constraints-signature constraints super interfaces)
+ (..class-name super)
+ (|> interfaces
+ (list@map ..class-name)
+ string-array)))
+ definitions)
+ _ (ClassWriter::visitEnd writer)]
+ (ClassWriter::toByteArray writer)))]
+
+ [class +0]
+ [abstract (Opcodes::ACC_ABSTRACT)]
+ )
+
+(def: $Object
+ (Type Class)
+ (type.class "java.lang.Object" (list)))
+
+(def: #export (interface version visibility config name constraints interfaces
+ definitions)
+ (-> //.Version //.Visibility //.Class-Config Text (List Constraint) (List (Type Class)) //.Def
+ (host.type [byte]))
+ (let [writer (|> (do-to (ClassWriter::new class-computes)
+ (ClassWriter::visit (version-flag version)
+ ($_ i.+
+ (Opcodes::ACC_SUPER)
+ (Opcodes::ACC_INTERFACE)
+ (visibility-flag visibility)
+ (class-flags config))
+ (..binary-name name)
+ (constraints-signature constraints $Object interfaces)
+ (..class-name $Object)
+ (|> interfaces
+ (list@map ..class-name)
+ string-array)))
+ definitions)
+ _ (ClassWriter::visitEnd writer)]
+ (ClassWriter::toByteArray writer)))
+
+(def: #export (method visibility config name type then)
+ (-> //.Visibility //.Method-Config Text (Type Method) //.Inst
+ //.Def)
+ (function (_ writer)
+ (let [=method (ClassWriter::visitMethod ($_ i.+
+ (visibility-flag visibility)
+ (method-flags config))
+ (..binary-name name)
+ (..descriptor type)
+ (..signature type)
+ (string-array (list))
+ writer)
+ _ (MethodVisitor::visitCode =method)
+ _ (then =method)
+ _ (MethodVisitor::visitMaxs +0 +0 =method)
+ _ (MethodVisitor::visitEnd =method)]
+ writer)))
+
+(def: #export (abstract-method visibility config name type)
+ (-> //.Visibility //.Method-Config Text (Type Method)
+ //.Def)
+ (function (_ writer)
+ (let [=method (ClassWriter::visitMethod ($_ i.+
+ (visibility-flag visibility)
+ (method-flags config)
+ (Opcodes::ACC_ABSTRACT))
+ (..binary-name name)
+ (..descriptor type)
+ (..signature type)
+ (string-array (list))
+ writer)
+ _ (MethodVisitor::visitEnd =method)]
+ writer)))
+
+(def: #export (field visibility config name type)
+ (-> //.Visibility //.Field-Config Text (Type Value) //.Def)
+ (function (_ writer)
+ (let [=field (do-to (ClassWriter::visitField ($_ i.+
+ (visibility-flag visibility)
+ (field-flags config))
+ (..binary-name name)
+ (..descriptor type)
+ (..signature type)
+ (host.null)
+ writer)
+ (FieldVisitor::visitEnd))]
+ writer)))
+
+(template [<name> <lux-type> <jvm-type> <prepare>]
+ [(def: #export (<name> visibility config name value)
+ (-> //.Visibility //.Field-Config Text <lux-type> //.Def)
+ (function (_ writer)
+ (let [=field (do-to (ClassWriter::visitField ($_ i.+
+ (visibility-flag visibility)
+ (field-flags config))
+ (..binary-name name)
+ (..descriptor <jvm-type>)
+ (..signature <jvm-type>)
+ (<prepare> value)
+ writer)
+ (FieldVisitor::visitEnd))]
+ writer)))]
+
+ [boolean-field Bit type.boolean function.identity]
+ [byte-field Int type.byte host.long-to-byte]
+ [short-field Int type.short host.long-to-short]
+ [int-field Int type.int host.long-to-int]
+ [long-field Int type.long function.identity]
+ [float-field Frac type.float host.double-to-float]
+ [double-field Frac type.double function.identity]
+ [char-field Nat type.char (|>> .int host.long-to-int host.int-to-char)]
+ [string-field Text (type.class "java.lang.String" (list)) function.identity]
+ )
+
+(def: #export (fuse defs)
+ (-> (List //.Def) //.Def)
+ (case defs
+ #.Nil
+ function.identity
+
+ (#.Cons singleton #.Nil)
+ singleton
+
+ (#.Cons head tail)
+ (function.compose (fuse tail) head)))
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-05 01:03:10 +0000