diff options
author | Eduardo Julian | 2017-11-15 19:51:33 -0400 |
---|---|---|
committer | Eduardo Julian | 2017-11-15 19:51:33 -0400 |
commit | 296d087530cb142efec1dea159770346bb43c3c0 (patch) | |
tree | bde43594e5df48af539a0fda3e13cbf6aa36b557 /new-luxc/source/luxc/lang/host/jvm/def.lux | |
parent | c4e928e5805054aa12da40baaeccbb9c522b52d0 (diff) |
- Heavy refactoring.
Diffstat (limited to 'new-luxc/source/luxc/lang/host/jvm/def.lux')
-rw-r--r-- | new-luxc/source/luxc/lang/host/jvm/def.lux | 288 |
1 files changed, 288 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/lang/host/jvm/def.lux b/new-luxc/source/luxc/lang/host/jvm/def.lux new file mode 100644 index 000000000..60009fb5c --- /dev/null +++ b/new-luxc/source/luxc/lang/host/jvm/def.lux @@ -0,0 +1,288 @@ +(;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))) |