(;module: lux (lux (data [text] text/format [product] (coll ["a" array] [list "L/" Functor])) [host #+ jvm-import do-to]) ["$" ..] (.. ["$t" type])) ## [Host] (jvm-import #long java.lang.Object) (jvm-import #long java.lang.String) (jvm-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) ) (jvm-import org.objectweb.asm.FieldVisitor (visitEnd [] void)) (jvm-import org.objectweb.asm.MethodVisitor (visitCode [] void) (visitMaxs [int int] void) (visitEnd [] void)) (jvm-import org.objectweb.asm.ClassWriter (#static COMPUTE_MAXS 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 [] Byte-Array)) ## [Defs] (def: (string-array values) (-> (List Text) (a;Array Text)) (let [output (host;array String (list;size values))] (exec (L/map (function [[idx value]] (host;array-store idx value output)) (list;enumerate values)) output))) (def: exceptions-array (-> $;Method (a;Array Text)) (|>. (get@ #$;exceptions) (L/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.+ Opcodes.ACC_STRICT (if (get@ #$;staticM config) Opcodes.ACC_STATIC 0) (if (get@ #$;finalM config) Opcodes.ACC_FINAL 0) (if (get@ #$;synchronizedM config) Opcodes.ACC_SYNCHRONIZED 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 (L/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 (L/map formal-param) (text;join-with "")) ">"))] (format formal-params (|> super class-to-type $t;signature) (|> interfaces (L/map (|>. class-to-type $t;signature)) (text;join-with ""))))) (do-template [ ] [(def: #export ( version visibility config name parameters super interfaces definitions) (-> $;Version $;Visibility $;Class-Config Text (List $;Parameter) $;Class (List $;Class) $;Def host;Byte-Array) (let [writer (|> (do-to (ClassWriter.new ClassWriter.COMPUTE_MAXS) (ClassWriter.visit [(version-flag version) ($_ i.+ Opcodes.ACC_SUPER (visibility-flag visibility) (class-flags config)) ($t;binary-name name) (parameters-signature parameters super interfaces) (|> super product;left $t;binary-name) (|> interfaces (L/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;Byte-Array) (let [writer (|> (do-to (ClassWriter.new ClassWriter.COMPUTE_MAXS) (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 (L/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 [ ] [(def: #export ( visibility config name value) (-> $;Visibility $;Field-Config Text $;Def) (function [writer] (let [=field (do-to (ClassWriter.visitField [($_ i.+ (visibility-flag visibility) (field-flags config)) ($t;binary-name name) ($t;descriptor ) ($t;signature ) ( 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 Real $t;float host;d2f] [double-field Real $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) (. head (fuse tail))))