aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/host/jvm/def.lux
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/host/jvm/def.lux')
-rw-r--r--new-luxc/source/luxc/host/jvm/def.lux287
1 files changed, 287 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/host/jvm/def.lux b/new-luxc/source/luxc/host/jvm/def.lux
new file mode 100644
index 000000000..1d50ba9f6
--- /dev/null
+++ b/new-luxc/source/luxc/host/jvm/def.lux
@@ -0,0 +1,287 @@
+(;module:
+ lux
+ (lux (data [text]
+ text/format
+ [product]
+ (coll ["a" array]
+ [list "list/" Functor<List>]))
+ [host #+ do-to])
+ ["$" ..]
+ (.. ["$t" type]))
+
+## [Host]
+(host;import #long java.lang.Object)
+(host;import #long java.lang.String)
+
+(host;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)
+ )
+
+(host;import org.objectweb.asm.FieldVisitor
+ (visitEnd [] void))
+
+(host;import org.objectweb.asm.MethodVisitor
+ (visitCode [] void)
+ (visitMaxs [int int] void)
+ (visitEnd [] void))
+
+(host;import org.objectweb.asm.ClassWriter
+ (#static COMPUTE_MAXS int)
+ (#static COMPUTE_FRAMES int)
+ (new [int])
+ (visit [int int String String String (Array String)] void)
+ (visitEnd [] void)
+ (visitField [int String String String Object] FieldVisitor)
+ (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))]
+ (exec (list/map (function [[idx value]]
+ (host;array-write idx value output))
+ (list;enumerate values))
+ output)))
+
+(def: exceptions-array
+ (-> $;Method (Array Text))
+ (|>. (get@ #$;exceptions)
+ (list/map (|>. #$;Generic $t;descriptor))
+ string-array))
+
+(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: class-to-type
+ (-> $;Class $;Type)
+ (|>. #$;Class #$;Generic))
+
+(def: param-signature
+ (-> $;Class Text)
+ (|>. class-to-type $t;signature (format ":")))
+
+(def: (formal-param [name super interfaces])
+ (-> $;Parameter Text)
+ (format name
+ (param-signature super)
+ (|> interfaces
+ (list/map param-signature)
+ (text;join-with ""))))
+
+(def: (parameters-signature parameters super interfaces)
+ (-> (List $;Parameter) $;Class (List $;Class)
+ Text)
+ (let [formal-params (if (list;empty? parameters)
+ ""
+ (format "<"
+ (|> parameters
+ (list/map formal-param)
+ (text;join-with ""))
+ ">"))]
+ (format formal-params
+ (|> super class-to-type $t;signature)
+ (|> interfaces
+ (list/map (|>. class-to-type $t;signature))
+ (text;join-with "")))))
+
+(def: class-computes
+ Int
+ ($_ i.+
+ ClassWriter.COMPUTE_MAXS
+ ClassWriter.COMPUTE_FRAMES))
+
+(do-template [<name> <flag>]
+ [(def: #export (<name> version visibility config name parameters super interfaces
+ definitions)
+ (-> $;Version $;Visibility $;Class-Config Text (List $;Parameter) $;Class (List $;Class) $;Def
+ (host;type (Array 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))
+ ($t;binary-name name)
+ (parameters-signature parameters super interfaces)
+ (|> super product;left $t;binary-name)
+ (|> interfaces
+ (list/map (|>. product;left $t;binary-name))
+ string-array)]))
+ definitions)
+ _ (ClassWriter.visitEnd [] writer)]
+ (ClassWriter.toByteArray [] writer)))]
+
+ [class 0]
+ [abstract Opcodes.ACC_ABSTRACT]
+ )
+
+(def: $Object $;Class ["java.lang.Object" (list)])
+
+(def: #export (interface version visibility config name parameters interfaces
+ definitions)
+ (-> $;Version $;Visibility $;Class-Config Text (List $;Parameter) (List $;Class) $;Def
+ (host;type (Array 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))
+ ($t;binary-name name)
+ (parameters-signature parameters $Object interfaces)
+ (|> $Object product;left $t;binary-name)
+ (|> interfaces
+ (list/map (|>. product;left $t;binary-name))
+ string-array)]))
+ definitions)
+ _ (ClassWriter.visitEnd [] writer)]
+ (ClassWriter.toByteArray [] writer)))
+
+(def: #export (method visibility config name type then)
+ (-> $;Visibility $;Method-Config Text $;Method $;Inst
+ $;Def)
+ (function [writer]
+ (let [=method (ClassWriter.visitMethod [($_ i.+
+ (visibility-flag visibility)
+ (method-flags config))
+ ($t;binary-name name)
+ ($t;method-descriptor type)
+ ($t;method-signature type)
+ (exceptions-array type)]
+ 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 $;Method
+ $;Def)
+ (function [writer]
+ (let [=method (ClassWriter.visitMethod [($_ i.+
+ (visibility-flag visibility)
+ (method-flags config)
+ Opcodes.ACC_ABSTRACT)
+ ($t;binary-name name)
+ ($t;method-descriptor type)
+ ($t;method-signature type)
+ (exceptions-array type)]
+ writer)
+ _ (MethodVisitor.visitEnd [] =method)]
+ writer)))
+
+(def: #export (field visibility config name type)
+ (-> $;Visibility $;Field-Config Text $;Type $;Def)
+ (function [writer]
+ (let [=field (do-to (ClassWriter.visitField [($_ i.+
+ (visibility-flag visibility)
+ (field-flags config))
+ ($t;binary-name name)
+ ($t;descriptor type)
+ ($t;signature type)
+ (host;null)] writer)
+ (FieldVisitor.visitEnd []))]
+ writer)))
+
+(do-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))
+ ($t;binary-name name)
+ ($t;descriptor <jvm-type>)
+ ($t;signature <jvm-type>)
+ (<prepare> value)]
+ writer)
+ (FieldVisitor.visitEnd []))]
+ writer)))]
+
+ [boolean-field Bool $t;boolean id]
+ [byte-field Int $t;byte host;l2b]
+ [short-field Int $t;short host;l2s]
+ [int-field Int $t;int host;l2i]
+ [long-field Int $t;long id]
+ [float-field Frac $t;float host;d2f]
+ [double-field Frac $t;double id]
+ [char-field Nat $t;char (|>. nat-to-int host;l2i host;i2c)]
+ [string-field Text ($t;class "java.lang.String" (list)) id]
+ )
+
+(def: #export (fuse defs)
+ (-> (List $;Def) $;Def)
+ (case defs
+ #;Nil
+ id
+
+ (#;Cons singleton #;Nil)
+ singleton
+
+ (#;Cons head tail)
+ (. (fuse tail) head)))
generated by cgit v1.2.3 (git 2.25.1) at 2024-08-24 04:45:29 +0000