(.module: [library [lux {"-" [Type static local]} ["[0]" ffi {"+" [Inheritance Privacy State import:]}] [abstract ["[0]" monad {"+" [do]}]] [control [pipe {"+" [case>]}] ["[0]" try {"+" [Try]}] ["<>" parser ["<[0]>" code {"+" [Parser]}] ["<[0]>" text]]] [data [identity {"+" [Identity]}] [binary {"+" [Binary]}] ["[0]" product] [text ["%" format {"+" [format]}]] [collection [array {"+" [Array]}] ["[0]" list ("[1]#[0]" mix functor monoid)] ["[0]" dictionary {"+" [Dictionary]}] ["[0]" row {"+" [Row]} ("[1]#[0]" functor mix)]]] [math [number ["[0]" nat]]] [target ["/" jvm [encoding ["[0]" name {"+" [External]}]] ["[1][0]" type {"+" [Type Constraint]} [category {"+" [Void Value Return Primitive Object Class Var Parameter]}] ["[0]" parser] ["[0]T" lux] ["[1]/[0]" signature] ["[1]/[0]" descriptor]]]] [tool [compiler ["[0]" phase] [language [lux ["[0]" analysis {"+" [Analysis]}] ["[0]" synthesis {"+" [Synthesis]}] ["[0]" generation] ["[0]" directive {"+" [Requirements]}] [phase [analysis ["[0]A" scope] ["[0]A" type]] ["[0]" extension ["[0]" bundle] [analysis ["//A" jvm]] [directive ["[0]/" lux]]]]]] [meta [archive {"+" [Archive]}]]]]]] [/// [host ["[0]" jvm {"+" [Inst]} ["_" inst] ["[0]" def]]] [translation [jvm [extension ["//G" host]]]]]) (import: org/objectweb/asm/Label ["[1]::[0]" (new [])]) (def: (literal literal) (-> /.Literal Inst) (case literal {/.#Boolean value} (_.boolean value) {/.#Int value} (_.int value) {/.#Long value} (_.long value) {/.#Double value} (_.double value) {/.#Char value} (_.char value) {/.#String value} (_.string value))) (def: (constant instruction) (-> /.Constant Inst) (case instruction {/.#BIPUSH constant} (_.BIPUSH constant) {/.#SIPUSH constant} (_.SIPUSH constant) {/.#ICONST_M1} _.ICONST_M1 {/.#ICONST_0} _.ICONST_0 {/.#ICONST_1} _.ICONST_1 {/.#ICONST_2} _.ICONST_2 {/.#ICONST_3} _.ICONST_3 {/.#ICONST_4} _.ICONST_4 {/.#ICONST_5} _.ICONST_5 {/.#LCONST_0} _.LCONST_0 {/.#LCONST_1} _.LCONST_1 {/.#FCONST_0} _.FCONST_0 {/.#FCONST_1} _.FCONST_1 {/.#FCONST_2} _.FCONST_2 {/.#DCONST_0} _.DCONST_0 {/.#DCONST_1} _.DCONST_1 {/.#ACONST_NULL} _.NULL {/.#LDC literal} (..literal literal) )) (def: (int_arithmetic instruction) (-> /.Int_Arithmetic Inst) (case instruction {/.#IADD} _.IADD {/.#ISUB} _.ISUB {/.#IMUL} _.IMUL {/.#IDIV} _.IDIV {/.#IREM} _.IREM {/.#INEG} _.INEG)) (def: (long_arithmetic instruction) (-> /.Long_Arithmetic Inst) (case instruction {/.#LADD} _.LADD {/.#LSUB} _.LSUB {/.#LMUL} _.LMUL {/.#LDIV} _.LDIV {/.#LREM} _.LREM {/.#LNEG} _.LNEG)) (def: (float_arithmetic instruction) (-> /.Float_Arithmetic Inst) (case instruction {/.#FADD} _.FADD {/.#FSUB} _.FSUB {/.#FMUL} _.FMUL {/.#FDIV} _.FDIV {/.#FREM} _.FREM {/.#FNEG} _.FNEG)) (def: (double_arithmetic instruction) (-> /.Double_Arithmetic Inst) (case instruction {/.#DADD} _.DADD {/.#DSUB} _.DSUB {/.#DMUL} _.DMUL {/.#DDIV} _.DDIV {/.#DREM} _.DREM {/.#DNEG} _.DNEG)) (def: (arithmetic instruction) (-> /.Arithmetic Inst) (case instruction {/.#Int_Arithmetic int_arithmetic} (..int_arithmetic int_arithmetic) {/.#Long_Arithmetic long_arithmetic} (..long_arithmetic long_arithmetic) {/.#Float_Arithmetic float_arithmetic} (..float_arithmetic float_arithmetic) {/.#Double_Arithmetic double_arithmetic} (..double_arithmetic double_arithmetic))) (def: (int_bitwise instruction) (-> /.Int_Bitwise Inst) (case instruction {/.#IOR} _.IOR {/.#IXOR} _.IXOR {/.#IAND} _.IAND {/.#ISHL} _.ISHL {/.#ISHR} _.ISHR {/.#IUSHR} _.IUSHR)) (def: (long_bitwise instruction) (-> /.Long_Bitwise Inst) (case instruction {/.#LOR} _.LOR {/.#LXOR} _.LXOR {/.#LAND} _.LAND {/.#LSHL} _.LSHL {/.#LSHR} _.LSHR {/.#LUSHR} _.LUSHR)) (def: (bitwise instruction) (-> /.Bitwise Inst) (case instruction {/.#Int_Bitwise int_bitwise} (..int_bitwise int_bitwise) {/.#Long_Bitwise long_bitwise} (..long_bitwise long_bitwise))) (def: (conversion instruction) (-> /.Conversion Inst) (case instruction {/.#I2B} _.I2B {/.#I2S} _.I2S {/.#I2L} _.I2L {/.#I2F} _.I2F {/.#I2D} _.I2D {/.#I2C} _.I2C {/.#L2I} _.L2I {/.#L2F} _.L2F {/.#L2D} _.L2D {/.#F2I} _.F2I {/.#F2L} _.F2L {/.#F2D} _.F2D {/.#D2I} _.D2I {/.#D2L} _.D2L {/.#D2F} _.D2F)) (def: (array instruction) (-> /.Array Inst) (case instruction {/.#ARRAYLENGTH} _.ARRAYLENGTH {/.#NEWARRAY type} (_.NEWARRAY type) {/.#ANEWARRAY type} (_.ANEWARRAY type) {/.#BALOAD} _.BALOAD {/.#BASTORE} _.BASTORE {/.#SALOAD} _.SALOAD {/.#SASTORE} _.SASTORE {/.#IALOAD} _.IALOAD {/.#IASTORE} _.IASTORE {/.#LALOAD} _.LALOAD {/.#LASTORE} _.LASTORE {/.#FALOAD} _.FALOAD {/.#FASTORE} _.FASTORE {/.#DALOAD} _.DALOAD {/.#DASTORE} _.DASTORE {/.#CALOAD} _.CALOAD {/.#CASTORE} _.CASTORE {/.#AALOAD} _.AALOAD {/.#AASTORE} _.AASTORE)) (def: (object instruction) (-> /.Object Inst) (case instruction (^template [ ] [{ class field_name field_type} ( class field_name field_type)]) ([/.#GETSTATIC _.GETSTATIC] [/.#PUTSTATIC _.PUTSTATIC] [/.#GETFIELD _.GETFIELD] [/.#PUTFIELD _.PUTFIELD]) {/.#NEW type} (_.NEW type) {/.#INSTANCEOF type} (_.INSTANCEOF type) {/.#CHECKCAST type} (_.CHECKCAST type) (^template [ ] [{ class method_name method_type} ( class method_name method_type)]) ([/.#INVOKEINTERFACE _.INVOKEINTERFACE] [/.#INVOKESPECIAL _.INVOKESPECIAL] [/.#INVOKESTATIC _.INVOKESTATIC] [/.#INVOKEVIRTUAL _.INVOKEVIRTUAL]) )) (def: (local_int instruction) (-> /.Local_Int Inst) (case instruction {/.#ILOAD register} (_.ILOAD register) {/.#ISTORE register} (_.ISTORE register))) (def: (local_long instruction) (-> /.Local_Long Inst) (case instruction {/.#LLOAD register} (_.LLOAD register) {/.#LSTORE register} (_.LSTORE register))) (def: (local_float instruction) (-> /.Local_Float Inst) (case instruction {/.#FLOAD register} (_.FLOAD register) {/.#FSTORE register} (_.FSTORE register))) (def: (local_double instruction) (-> /.Local_Double Inst) (case instruction {/.#DLOAD register} (_.DLOAD register) {/.#DSTORE register} (_.DSTORE register))) (def: (local_object instruction) (-> /.Local_Object Inst) (case instruction {/.#ALOAD register} (_.ALOAD register) {/.#ASTORE register} (_.ASTORE register))) (def: (local instruction) (-> /.Local Inst) (case instruction {/.#Local_Int instruction} (..local_int instruction) {/.#IINC register} (_.IINC register) {/.#Local_Long instruction} (..local_long instruction) {/.#Local_Float instruction} (..local_float instruction) {/.#Local_Double instruction} (..local_double instruction) {/.#Local_Object instruction} (..local_object instruction))) (def: (stack instruction) (-> /.Stack Inst) (case instruction {/.#DUP} _.DUP {/.#DUP_X1} _.DUP_X1 {/.#DUP_X2} _.DUP_X2 {/.#DUP2} _.DUP2 {/.#DUP2_X1} _.DUP2_X1 {/.#DUP2_X2} _.DUP2_X2 {/.#SWAP} _.SWAP {/.#POP} _.POP {/.#POP2} _.POP2)) (def: (comparison instruction) (-> /.Comparison Inst) (case instruction {/.#LCMP} _.LCMP {/.#FCMPG} _.FCMPG {/.#FCMPL} _.FCMPL {/.#DCMPG} _.DCMPG {/.#DCMPL} _.DCMPL)) (def: (branching instruction) (-> (/.Branching org/objectweb/asm/Label) Inst) (case instruction {/.#IF_ICMPEQ label} (_.IF_ICMPEQ label) {/.#IF_ICMPGE label} (_.IF_ICMPGE label) {/.#IF_ICMPGT label} (_.IF_ICMPGT label) {/.#IF_ICMPLE label} (_.IF_ICMPLE label) {/.#IF_ICMPLT label} (_.IF_ICMPLT label) {/.#IF_ICMPNE label} (_.IF_ICMPNE label) {/.#IFEQ label} (_.IFEQ label) {/.#IFGE label} (_.IFGE label) {/.#IFGT label} (_.IFGT label) {/.#IFLE label} (_.IFLE label) {/.#IFLT label} (_.IFLT label) {/.#IFNE label} (_.IFNE label) {/.#TABLESWITCH min max default labels} (_.TABLESWITCH min max default labels) {/.#LOOKUPSWITCH default keys+labels} (_.LOOKUPSWITCH default keys+labels) {/.#IF_ACMPEQ label} (_.IF_ACMPEQ label) {/.#IF_ACMPNE label} (_.IF_ACMPNE label) {/.#IFNONNULL label} (_.IFNONNULL label) {/.#IFNULL label} (_.IFNULL label))) (def: (exception instruction) (-> (/.Exception org/objectweb/asm/Label) Inst) (case instruction {/.#Try start end handler exception} (_.try start end handler exception) {/.#ATHROW} _.ATHROW)) (def: (concurrency instruction) (-> /.Concurrency Inst) (case instruction {/.#MONITORENTER} _.MONITORENTER {/.#MONITOREXIT} _.MONITOREXIT)) (def: (return instruction) (-> /.Return Inst) (case instruction {/.#RETURN} _.RETURN {/.#IRETURN} _.IRETURN {/.#LRETURN} _.LRETURN {/.#FRETURN} _.FRETURN {/.#DRETURN} _.DRETURN {/.#ARETURN} _.ARETURN)) (def: (control instruction) (-> (/.Control org/objectweb/asm/Label) Inst) (case instruction {/.#GOTO label} (_.GOTO label) {/.#Branching instruction} (..branching instruction) {/.#Exception instruction} (..exception instruction) {/.#Concurrency instruction} (..concurrency instruction) {/.#Return instruction} (..return instruction))) (def: (instruction instruction) (-> (/.Instruction Inst org/objectweb/asm/Label) Inst) (case instruction {/.#NOP} _.NOP {/.#Constant instruction} (..constant instruction) {/.#Arithmetic instruction} (..arithmetic instruction) {/.#Bitwise instruction} (..bitwise instruction) {/.#Conversion instruction} (..conversion instruction) {/.#Array instruction} (..array instruction) {/.#Object instruction} (..object instruction) {/.#Local instruction} (..local instruction) {/.#Stack instruction} (..stack instruction) {/.#Comparison instruction} (..comparison instruction) {/.#Control instruction} (..control instruction) {/.#Embedded embedded} embedded)) (type: Mapping (Dictionary /.Label org/objectweb/asm/Label)) (type: (Re_labeler context) (-> [Mapping (context /.Label)] [Mapping (context org/objectweb/asm/Label)])) (def: (relabel [mapping label]) (Re_labeler Identity) (case (dictionary.value label mapping) {.#Some label} [mapping label] {.#None} (let [label' (org/objectweb/asm/Label::new)] [(dictionary.has label label' mapping) label']))) (def: (relabel_branching [mapping instruction]) (Re_labeler /.Branching) (case instruction (^template [] [{ label} (let [[mapping label] (..relabel [mapping label])] [mapping { label}])]) ([/.#IF_ICMPEQ] [/.#IF_ICMPGE] [/.#IF_ICMPGT] [/.#IF_ICMPLE] [/.#IF_ICMPLT] [/.#IF_ICMPNE] [/.#IFEQ] [/.#IFNE] [/.#IFGE] [/.#IFGT] [/.#IFLE] [/.#IFLT] [/.#IF_ACMPEQ] [/.#IF_ACMPNE] [/.#IFNONNULL] [/.#IFNULL]) {/.#TABLESWITCH min max default labels} (let [[mapping default] (..relabel [mapping default]) [mapping labels] (list#mix (function (_ input [mapping output]) (let [[mapping input] (..relabel [mapping input])] [mapping (list& input output)])) [mapping (list)] labels)] [mapping {/.#TABLESWITCH min max default (list.reversed labels)}]) {/.#LOOKUPSWITCH default keys+labels} (let [[mapping default] (..relabel [mapping default]) [mapping keys+labels] (list#mix (function (_ [expected input] [mapping output]) (let [[mapping input] (..relabel [mapping input])] [mapping (list& [expected input] output)])) [mapping (list)] keys+labels)] [mapping {/.#LOOKUPSWITCH default (list.reversed keys+labels)}]) )) (def: (relabel_exception [mapping instruction]) (Re_labeler /.Exception) (case instruction {/.#Try start end handler exception} (let [[mapping start] (..relabel [mapping start]) [mapping end] (..relabel [mapping end]) [mapping handler] (..relabel [mapping handler])] [mapping {/.#Try start end handler exception}]) {/.#ATHROW} [mapping {/.#ATHROW}] )) (def: (relabel_control [mapping instruction]) (Re_labeler /.Control) (case instruction (^template [ ] [{ instruction} (let [[mapping instruction] ( [mapping instruction])] [mapping { instruction}])]) ([/.#GOTO ..relabel] [/.#Branching ..relabel_branching] [/.#Exception ..relabel_exception]) (^template [] [{ instruction} [mapping { instruction}]]) ([/.#Concurrency] [/.#Return]) )) (def: (relabel_instruction [mapping instruction]) (Re_labeler (/.Instruction Inst)) (case instruction {/.#Embedded embedded} [mapping {/.#Embedded embedded}] {/.#NOP} [mapping {/.#NOP}] (^template [] [{ instruction} [mapping { instruction}]]) ([/.#Constant] [/.#Arithmetic] [/.#Bitwise] [/.#Conversion] [/.#Array] [/.#Object] [/.#Local] [/.#Stack] [/.#Comparison]) {/.#Control instruction} (let [[mapping instruction] (..relabel_control [mapping instruction])] [mapping {/.#Control instruction}]))) (def: (relabel_bytecode [mapping bytecode]) (Re_labeler (/.Bytecode Inst)) (row#mix (function (_ input [mapping output]) (let [[mapping input'] (..relabel_instruction [mapping input])] [mapping (row.suffix input' output)])) [mapping (row.row)] bytecode)) (def: fresh Mapping (dictionary.empty nat.hash)) (def: bytecode (-> (/.Bytecode Inst /.Label) jvm.Inst) (|>> [..fresh] ..relabel_bytecode product.right (row#each ..instruction) row.list _.fuse)) (with_expansions [ (as_is jvm.Anchor) (as_is Inst) (as_is jvm.Definition) (as_is )] (type: Handler' ... (generation.Handler jvm.Anchor (/.Bytecode Inst /.Label) jvm.Definition) (-> extension.Name (phase.Phase [(extension.Bundle ) (generation.State )] Synthesis ) (phase.Phase [(extension.Bundle ) (generation.State )] (List Synthesis) (/.Bytecode Inst /.Label))))) (def: (true_handler extender pseudo) (-> jvm.Extender Any jvm.Handler) (function (_ extension_name phase archive inputs) (# phase.monad each (|>> (:as (/.Bytecode Inst /.Label)) ..bytecode) ((extender pseudo) extension_name phase archive inputs)))) (type: Phase (directive.Phase jvm.Anchor jvm.Inst jvm.Definition)) (type: Operation (directive.Operation jvm.Anchor jvm.Inst jvm.Definition)) (type: Handler (directive.Handler jvm.Anchor jvm.Inst jvm.Definition)) (def: (def::generation extender) (-> jvm.Extender ..Handler) (function (handler extension_name phase archive inputsC+) (case inputsC+ (^ (list nameC valueC)) (do phase.monad [[_ _ name] (lux/.evaluate! archive Text nameC) [_ handlerV] (lux/.generator archive (:as Text name) ..Handler' valueC) _ (|> handlerV (..true_handler extender) (extension.install extender (:as Text name)) directive.lifted_generation) _ (directive.lifted_generation (generation.log! (format "Generation " (%.text (:as Text name)))))] (in directive.no_requirements)) _ (phase.except extension.invalid_syntax [extension_name %.code inputsC+])))) (def: .public (custom [parser handler]) (All (_ i) (-> [(Parser i) (-> Text ..Phase Archive i (..Operation Requirements))] ..Handler)) (function (_ extension_name phase archive input) (case (.result parser input) {try.#Success input'} (handler extension_name phase archive input') {try.#Failure error} (phase.except extension.invalid_syntax [extension_name %.code input])))) (type: Declaration [External (List (Type Var))]) (template [ ] [(def: (Parser ) (do [! <>.monad] [raw .text] (<>.lifted (.result raw))))] [class_declaration Declaration parser.declaration'] [class (Type Class) parser.class] [type_variable (Type Var) parser.var] [value (Type Value) parser.value] [return_type (Type Return) parser.return] ) (type: Annotation Code) (def: annotation (Parser Annotation) .any) (type: Method_Declaration (Record [#name Text #annotations (List Annotation) #type_variables (List (Type Var)) #exceptions (List (Type Class)) #arguments (List (Type Value)) #return (Type Value)])) (def: method_declaration (Parser Method_Declaration) (.form ($_ <>.and .text (.tuple (<>.some ..annotation)) (.tuple (<>.some ..type_variable)) (.tuple (<>.some ..class)) (.tuple (<>.some ..value)) ..value ))) (def: java/lang/Object (/type.class "java.lang.Object" (list))) (def: inheritance (Parser Inheritance) ($_ <>.or (.text! "final") (.text! "abstract") (.text! "default") )) (def: privacy (Parser Privacy) ($_ <>.or (.text! "public") (.text! "private") (.text! "protected") (.text! "default") )) (def: state (Parser State) ($_ <>.or (.text! "volatile") (.text! "final") (.text! "default") )) (type: Field [Text Privacy State (List Annotation) (Type Value)]) (def: field (Parser Field) (.form (do <>.monad [_ (.text! "variable") name .text privacy ..privacy state ..state _ (.tuple (<>.some ..annotation)) type ..value] (in [name privacy state (list) type])))) (type: Argument [Text (Type Value)]) (def: argument (Parser Argument) (.tuple (<>.and .text ..value))) (type: (Constructor a) [Privacy Bit (List Annotation) (List (Type Var)) (List (Type Class)) Text (List Argument) (List [(Type Value) a]) a]) (type: (Override a) [Declaration Text Bit (List Annotation) (List (Type Var)) Text (List Argument) (Type Return) (List (Type Class)) a]) (type: (Virtual a) [Text Privacy Bit Bit (List Annotation) (List (Type Var)) Text (List Argument) (Type Return) (List (Type Class)) a]) (type: (Static a) [Text Privacy Bit (List Annotation) (List (Type Var)) (List Argument) (Type Return) (List (Type Class)) a]) (type: Abstract [Text Privacy (List Annotation) (List (Type Var)) (List Argument) (Type Return) (List (Type Class))]) (type: (Method a) (Variant {#Constructor (Constructor a)} {#Override (Override a)} {#Virtual (Virtual a)} {#Static (Static a)} {#Abstract Abstract})) (def: constructor (Parser (Constructor Code)) (let [constructor_argument (: (Parser [(Type Value) Code]) (.tuple (<>.and ..value .any)))] (<| .form (<>.after (.text! "init")) ($_ <>.and ..privacy .bit (.tuple (<>.some ..annotation)) (.tuple (<>.some ..type_variable)) (.tuple (<>.some ..class)) .text (.tuple (<>.some ..argument)) (.tuple (<>.some constructor_argument)) .any )))) (def: override (Parser (Override Code)) (<| .form (<>.after (.text! "override")) ($_ <>.and ..class_declaration .text .bit (.tuple (<>.some ..annotation)) (.tuple (<>.some ..type_variable)) .text (.tuple (<>.some ..argument)) ..return_type (.tuple (<>.some ..class)) .any ))) (def: virtual (Parser (Virtual Code)) (<| .form (<>.after (.text! "virtual")) ($_ <>.and .text ..privacy .bit .bit (.tuple (<>.some ..annotation)) (.tuple (<>.some ..type_variable)) .text (.tuple (<>.some ..argument)) ..return_type (.tuple (<>.some ..class)) .any ))) (def: static (Parser (Static Code)) (<| .form (<>.after (.text! "static")) ($_ <>.and .text ..privacy .bit (.tuple (<>.some ..annotation)) (.tuple (<>.some ..type_variable)) (.tuple (<>.some ..argument)) ..return_type (.tuple (<>.some ..class)) .any ))) (def: abstract (Parser Abstract) (<| .form (<>.after (.text! "abstract")) ($_ <>.and .text ..privacy (.tuple (<>.some ..annotation)) (.tuple (<>.some ..type_variable)) (.tuple (<>.some ..argument)) ..return_type (.tuple (<>.some ..class)) ))) (def: method (Parser (Method Code)) ($_ <>.or ..constructor ..override ..virtual ..static ..abstract )) (def: (constraint tv) (-> (Type Var) Constraint) [/type.#name (parser.name tv) /type.#super_class java/lang/Object /type.#super_interfaces (list)]) (def: visibility (-> ffi.Privacy jvm.Visibility) (|>> (case> {ffi.#PublicP} {jvm.#Public} {ffi.#PrivateP} {jvm.#Private} {ffi.#ProtectedP} {jvm.#Protected} {ffi.#DefaultP} {jvm.#Default}))) (def: field_config (-> ffi.State jvm.Field_Config) (|>> (case> {ffi.#VolatileS} jvm.volatileF {ffi.#FinalS} jvm.finalF {ffi.#DefaultS} jvm.noneF))) (def: (field_header [name privacy state annotations type]) (-> Field jvm.Def) (def.field (..visibility privacy) (..field_config state) name type)) (def: (header_value valueT) (-> (Type Value) Inst) (case (/type.primitive? valueT) {.#Left classT} _.NULL {.#Right primitiveT} (cond (or (# /type.equivalence = /type.boolean primitiveT) (# /type.equivalence = /type.byte primitiveT) (# /type.equivalence = /type.short primitiveT) (# /type.equivalence = /type.int primitiveT) (# /type.equivalence = /type.char primitiveT)) _.ICONST_0 (# /type.equivalence = /type.long primitiveT) _.LCONST_0 (# /type.equivalence = /type.float primitiveT) _.FCONST_0 ... (# /type.equivalence = /type.double primitiveT) _.DCONST_0))) (def: (header_return returnT) (-> (Type Return) Inst) (case (/type.void? returnT) {.#Right returnT} _.RETURN {.#Left valueT} (case (/type.primitive? valueT) {.#Left classT} (|>> (header_value classT) _.ARETURN) {.#Right primitiveT} (cond (or (# /type.equivalence = /type.boolean primitiveT) (# /type.equivalence = /type.byte primitiveT) (# /type.equivalence = /type.short primitiveT) (# /type.equivalence = /type.int primitiveT) (# /type.equivalence = /type.char primitiveT)) (|>> (header_value primitiveT) _.IRETURN) (# /type.equivalence = /type.long primitiveT) (|>> (header_value primitiveT) _.LRETURN) (# /type.equivalence = /type.float primitiveT) (|>> (header_value primitiveT) _.FRETURN) ... (# /type.equivalence = /type.double primitiveT) (|>> (header_value primitiveT) _.DRETURN))))) (def: constructor_name "") (def: (abstract_method_generation method) (-> Abstract jvm.Def) (let [[name privacy annotations variables arguments return exceptions] method] (def.abstract_method (..visibility privacy) jvm.noneM name (/type.method [variables (list#each product.right arguments) return exceptions])))) (def: (method_header super_class method) (-> (Type Class) (Method Code) jvm.Def) (case method {#Constructor [privacy strict_floating_point? annotations variables exceptions self arguments constructor_arguments body]} (let [[super_name super_vars] (parser.read_class super_class) init_constructor_arguments (|> constructor_arguments (list#each (|>> product.left ..header_value)) _.fuse) super_constructorT (/type.method [(list) (list#each product.left constructor_arguments) /type.void (list)])] (def.method (..visibility privacy) (if strict_floating_point? jvm.strictM jvm.noneM) ..constructor_name (/type.method [variables (list#each product.right arguments) /type.void exceptions]) (|>> (_.ALOAD 0) init_constructor_arguments (_.INVOKESPECIAL super_class ..constructor_name super_constructorT) _.RETURN))) {#Override [[parent_name parent_variables] name strict_floating_point? annotations variables self arguments return exceptions body]} (def.method {jvm.#Public} (if strict_floating_point? jvm.strictM jvm.noneM) name (/type.method [variables (list#each product.right arguments) return exceptions]) (..header_return return)) {#Virtual [name privacy final? strict_floating_point? annotations variables self arguments return exceptions body]} (def.method (..visibility privacy) (|> jvm.noneM (jvm.++M (if strict_floating_point? jvm.strictM jvm.noneM)) (jvm.++M (if final? jvm.finalM jvm.noneM))) name (/type.method [variables (list#each product.right arguments) return exceptions]) (..header_return return)) {#Static [name privacy strict_floating_point? annotations variables arguments return exceptions body]} (def.method (..visibility privacy) (|> jvm.staticM (jvm.++M (if strict_floating_point? jvm.strictM jvm.noneM))) name (/type.method [variables (list#each product.right arguments) return exceptions]) (..header_return return)) {#Abstract method} (..abstract_method_generation method) )) (def: (header [class_name type_variables] super_class super_interfaces inheritance fields methods) (-> Declaration (Type Class) (List (Type Class)) Inheritance (List Field) (List (Method Code)) [External Binary]) (let [constraints (list#each ..constraint type_variables) field_definitions (list#each ..field_header fields) method_definitions (list#each (..method_header super_class) methods) definitions (def.fuse (list#composite field_definitions method_definitions))] [class_name (case inheritance {ffi.#DefaultI} (def.class {jvm.#V1_6} {jvm.#Public} jvm.noneC class_name constraints super_class super_interfaces definitions) {ffi.#FinalI} (def.class {jvm.#V1_6} {jvm.#Public} jvm.finalC class_name constraints super_class super_interfaces definitions) {ffi.#AbstractI} (def.abstract {jvm.#V1_6} {jvm.#Public} jvm.noneC class_name constraints super_class super_interfaces definitions))])) (def: (constructor_method_analysis archive [class_name class_tvars] method) (-> Archive Declaration (Constructor Code) (Operation (Constructor Analysis))) (do [! phase.monad] [.let [[privacy strict_floating_point? annotations method_tvars exceptions self arguments constructor_argumentsC bodyC] method] analyse directive.analysis] (directive.lifted_analysis (do ! [mapping (//A.with_fresh_type_vars class_tvars luxT.fresh) mapping (//A.with_fresh_type_vars method_tvars mapping) constructor_argumentsA (monad.each ! (function (_ [typeJ termC]) (do ! [typeL (//A.reflection_type mapping typeJ) termA (typeA.with_type typeL (analyse archive termC))] (in [typeJ termA]))) constructor_argumentsC) selfT (//A.reflection_type mapping (/type.class class_name class_tvars)) arguments' (monad.each ! (function (_ [name type]) (# ! each (|>> [name]) (//A.boxed_reflection_type mapping type))) arguments) returnT (//A.boxed_reflection_return mapping /type.void) [_scope bodyA] (|> arguments' {.#Item [self selfT]} list.reversed (list#mix scopeA.with_local (analyse archive bodyC)) (typeA.with_type returnT) analysis.with_scope)] (in [privacy strict_floating_point? annotations method_tvars exceptions self arguments constructor_argumentsA bodyA]))))) (def: (override_method_analysis archive [class_name class_tvars] supers method) (-> Archive Declaration (List (Type Class)) (Override Code) (Operation (Override Analysis))) (do [! phase.monad] [.let [[[super_name super_tvars] method_name strict_floating_point? annotations method_tvars self arguments returnJ exceptionsJ bodyC] method] analyse directive.analysis] (directive.lifted_analysis (do ! [mapping (//A.with_fresh_type_vars class_tvars luxT.fresh) .let [parent_type (/type.class super_name super_tvars)] mapping (//A.with_override_mapping supers parent_type mapping) mapping (//A.with_fresh_type_vars method_tvars mapping) selfT (//A.reflection_type mapping (/type.class class_name class_tvars)) arguments' (monad.each ! (function (_ [name type]) (# ! each (|>> [name]) (//A.boxed_reflection_type mapping type))) arguments) returnT (//A.boxed_reflection_return mapping returnJ) [_scope bodyA] (|> arguments' {.#Item [self selfT]} list.reversed (list#mix scopeA.with_local (analyse archive bodyC)) (typeA.with_type returnT) analysis.with_scope)] (in [[super_name super_tvars] method_name strict_floating_point? annotations method_tvars self arguments returnJ exceptionsJ bodyA]))))) (def: (virtual_method_analysis archive [class_name class_tvars] method) (-> Archive Declaration (Virtual Code) (Operation (Virtual Analysis))) (do [! phase.monad] [.let [[name privacy final? strict_floating_point? annotations method_tvars self arguments returnJ exceptionsJ bodyC] method] analyse directive.analysis] (directive.lifted_analysis (do ! [mapping (//A.with_fresh_type_vars class_tvars luxT.fresh) mapping (//A.with_fresh_type_vars method_tvars mapping) selfT (//A.reflection_type mapping (/type.class class_name class_tvars)) arguments' (monad.each ! (function (_ [name type]) (# ! each (|>> [name]) (//A.boxed_reflection_type mapping type))) arguments) returnT (//A.boxed_reflection_return mapping returnJ) [_scope bodyA] (|> arguments' {.#Item [self selfT]} list.reversed (list#mix scopeA.with_local (analyse archive bodyC)) (typeA.with_type returnT) analysis.with_scope)] (in [name privacy final? strict_floating_point? annotations method_tvars self arguments returnJ exceptionsJ bodyA]))))) (def: (static_method_analysis archive method) (-> Archive (Static Code) (Operation (Static Analysis))) (do [! phase.monad] [.let [[name privacy strict_floating_point? annotations method_tvars arguments returnJ exceptionsJ bodyC] method] analyse directive.analysis] (directive.lifted_analysis (do ! [mapping (//A.with_fresh_type_vars method_tvars luxT.fresh) arguments' (monad.each ! (function (_ [name type]) (# ! each (|>> [name]) (//A.boxed_reflection_type mapping type))) arguments) returnT (//A.boxed_reflection_return mapping returnJ) [_scope bodyA] (|> arguments' list.reversed (list#mix scopeA.with_local (analyse archive bodyC)) (typeA.with_type returnT) analysis.with_scope)] (in [name privacy strict_floating_point? annotations method_tvars arguments returnJ exceptionsJ bodyA]))))) (def: (method_analysis archive declaration supers method) (-> Archive Declaration (List (Type Class)) (Method Code) (Operation (Method Analysis))) (case method {#Constructor method} (# phase.monad each (|>> {#Constructor}) (constructor_method_analysis archive declaration method)) {#Override method} (# phase.monad each (|>> {#Override}) (override_method_analysis archive declaration supers method)) {#Virtual method} (# phase.monad each (|>> {#Virtual}) (virtual_method_analysis archive declaration method)) {#Static method} (# phase.monad each (|>> {#Static}) (static_method_analysis archive method)) {#Abstract method} (# phase.monad in {#Abstract method}) )) (template: (method_body ) [(<| synthesis.function/abstraction [_ _] synthesis.loop/scope [_ _] synthesis.tuple (list _) )]) (def: (constructor_method_synthesis archive method) (-> Archive (Constructor Analysis) (Operation (Constructor Synthesis))) (do [! phase.monad] [.let [[privacy strict_floating_point? annotations method_tvars exceptions self arguments constructor_argumentsA bodyA] method] synthesise directive.synthesis] (directive.lifted_synthesis (do ! [constructor_argumentsS (monad.each ! (function (_ [typeJ termA]) (# ! each (|>> [typeJ]) (synthesise archive termA))) constructor_argumentsA) bodyS (synthesise archive {analysis.#Function (list) (//A.hide_method_body (list.size arguments) bodyA)})] (in [privacy strict_floating_point? annotations method_tvars exceptions self arguments constructor_argumentsS (case bodyS (^ (method_body bodyS)) bodyS _ bodyS)]))))) (def: (override_method_synthesis archive method) (-> Archive (Override Analysis) (Operation (Override Synthesis))) (do [! phase.monad] [.let [[[super_name super_tvars] method_name strict_floating_point? annotations method_tvars self arguments returnJ exceptionsJ bodyA] method] synthesise directive.synthesis] (directive.lifted_synthesis (do ! [bodyS (synthesise archive {analysis.#Function (list) (//A.hide_method_body (list.size arguments) bodyA)})] (in [[super_name super_tvars] method_name strict_floating_point? annotations method_tvars self arguments returnJ exceptionsJ (case bodyS (^ (method_body bodyS)) bodyS _ bodyS)]))))) (def: (virtual_method_synthesis archive method) (-> Archive (Virtual Analysis) (Operation (Virtual Synthesis))) (do [! phase.monad] [.let [[name privacy final? strict_floating_point? annotations method_tvars self arguments returnJ exceptionsJ bodyA] method] synthesise directive.synthesis] (directive.lifted_synthesis (do ! [bodyS (synthesise archive {analysis.#Function (list) (//A.hide_method_body (list.size arguments) bodyA)})] (in [name privacy final? strict_floating_point? annotations method_tvars self arguments returnJ exceptionsJ (case bodyS (^ (method_body bodyS)) bodyS _ bodyS)]))))) (def: (static_method_synthesis archive method) (-> Archive (Static Analysis) (Operation (Static Synthesis))) (do [! phase.monad] [.let [[name privacy strict_floating_point? annotations method_tvars arguments returnJ exceptionsJ bodyA] method] synthesise directive.synthesis] (directive.lifted_synthesis (do ! [bodyS (synthesise archive {analysis.#Function (list) (//A.hide_method_body (list.size arguments) bodyA)})] (in [name privacy strict_floating_point? annotations method_tvars arguments returnJ exceptionsJ (case bodyS (^ (method_body bodyS)) bodyS _ bodyS)]))))) (def: (method_synthesis archive method) (-> Archive (Method Analysis) (Operation (Method Synthesis))) (case method {#Constructor method} (# phase.monad each (|>> {#Constructor}) (constructor_method_synthesis archive method)) {#Override method} (# phase.monad each (|>> {#Override}) (override_method_synthesis archive method)) {#Virtual method} (# phase.monad each (|>> {#Virtual}) (virtual_method_synthesis archive method)) {#Static method} (# phase.monad each (|>> {#Static}) (static_method_synthesis archive method)) {#Abstract method} (# phase.monad in {#Abstract method}) )) (def: (constructor_method_generation archive super_class method) (-> Archive (Type Class) (Constructor Synthesis) (Operation jvm.Def)) (do [! phase.monad] [.let [[privacy strict_floating_point? annotations method_tvars exceptions self arguments constructor_argumentsS bodyS] method] generate directive.generation] (directive.lifted_generation (do ! [constructor_argumentsG (monad.each ! (|>> product.right (generate archive)) constructor_argumentsS) bodyG (generate archive (//G.hidden_method_body (list.size arguments) bodyS)) .let [[super_name super_vars] (parser.read_class super_class) super_constructor_argument_values (_.fuse constructor_argumentsG) super_constructorT (/type.method [(list) (list#each product.left constructor_argumentsS) /type.void (list)]) argumentsT (list#each product.right arguments) initialize_object! (: Inst (|>> (_.ALOAD 0) super_constructor_argument_values (_.INVOKESPECIAL super_class ..constructor_name super_constructorT)))]] (in (def.method (..visibility privacy) (if strict_floating_point? jvm.strictM jvm.noneM) ..constructor_name (/type.method [method_tvars argumentsT /type.void exceptions]) (|>> initialize_object! (//G.prepare_arguments 1 argumentsT) bodyG _.RETURN))))))) (def: (override_method_generation archive method) (-> Archive (Override Synthesis) (Operation jvm.Def)) (do [! phase.monad] [.let [[[super_name super_tvars] method_name strict_floating_point? annotations method_tvars self arguments returnJ exceptionsJ bodyS] method] generate directive.generation] (directive.lifted_generation (do ! [bodyG (generate archive (//G.hidden_method_body (list.size arguments) bodyS)) .let [argumentsT (list#each product.right arguments)]] (in (def.method {jvm.#Public} (if strict_floating_point? jvm.strictM jvm.noneM) method_name (/type.method [method_tvars argumentsT returnJ exceptionsJ]) (|>> (//G.prepare_arguments 1 argumentsT) bodyG (//G.returnI returnJ)))))))) (def: (virtual_method_generation archive method) (-> Archive (Virtual Synthesis) (Operation jvm.Def)) (do [! phase.monad] [.let [[method_name privacy final? strict_floating_point? annotations method_tvars self arguments returnJ exceptionsJ bodyS] method] generate directive.generation] (directive.lifted_generation (do ! [bodyG (generate archive (//G.hidden_method_body (list.size arguments) bodyS)) .let [argumentsT (list#each product.right arguments)]] (in (def.method (..visibility privacy) (|> jvm.noneM (jvm.++M (if strict_floating_point? jvm.strictM jvm.noneM)) (jvm.++M (if final? jvm.finalM jvm.noneM))) method_name (/type.method [method_tvars argumentsT returnJ exceptionsJ]) (|>> (//G.prepare_arguments 1 argumentsT) bodyG (//G.returnI returnJ)))))))) (def: (static_method_generation archive method) (-> Archive (Static Synthesis) (Operation jvm.Def)) (do [! phase.monad] [.let [[method_name privacy strict_floating_point? annotations method_tvars arguments returnJ exceptionsJ bodyS] method] generate directive.generation] (directive.lifted_generation (do ! [bodyG (generate archive (//G.hidden_method_body (list.size arguments) bodyS)) .let [argumentsT (list#each product.right arguments)]] (in (def.method (..visibility privacy) (|> jvm.staticM (jvm.++M (if strict_floating_point? jvm.strictM jvm.noneM))) method_name (/type.method [method_tvars argumentsT returnJ exceptionsJ]) (|>> (//G.prepare_arguments 0 argumentsT) bodyG (//G.returnI returnJ)))))))) (def: (method_generation archive super_class method) (-> Archive (Type Class) (Method Synthesis) (Operation jvm.Def)) (case method {#Constructor method} (..constructor_method_generation archive super_class method) {#Override method} (..override_method_generation archive method) {#Virtual method} (..virtual_method_generation archive method) {#Static method} (..static_method_generation archive method) {#Abstract method} (# phase.monad in (..abstract_method_generation method)) )) (import: java/lang/ClassLoader) (def: (convert_overriden_method method) (-> (Method Code) (Maybe (//A.Overriden_Method Code))) (case method {#Override [[parent_name parent_variables] method_name strict_floating_point? annotations variables self arguments return exceptions body]} {.#Some [(/type.class parent_name parent_variables) method_name strict_floating_point? (list) variables self arguments return exceptions body]} _ {.#None})) (def: (jvm::class class_loader) (-> java/lang/ClassLoader ..Handler) (..custom [($_ <>.and ..class_declaration ..class (.tuple (<>.some ..class)) ..inheritance (.tuple (<>.some ..annotation)) (.tuple (<>.some ..field)) (.tuple (<>.some ..method))) (function (_ extension_name phase archive [declaration super_class super_interfaces inheritance annotations fields methodsC]) (do [! phase.monad] [.let [[class_name type_variables] declaration header (..header [class_name type_variables] super_class super_interfaces inheritance fields methodsC)] ... Necessary for reflection to work properly during analysis. _ (directive.lifted_generation (generation.execute! header)) .let [supers (: (List (Type Class)) (list& super_class super_interfaces))] _ (|> methodsC (list.all ..convert_overriden_method) (//A.require_complete_method_concretion class_loader supers) directive.lifted_analysis) methodsA (monad.each ! (method_analysis archive declaration supers) methodsC) methodsS (monad.each ! (method_synthesis archive) methodsA) methodsG (monad.each ! (method_generation archive super_class) methodsS) .let [directive [class_name (def.class {jvm.#V1_6} {jvm.#Public} jvm.noneC class_name (list#each ..constraint type_variables) super_class super_interfaces (def.fuse (list#composite (list#each ..field_header fields) methodsG)))]]] (directive.lifted_generation (do ! [artifact_id (generation.learn_custom class_name) _ (generation.execute! directive) _ (generation.save! artifact_id {.#Some class_name} directive) _ (generation.log! (format "JVM Class " (%.text class_name)))] (in directive.no_requirements)))))])) (def: jvm::class::interface ..Handler (..custom [($_ <>.and ..class_declaration (.tuple (<>.some ..class)) (.tuple (<>.some ..annotation)) (<>.some ..method_declaration)) (function (_ extension_name phase archive [[class_name type_variables] supers annotations method_declarations]) (do [! phase.monad] [.let [directive [class_name (def.interface {jvm.#V1_6} {jvm.#Public} jvm.noneC class_name (list#each ..constraint type_variables) supers (|> method_declarations (list#each (function (_ (^slots [#name #annotations #type_variables #exceptions #arguments #return])) (def.abstract_method {jvm.#Public} jvm.noneM name (/type.method [type_variables arguments return exceptions])))) def.fuse))]]] (directive.lifted_generation (do ! [artifact_id (generation.learn_custom class_name) _ (generation.execute! directive) _ (generation.save! artifact_id {.#Some class_name} directive) _ (generation.log! (format "JVM Interface " (%.text class_name)))] (in directive.no_requirements)))))])) (def: .public (bundle class_loader extender) (-> java/lang/ClassLoader jvm.Extender (directive.Bundle jvm.Anchor jvm.Inst jvm.Definition)) (|> bundle.empty (dictionary.has "lux def generation" (..def::generation extender)) (dictionary.has "jvm class" (..jvm::class class_loader)) (dictionary.has "jvm class interface" ..jvm::class::interface)))