From 60daee098f92a44c3b404a9f5801f2e8126ad650 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 5 Apr 2022 18:32:42 -0400 Subject: No longer depending on the ASM library for JVM bytecode generation. --- lux-jvm/source/luxc/lang/directive/jvm.lux | 1522 ---------------------------- 1 file changed, 1522 deletions(-) delete mode 100644 lux-jvm/source/luxc/lang/directive/jvm.lux (limited to 'lux-jvm/source/luxc/lang/directive/jvm.lux') diff --git a/lux-jvm/source/luxc/lang/directive/jvm.lux b/lux-jvm/source/luxc/lang/directive/jvm.lux deleted file mode 100644 index bff4a1ab4..000000000 --- a/lux-jvm/source/luxc/lang/directive/jvm.lux +++ /dev/null @@ -1,1522 +0,0 @@ -(.using - [library - [lux {"-" Type Primitive static local} - ["[0]" ffi {"+" Inheritance Privacy State import:}] - [abstract - ["[0]" monad {"+" do}]] - [control - ["[0]" pipe] - ["[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]" sequence {"+" Sequence} ("[1]#[0]" functor mix)] - ["[0]" set {"+" Set}]]] - [macro - ["^" pattern]] - [math - [number - ["[0]" nat]]] - [target - ["/" jvm - [encoding - ["[0]" name {"+" External}]] - ["[1][0]" type {"+" Type Typed 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]" synthesis {"+" Synthesis}] - ["[0]" generation] - ["[0]" directive {"+" Requirements}] - ["[0]" analysis {"+" Analysis} - ["[0]A" type] - ["[0]A" scope]] - [phase - ["[0]" extension - ["[0]" bundle] - [analysis - ["//A" jvm]] - [directive - ["[0]/" lux]]]]]] - [meta - [archive {"+" Archive} - ["[0]" unit]] - ["[0]" cache "_" - ["[1]" artifact]]]]]]] - [/// - [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)) - (sequence#mix (function (_ input [mapping output]) - (let [[mapping input'] (..relabel_instruction [mapping input])] - [mapping (sequence.suffix input' output)])) - [mapping (sequence.sequence)] - bytecode)) - -(def: fresh - Mapping - (dictionary.empty nat.hash)) - -(def: bytecode - (-> (/.Bytecode Inst /.Label) jvm.Inst) - (|>> [..fresh] - ..relabel_bytecode - product.right - (sequence#each ..instruction) - sequence.list - _.fuse)) - -(with_expansions [ (these jvm.Anchor) - (these Inst) - (these jvm.Definition) - (these )] - (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+ - (pattern (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 - (.this_text "final") - (.this_text "abstract") - (.this_text "default") - )) - -(def: privacy - (Parser Privacy) - ($_ <>.or - (.this_text "public") - (.this_text "private") - (.this_text "protected") - (.this_text "default") - )) - -(def: state - (Parser State) - ($_ <>.or - (.this_text "volatile") - (.this_text "final") - (.this_text "default") - )) - -(type: Field - [Text Privacy State (List Annotation) (Type Value)]) - -(def: field - (Parser Field) - (.form - (do <>.monad - [_ (.this_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 (Typed 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: (method_dependencies archive method) - (-> Archive (Method Synthesis) - (generation.Operation jvm.Anchor jvm.Inst jvm.Definition - (Set unit.ID))) - (case method - {#Constructor [privacy strict_floating_point? annotations variables exceptions - self arguments constructor_arguments - body]} - (do [! phase.monad] - [all_super_ctor_dependencies (monad.each ! (|>> product.right (cache.dependencies archive)) - constructor_arguments) - body_dependencies (cache.dependencies archive body)] - (in (cache.all (list& body_dependencies all_super_ctor_dependencies)))) - - - (^.or {#Override [[parent_name parent_variables] name strict_floating_point? annotations variables - self arguments return exceptions - body]} - {#Virtual [name privacy final? strict_floating_point? annotations variables - self arguments return exceptions - body]} - {#Static [name privacy strict_floating_point? annotations variables - arguments return exceptions - body]}) - (cache.dependencies archive body) - - {#Abstract _} - (# phase.monad in unit.none))) - -(def: constructor - (Parser (Constructor Code)) - (let [constructor_argument (is (Parser [(Type Value) Code]) - (.tuple - (<>.and ..value - .any)))] - (<| .form - (<>.after (.this_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 (.this_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 (.this_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 (.this_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 (.this_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) - (|>> (pipe.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) - (|>> (pipe.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.expecting 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.expecting returnT) - scopeA.with)] - (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.expecting returnT) - scopeA.with)] - (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.expecting returnT) - scopeA.with)] - (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.expecting returnT) - scopeA.with)] - (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.hidden_method_body (list.size arguments) bodyA)})] - (in [privacy strict_floating_point? annotations method_tvars exceptions - self arguments constructor_argumentsS - (case bodyS - (pattern (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.hidden_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 - (pattern (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.hidden_method_body (list.size arguments) bodyA)})] - (in [name privacy final? strict_floating_point? annotations method_tvars - self arguments returnJ exceptionsJ - (case bodyS - (pattern (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.hidden_method_body (list.size arguments) bodyA)})] - (in [name privacy strict_floating_point? annotations method_tvars - arguments returnJ exceptionsJ - (case bodyS - (pattern (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! (is 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 (is (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) - all_dependencies (|> methodsS - (monad.each ! (method_dependencies archive)) - (# ! each cache.all) - directive.lifted_generation) - .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 all_dependencies) - _ (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 (_ (open "_[0]")) - (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 unit.none) - _ (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))) -- cgit v1.2.3