diff options
Diffstat (limited to 'lux-jvm/source/luxc/lang')
17 files changed, 0 insertions, 5917 deletions
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 [<tag> <inst>] - [{<tag> class field_name field_type} - (<inst> 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 [<tag> <inst>] - [{<tag> class method_name method_type} - (<inst> 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 [<tag>] - [{<tag> label} - (let [[mapping label] (..relabel [mapping label])] - [mapping {<tag> 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 [<tag> <relabel>] - [{<tag> instruction} - (let [[mapping instruction] (<relabel> [mapping instruction])] - [mapping {<tag> instruction}])]) - ([/.#GOTO ..relabel] - [/.#Branching ..relabel_branching] - [/.#Exception ..relabel_exception]) - - (^.template [<tag>] - [{<tag> instruction} - [mapping {<tag> instruction}]]) - ([/.#Concurrency] [/.#Return]) - )) - -(def: (relabel_instruction [mapping instruction]) - (Re_labeler (/.Instruction Inst)) - (case instruction - {/.#Embedded embedded} - [mapping {/.#Embedded embedded}] - - {/.#NOP} - [mapping {/.#NOP}] - - (^.template [<tag>] - [{<tag> instruction} - [mapping {<tag> 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 [<anchor> (these jvm.Anchor) - <expression> (these Inst) - <directive> (these jvm.Definition) - <type_vars> (these <anchor> <expression> <directive>)] - (type: Handler' - ... (generation.Handler jvm.Anchor (/.Bytecode Inst /.Label) jvm.Definition) - (-> extension.Name - (phase.Phase [(extension.Bundle <type_vars>) - (generation.State <type_vars>)] - Synthesis - <expression>) - (phase.Phase [(extension.Bundle <type_vars>) - (generation.State <type_vars>)] - (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 (<code>.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 [<name> <type> <parser>] - [(def: <name> - (Parser <type>) - (do [! <>.monad] - [raw <code>.text] - (<>.lifted (<text>.result <parser> 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) - <code>.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) - (<code>.form - ($_ <>.and - <code>.text - (<code>.tuple (<>.some ..annotation)) - (<code>.tuple (<>.some ..type_variable)) - (<code>.tuple (<>.some ..class)) - (<code>.tuple (<>.some ..value)) - ..value - ))) - -(def: java/lang/Object - (/type.class "java.lang.Object" (list))) - -(def: inheritance - (Parser Inheritance) - ($_ <>.or - (<code>.this_text "final") - (<code>.this_text "abstract") - (<code>.this_text "default") - )) - -(def: privacy - (Parser Privacy) - ($_ <>.or - (<code>.this_text "public") - (<code>.this_text "private") - (<code>.this_text "protected") - (<code>.this_text "default") - )) - -(def: state - (Parser State) - ($_ <>.or - (<code>.this_text "volatile") - (<code>.this_text "final") - (<code>.this_text "default") - )) - -(type: Field - [Text Privacy State (List Annotation) (Type Value)]) - -(def: field - (Parser Field) - (<code>.form - (do <>.monad - [_ (<code>.this_text "variable") - name <code>.text - privacy ..privacy - state ..state - _ (<code>.tuple (<>.some ..annotation)) - type ..value] - (in [name privacy state (list) type])))) - -(type: Argument - [Text (Type Value)]) - -(def: argument - (Parser Argument) - (<code>.tuple - (<>.and <code>.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]) - (<code>.tuple - (<>.and ..value - <code>.any)))] - (<| <code>.form - (<>.after (<code>.this_text "init")) - ($_ <>.and - ..privacy - <code>.bit - (<code>.tuple (<>.some ..annotation)) - (<code>.tuple (<>.some ..type_variable)) - (<code>.tuple (<>.some ..class)) - <code>.text - (<code>.tuple (<>.some ..argument)) - (<code>.tuple (<>.some constructor_argument)) - <code>.any - )))) - -(def: override - (Parser (Override Code)) - (<| <code>.form - (<>.after (<code>.this_text "override")) - ($_ <>.and - ..class_declaration - <code>.text - <code>.bit - (<code>.tuple (<>.some ..annotation)) - (<code>.tuple (<>.some ..type_variable)) - <code>.text - (<code>.tuple (<>.some ..argument)) - ..return_type - (<code>.tuple (<>.some ..class)) - <code>.any - ))) - -(def: virtual - (Parser (Virtual Code)) - (<| <code>.form - (<>.after (<code>.this_text "virtual")) - ($_ <>.and - <code>.text - ..privacy - <code>.bit - <code>.bit - (<code>.tuple (<>.some ..annotation)) - (<code>.tuple (<>.some ..type_variable)) - <code>.text - (<code>.tuple (<>.some ..argument)) - ..return_type - (<code>.tuple (<>.some ..class)) - <code>.any - ))) - -(def: static - (Parser (Static Code)) - (<| <code>.form - (<>.after (<code>.this_text "static")) - ($_ <>.and - <code>.text - ..privacy - <code>.bit - (<code>.tuple (<>.some ..annotation)) - (<code>.tuple (<>.some ..type_variable)) - (<code>.tuple (<>.some ..argument)) - ..return_type - (<code>.tuple (<>.some ..class)) - <code>.any - ))) - -(def: abstract - (Parser Abstract) - (<| <code>.form - (<>.after (<code>.this_text "abstract")) - ($_ <>.and - <code>.text - ..privacy - (<code>.tuple (<>.some ..annotation)) - (<code>.tuple (<>.some ..type_variable)) - (<code>.tuple (<>.some ..argument)) - ..return_type - (<code>.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 - "<init>") - -(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 <bodyS>) - [(<| synthesis.function/abstraction [_ _] - synthesis.loop/scope [_ _] - synthesis.tuple - (list _) - <bodyS>)]) - -(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 - (<code>.tuple (<>.some ..class)) - ..inheritance - (<code>.tuple (<>.some ..annotation)) - (<code>.tuple (<>.some ..field)) - (<code>.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 - (<code>.tuple (<>.some ..class)) - (<code>.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))) diff --git a/lux-jvm/source/luxc/lang/host/jvm.lux b/lux-jvm/source/luxc/lang/host/jvm.lux deleted file mode 100644 index 22d901d51..000000000 --- a/lux-jvm/source/luxc/lang/host/jvm.lux +++ /dev/null @@ -1,150 +0,0 @@ -(.using - [library - [lux {"-" Definition Type Label} - [ffi {"+" import:}] - [abstract - monad] - [control - ["<>" parser - ["<[0]>" code]]] - [data - [binary {"+" Binary}] - [text - ["%" format {"+" format}]] - [collection - ["[0]" list ("[1]#[0]" monad)]]] - [macro - ["[0]" code] - [syntax {"+" syntax:}]] - [target - [jvm - ["[0]" type {"+" Type} - [category {"+" Class}]]]] - [tool - [compiler - [reference - [variable {"+" Register}]] - [language - [lux - ["[0]" generation]]] - [meta - [archive {"+" Archive}]]]]]]) - -(import: org/objectweb/asm/MethodVisitor - "[1]::[0]") - -(import: org/objectweb/asm/ClassWriter - "[1]::[0]") - -(import: org/objectweb/asm/Label - "[1]::[0]" - (new [])) - -(type: .public Def - (-> org/objectweb/asm/ClassWriter org/objectweb/asm/ClassWriter)) - -(type: .public Inst - (-> org/objectweb/asm/MethodVisitor org/objectweb/asm/MethodVisitor)) - -(type: .public Label - org/objectweb/asm/Label) - -(type: .public Visibility - (Variant - {#Public} - {#Protected} - {#Private} - {#Default})) - -(type: .public Version - (Variant - {#V1_1} - {#V1_2} - {#V1_3} - {#V1_4} - {#V1_5} - {#V1_6} - {#V1_7} - {#V1_8})) - -(type: .public ByteCode - Binary) - -(type: .public Definition - [Text ByteCode]) - -(type: .public Anchor - [Label Register]) - -(type: .public Host - (generation.Host Inst Definition)) - -(template [<name> <base>] - [(type: .public <name> - (<base> ..Anchor ..Inst ..Definition))] - - [State generation.State] - [Operation generation.Operation] - [Phase generation.Phase] - [Handler generation.Handler] - [Bundle generation.Bundle] - [Extender generation.Extender] - ) - -(type: .public (Generator i) - (-> Phase Archive i (Operation Inst))) - -(syntax: (config: [type <code>.local - none <code>.local - ++ <code>.local - options (<code>.tuple (<>.many <code>.local))]) - (let [g!type (code.local type) - g!none (code.local none) - g!tags+ (list#each (|>> (format "#") code.local) options) - g!_left (code.local "_left") - g!_right (code.local "_right") - g!options+ (list#each (function (_ option) - (` (def: .public (~ (code.local option)) - (~ g!type) - (|> (~ g!none) - (has (~ (code.local (format "#" option))) #1))))) - options)] - (in (list& (` (type: .public (~ g!type) - (.Record - (~ (|> g!tags+ - (list#each (function (_ tag) - (list tag (` .Bit)))) - list#conjoint - code.tuple))))) - - (` (def: .public (~ g!none) - (~ g!type) - (~ (|> g!tags+ - (list#each (function (_ tag) - (list tag (` #0)))) - list#conjoint - code.tuple)))) - - (` (def: .public ((~ (code.local ++)) (~ g!_left) (~ g!_right)) - (-> (~ g!type) (~ g!type) (~ g!type)) - (~ (|> g!tags+ - (list#each (function (_ tag) - (list tag (` (or (the (~ tag) (~ g!_left)) - (the (~ tag) (~ g!_right))))))) - list#conjoint - code.tuple)))) - - g!options+)))) - -(config: Class_Config noneC ++C [finalC]) -(config: Method_Config noneM ++M [finalM staticM synchronizedM strictM]) -(config: Field_Config noneF ++F [finalF staticF transientF volatileF]) - -(def: .public new_label - (-> Any Label) - (function (_ _) - (org/objectweb/asm/Label::new))) - -(def: .public (simple_class name) - (-> Text (Type Class)) - (type.class name (list))) diff --git a/lux-jvm/source/luxc/lang/host/jvm/def.lux b/lux-jvm/source/luxc/lang/host/jvm/def.lux deleted file mode 100644 index fd79d2119..000000000 --- a/lux-jvm/source/luxc/lang/host/jvm/def.lux +++ /dev/null @@ -1,306 +0,0 @@ -(.using - [library - [lux {"-" Type} - ["[0]" ffi {"+" import: do_to}] - [control - ["[0]" function]] - [data - ["[0]" product] - ["[0]" text - ["%" format {"+" format}]] - [collection - ["[0]" array {"+" Array}] - ["[0]" list ("[1]@[0]" functor)]]] - [math - [number - ["i" int]]] - [target - [jvm - [encoding - ["[0]" name]] - ["[0]" type {"+" Type Constraint} - [category {"+" Class Value Method}] - ["[0]" signature] - ["[0]" descriptor]]]]]] - ["[0]" //]) - -(def: signature (|>> type.signature signature.signature)) -(def: descriptor (|>> type.descriptor descriptor.descriptor)) -(def: class_name (|>> type.descriptor descriptor.class_name name.read)) - -(import: java/lang/Object - "[1]::[0]") - -(import: java/lang/String - "[1]::[0]") - -(import: org/objectweb/asm/Opcodes - "[1]::[0]" - ("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)) - -(import: org/objectweb/asm/FieldVisitor - "[1]::[0]" - (visitEnd [] void)) - -(import: org/objectweb/asm/MethodVisitor - "[1]::[0]" - (visitCode [] void) - (visitMaxs [int int] void) - (visitEnd [] void)) - -(import: org/objectweb/asm/ClassWriter - "[1]::[0]" - ("static" COMPUTE_MAXS int) - ("static" COMPUTE_FRAMES int) - (new [int]) - (visit [int int java/lang/String java/lang/String java/lang/String [java/lang/String]] void) - (visitEnd [] void) - (visitField [int java/lang/String java/lang/String java/lang/String java/lang/Object] org/objectweb/asm/FieldVisitor) - (visitMethod [int java/lang/String java/lang/String java/lang/String [java/lang/String]] org/objectweb/asm/MethodVisitor) - (toByteArray [] [byte])) - -(def: (string_array values) - (-> (List Text) (Array Text)) - (let [output (ffi.array java/lang/String (list.size values))] - (exec (list@each (function (_ [idx value]) - (ffi.write! idx value output)) - (list.enumeration values)) - output))) - -(def: (version_flag version) - (-> //.Version Int) - (case version - {//.#V1_1} (org/objectweb/asm/Opcodes::V1_1) - {//.#V1_2} (org/objectweb/asm/Opcodes::V1_2) - {//.#V1_3} (org/objectweb/asm/Opcodes::V1_3) - {//.#V1_4} (org/objectweb/asm/Opcodes::V1_4) - {//.#V1_5} (org/objectweb/asm/Opcodes::V1_5) - {//.#V1_6} (org/objectweb/asm/Opcodes::V1_6) - {//.#V1_7} (org/objectweb/asm/Opcodes::V1_7) - {//.#V1_8} (org/objectweb/asm/Opcodes::V1_8))) - -(def: (visibility_flag visibility) - (-> //.Visibility Int) - (case visibility - {//.#Public} (org/objectweb/asm/Opcodes::ACC_PUBLIC) - {//.#Protected} (org/objectweb/asm/Opcodes::ACC_PROTECTED) - {//.#Private} (org/objectweb/asm/Opcodes::ACC_PRIVATE) - {//.#Default} +0)) - -(def: (class_flags config) - (-> //.Class_Config Int) - ($_ i.+ - (if (the //.#finalC config) (org/objectweb/asm/Opcodes::ACC_FINAL) +0))) - -(def: (method_flags config) - (-> //.Method_Config Int) - ($_ i.+ - (if (the //.#staticM config) (org/objectweb/asm/Opcodes::ACC_STATIC) +0) - (if (the //.#finalM config) (org/objectweb/asm/Opcodes::ACC_FINAL) +0) - (if (the //.#synchronizedM config) (org/objectweb/asm/Opcodes::ACC_SYNCHRONIZED) +0) - (if (the //.#strictM config) (org/objectweb/asm/Opcodes::ACC_STRICT) +0))) - -(def: (field_flags config) - (-> //.Field_Config Int) - ($_ i.+ - (if (the //.#staticF config) (org/objectweb/asm/Opcodes::ACC_STATIC) +0) - (if (the //.#finalF config) (org/objectweb/asm/Opcodes::ACC_FINAL) +0) - (if (the //.#transientF config) (org/objectweb/asm/Opcodes::ACC_TRANSIENT) +0) - (if (the //.#volatileF config) (org/objectweb/asm/Opcodes::ACC_VOLATILE) +0))) - -(def: param_signature - (-> (Type Class) Text) - (|>> ..signature (format ":"))) - -(def: (formal_param [name super interfaces]) - (-> Constraint Text) - (format name - (param_signature super) - (|> interfaces - (list@each param_signature) - (text.interposed "")))) - -(def: (constraints_signature constraints super interfaces) - (-> (List Constraint) (Type Class) (List (Type Class)) - Text) - (let [formal_params (if (list.empty? constraints) - "" - (format "<" - (|> constraints - (list@each formal_param) - (text.interposed "")) - ">"))] - (format formal_params - (..signature super) - (|> interfaces - (list@each ..signature) - (text.interposed ""))))) - -(def: class_computes - Int - ($_ i.+ - (org/objectweb/asm/ClassWriter::COMPUTE_MAXS) - ... (org/objectweb/asm/ClassWriter::COMPUTE_FRAMES) - )) - -(def: binary_name (|>> name.internal name.read)) - -(template [<name> <flag>] - [(def: .public (<name> version visibility config name constraints super interfaces - definitions) - (-> //.Version //.Visibility //.Class_Config Text (List Constraint) (Type Class) (List (Type Class)) //.Def - (ffi.type [byte])) - (let [writer (|> (do_to (org/objectweb/asm/ClassWriter::new class_computes) - (org/objectweb/asm/ClassWriter::visit (version_flag version) - ($_ i.+ - (org/objectweb/asm/Opcodes::ACC_SUPER) - <flag> - (visibility_flag visibility) - (class_flags config)) - (..binary_name name) - (constraints_signature constraints super interfaces) - (..class_name super) - (|> interfaces - (list@each ..class_name) - string_array))) - definitions) - _ (org/objectweb/asm/ClassWriter::visitEnd writer)] - (org/objectweb/asm/ClassWriter::toByteArray writer)))] - - [class +0] - [abstract (org/objectweb/asm/Opcodes::ACC_ABSTRACT)] - ) - -(def: $Object - (Type Class) - (type.class "java.lang.Object" (list))) - -(def: .public (interface version visibility config name constraints interfaces - definitions) - (-> //.Version //.Visibility //.Class_Config Text (List Constraint) (List (Type Class)) //.Def - (ffi.type [byte])) - (let [writer (|> (do_to (org/objectweb/asm/ClassWriter::new class_computes) - (org/objectweb/asm/ClassWriter::visit (version_flag version) - ($_ i.+ - (org/objectweb/asm/Opcodes::ACC_ABSTRACT) - (org/objectweb/asm/Opcodes::ACC_INTERFACE) - (visibility_flag visibility) - (class_flags config)) - (..binary_name name) - (constraints_signature constraints $Object interfaces) - (..class_name $Object) - (|> interfaces - (list@each ..class_name) - string_array))) - definitions) - _ (org/objectweb/asm/ClassWriter::visitEnd writer)] - (org/objectweb/asm/ClassWriter::toByteArray writer))) - -(def: .public (method visibility config name type then) - (-> //.Visibility //.Method_Config Text (Type Method) //.Inst - //.Def) - (function (_ writer) - (let [=method (org/objectweb/asm/ClassWriter::visitMethod ($_ i.+ - (visibility_flag visibility) - (method_flags config)) - (..binary_name name) - (..descriptor type) - (..signature type) - (string_array (list)) - writer) - _ (org/objectweb/asm/MethodVisitor::visitCode =method) - _ (then =method) - _ (org/objectweb/asm/MethodVisitor::visitMaxs +0 +0 =method) - _ (org/objectweb/asm/MethodVisitor::visitEnd =method)] - writer))) - -(def: .public (abstract_method visibility config name type) - (-> //.Visibility //.Method_Config Text (Type Method) - //.Def) - (function (_ writer) - (let [=method (org/objectweb/asm/ClassWriter::visitMethod ($_ i.+ - (visibility_flag visibility) - (method_flags config) - (org/objectweb/asm/Opcodes::ACC_ABSTRACT)) - (..binary_name name) - (..descriptor type) - (..signature type) - (string_array (list)) - writer) - _ (org/objectweb/asm/MethodVisitor::visitEnd =method)] - writer))) - -(def: .public (field visibility config name type) - (-> //.Visibility //.Field_Config Text (Type Value) //.Def) - (function (_ writer) - (let [=field (do_to (org/objectweb/asm/ClassWriter::visitField ($_ i.+ - (visibility_flag visibility) - (field_flags config)) - (..binary_name name) - (..descriptor type) - (..signature type) - (ffi.null) - writer) - (org/objectweb/asm/FieldVisitor::visitEnd))] - writer))) - -(template [<name> <lux_type> <jvm_type> <prepare>] - [(def: .public (<name> visibility config name value) - (-> //.Visibility //.Field_Config Text <lux_type> //.Def) - (function (_ writer) - (let [=field (do_to (org/objectweb/asm/ClassWriter::visitField ($_ i.+ - (visibility_flag visibility) - (field_flags config)) - (..binary_name name) - (..descriptor <jvm_type>) - (..signature <jvm_type>) - (<prepare> value) - writer) - (org/objectweb/asm/FieldVisitor::visitEnd))] - writer)))] - - [boolean_field Bit type.boolean function.identity] - [byte_field Int type.byte ffi.long_to_byte] - [short_field Int type.short ffi.long_to_short] - [int_field Int type.int ffi.long_to_int] - [long_field Int type.long function.identity] - [float_field Frac type.float ffi.double_to_float] - [double_field Frac type.double function.identity] - [char_field Nat type.char (|>> .int ffi.long_to_int ffi.int_to_char)] - [string_field Text (type.class "java.lang.String" (list)) function.identity] - ) - -(def: .public (fuse defs) - (-> (List //.Def) //.Def) - (case defs - {.#End} - function.identity - - {.#Item singleton {.#End}} - singleton - - {.#Item head tail} - (function.composite (fuse tail) head))) diff --git a/lux-jvm/source/luxc/lang/host/jvm/inst.lux b/lux-jvm/source/luxc/lang/host/jvm/inst.lux deleted file mode 100644 index 77acf5b35..000000000 --- a/lux-jvm/source/luxc/lang/host/jvm/inst.lux +++ /dev/null @@ -1,472 +0,0 @@ -(.using - [library - [lux {"-" Type Primitive int char try} - ["[0]" ffi {"+" import: do_to}] - [abstract - [monad {"+" do}]] - [control - ["[0]" function] - ["[0]" maybe] - ["[0]" try] - ["p" parser - ["s" code]]] - [data - ["[0]" product] - [collection - ["[0]" list ("[1]@[0]" functor)]]] - [macro - [syntax {"+" syntax:}] - ["[0]" code] - ["[0]" template]] - [math - [number - ["n" nat] - ["i" int]]] - [target - [jvm - [encoding - ["[0]" name {"+" External}]] - ["[0]" type {"+" Type} ("[1]@[0]" equivalence) - [category {"+" Void Value Return Method Primitive Object Class Array Var Parameter}] - ["[0]" box] - ["[0]" descriptor] - ["[0]" reflection]]]] - [tool - [compiler - [phase {"+" Operation}]]]]] - ["[0]" // {"+" Inst}]) - -(def: class_name (|>> type.descriptor descriptor.class_name name.read)) -(def: descriptor (|>> type.descriptor descriptor.descriptor)) -(def: reflection (|>> type.reflection reflection.reflection)) - -... [Host] -(import: java/lang/Object - "[1]::[0]") - -(import: java/lang/String - "[1]::[0]") - -(syntax: (declare [codes (p.many s.local)]) - (|> codes - (list@each (function (_ code) (` ((~' "static") (~ (code.local code)) (~' int))))) - in)) - -(`` (import: org/objectweb/asm/Opcodes - "[1]::[0]" - ("static" NOP int) - - ... Conversion - (~~ (declare D2F D2I D2L - F2D F2I F2L - I2B I2C I2D I2F I2L I2S - L2D L2F L2I)) - - ... Primitive - (~~ (declare T_BOOLEAN T_CHAR T_FLOAT T_DOUBLE - T_BYTE T_SHORT T_INT T_LONG)) - - ... Class - (~~ (declare CHECKCAST NEW INSTANCEOF)) - - ... Stack - (~~ (declare DUP DUP_X1 DUP_X2 - DUP2 DUP2_X1 DUP2_X2 - POP POP2 - SWAP)) - - ... Jump - (~~ (declare IF_ICMPEQ IF_ICMPGT IF_ICMPLT - IF_ICMPNE IF_ICMPGE IF_ICMPLE - IF_ACMPEQ IF_ACMPNE IFNULL IFNONNULL - IFEQ IFNE IFLT IFLE IFGT IFGE - GOTO)) - - (~~ (declare BIPUSH SIPUSH)) - (~~ (declare ICONST_M1 ICONST_0 ICONST_1 ICONST_2 ICONST_3 ICONST_4 ICONST_5 - LCONST_0 LCONST_1 - FCONST_0 FCONST_1 FCONST_2 - DCONST_0 DCONST_1)) - ("static" ACONST_NULL int) - - ... Var - (~~ (declare IINC - ILOAD LLOAD FLOAD DLOAD ALOAD - ISTORE LSTORE FSTORE DSTORE ASTORE)) - - ... Arithmetic - (~~ (declare IADD ISUB IMUL IDIV IREM INEG - LADD LSUB LMUL LDIV LREM LNEG LCMP - FADD FSUB FMUL FDIV FREM FNEG FCMPG FCMPL - DADD DSUB DMUL DDIV DREM DNEG DCMPG DCMPL)) - - ... Bit-wise - (~~ (declare IAND IOR IXOR ISHL ISHR IUSHR - LAND LOR LXOR LSHL LSHR LUSHR)) - - ... Array - (~~ (declare ARRAYLENGTH NEWARRAY ANEWARRAY - AALOAD AASTORE - BALOAD BASTORE - SALOAD SASTORE - IALOAD IASTORE - LALOAD LASTORE - FALOAD FASTORE - DALOAD DASTORE - CALOAD CASTORE)) - - ... Member - (~~ (declare GETSTATIC PUTSTATIC GETFIELD PUTFIELD - INVOKESTATIC INVOKESPECIAL INVOKEVIRTUAL INVOKEINTERFACE)) - - ("static" ATHROW int) - - ... Concurrency - (~~ (declare MONITORENTER MONITOREXIT)) - - ... Return - (~~ (declare RETURN IRETURN LRETURN FRETURN DRETURN ARETURN)) - )) - -(import: org/objectweb/asm/Label - "[1]::[0]" - (new [])) - -(import: org/objectweb/asm/MethodVisitor - "[1]::[0]" - (visitCode [] void) - (visitMaxs [int int] void) - (visitEnd [] void) - (visitInsn [int] void) - (visitLdcInsn [java/lang/Object] void) - (visitFieldInsn [int java/lang/String java/lang/String java/lang/String] void) - (visitTypeInsn [int java/lang/String] void) - (visitVarInsn [int int] void) - (visitIntInsn [int int] void) - (visitMethodInsn [int java/lang/String java/lang/String java/lang/String boolean] void) - (visitLabel [org/objectweb/asm/Label] void) - (visitJumpInsn [int org/objectweb/asm/Label] void) - (visitTryCatchBlock [org/objectweb/asm/Label org/objectweb/asm/Label org/objectweb/asm/Label java/lang/String] void) - (visitLookupSwitchInsn [org/objectweb/asm/Label [int] [org/objectweb/asm/Label]] void) - (visitTableSwitchInsn [int int org/objectweb/asm/Label [org/objectweb/asm/Label]] void) - ) - -... [Insts] -(def: .public make_label - (All (_ s) (Operation s org/objectweb/asm/Label)) - (function (_ state) - {try.#Success [state (org/objectweb/asm/Label::new)]})) - -(def: .public (with_label action) - (All (_ a) (-> (-> org/objectweb/asm/Label a) a)) - (action (org/objectweb/asm/Label::new))) - -(template [<name> <type> <prepare>] - [(def: .public (<name> value) - (-> <type> Inst) - (function (_ visitor) - (do_to visitor - (org/objectweb/asm/MethodVisitor::visitLdcInsn (<prepare> value)))))] - - [boolean Bit function.identity] - [int Int ffi.long_to_int] - [long Int function.identity] - [double Frac function.identity] - [char Nat (|>> .int ffi.long_to_int ffi.int_to_char)] - [string Text function.identity] - ) - -(template: (!prefix short) - [(`` ((~~ (template.symbol ["org/objectweb/asm/Opcodes::" short]))))]) - -(template [<constant>] - [(def: .public <constant> - Inst - (function (_ visitor) - (do_to visitor - (org/objectweb/asm/MethodVisitor::visitInsn (!prefix <constant>)))))] - - [ICONST_M1] [ICONST_0] [ICONST_1] [ICONST_2] [ICONST_3] [ICONST_4] [ICONST_5] - [LCONST_0] [LCONST_1] - [FCONST_0] [FCONST_1] [FCONST_2] - [DCONST_0] [DCONST_1] - ) - -(def: .public NULL - Inst - (function (_ visitor) - (do_to visitor - (org/objectweb/asm/MethodVisitor::visitInsn (!prefix ACONST_NULL))))) - -(template [<constant>] - [(def: .public (<constant> constant) - (-> Int Inst) - (function (_ visitor) - (do_to visitor - (org/objectweb/asm/MethodVisitor::visitIntInsn (!prefix <constant>) constant))))] - - [BIPUSH] - [SIPUSH] - ) - -(template [<name>] - [(def: .public <name> - Inst - (function (_ visitor) - (do_to visitor - (org/objectweb/asm/MethodVisitor::visitInsn (!prefix <name>)))))] - - [NOP] - - ... Stack - [DUP] [DUP_X1] [DUP_X2] [DUP2] [DUP2_X1] [DUP2_X2] - [POP] [POP2] - [SWAP] - - ... Conversions - [D2F] [D2I] [D2L] - [F2D] [F2I] [F2L] - [I2B] [I2C] [I2D] [I2F] [I2L] [I2S] - [L2D] [L2F] [L2I] - - ... Integer arithmetic - [IADD] [ISUB] [IMUL] [IDIV] [IREM] [INEG] - - ... Integer bitwise - [IAND] [IOR] [IXOR] [ISHL] [ISHR] [IUSHR] - - ... Long arithmetic - [LADD] [LSUB] [LMUL] [LDIV] [LREM] [LNEG] - [LCMP] - - ... Long bitwise - [LAND] [LOR] [LXOR] [LSHL] [LSHR] [LUSHR] - - ... Float arithmetic - [FADD] [FSUB] [FMUL] [FDIV] [FREM] [FNEG] [FCMPG] [FCMPL] - - ... Double arithmetic - [DADD] [DSUB] [DMUL] [DDIV] [DREM] [DNEG] - [DCMPG] [DCMPL] - - ... Array - [ARRAYLENGTH] - [AALOAD] [AASTORE] - [BALOAD] [BASTORE] - [SALOAD] [SASTORE] - [IALOAD] [IASTORE] - [LALOAD] [LASTORE] - [FALOAD] [FASTORE] - [DALOAD] [DASTORE] - [CALOAD] [CASTORE] - - ... Exceptions - [ATHROW] - - ... Concurrency - [MONITORENTER] [MONITOREXIT] - - ... Return - [RETURN] [IRETURN] [LRETURN] [FRETURN] [DRETURN] [ARETURN] - ) - -(type: .public Register Nat) - -(template [<name>] - [(def: .public (<name> register) - (-> Register Inst) - (function (_ visitor) - (do_to visitor - (org/objectweb/asm/MethodVisitor::visitVarInsn (!prefix <name>) (.int register)))))] - - [IINC] - [ILOAD] [LLOAD] [FLOAD] [DLOAD] [ALOAD] - [ISTORE] [LSTORE] [FSTORE] [DSTORE] [ASTORE] - ) - -(template [<name> <inst>] - [(def: .public (<name> class field type) - (-> (Type Class) Text (Type Value) Inst) - (function (_ visitor) - (do_to visitor - (org/objectweb/asm/MethodVisitor::visitFieldInsn (<inst>) (..class_name class) field (..descriptor type)))))] - - [GETSTATIC org/objectweb/asm/Opcodes::GETSTATIC] - [PUTSTATIC org/objectweb/asm/Opcodes::PUTSTATIC] - - [PUTFIELD org/objectweb/asm/Opcodes::PUTFIELD] - [GETFIELD org/objectweb/asm/Opcodes::GETFIELD] - ) - -(template [<category> <instructions>+] - [(`` (template [<name> <inst>] - [(def: .public (<name> class) - (-> (Type <category>) Inst) - (function (_ visitor) - (do_to visitor - (org/objectweb/asm/MethodVisitor::visitTypeInsn (<inst>) (..class_name class)))))] - - (~~ (template.spliced <instructions>+))))] - - [Object - [[CHECKCAST org/objectweb/asm/Opcodes::CHECKCAST] - [ANEWARRAY org/objectweb/asm/Opcodes::ANEWARRAY]]] - - [Class - [[NEW org/objectweb/asm/Opcodes::NEW] - [INSTANCEOF org/objectweb/asm/Opcodes::INSTANCEOF]]] - ) - -(def: .public (NEWARRAY type) - (-> (Type Primitive) Inst) - (function (_ visitor) - (do_to visitor - (org/objectweb/asm/MethodVisitor::visitIntInsn (org/objectweb/asm/Opcodes::NEWARRAY) - (`` (cond (~~ (template [<descriptor> <opcode>] - [(type@= <descriptor> type) (<opcode>)] - - [type.boolean org/objectweb/asm/Opcodes::T_BOOLEAN] - [type.byte org/objectweb/asm/Opcodes::T_BYTE] - [type.short org/objectweb/asm/Opcodes::T_SHORT] - [type.int org/objectweb/asm/Opcodes::T_INT] - [type.long org/objectweb/asm/Opcodes::T_LONG] - [type.float org/objectweb/asm/Opcodes::T_FLOAT] - [type.double org/objectweb/asm/Opcodes::T_DOUBLE] - [type.char org/objectweb/asm/Opcodes::T_CHAR])) - ... else - (undefined))))))) - -(template [<name> <inst> <interface?>] - [(def: .public (<name> class method_name method) - (-> (Type Class) Text (Type Method) Inst) - (function (_ visitor) - (do_to visitor - (org/objectweb/asm/MethodVisitor::visitMethodInsn (<inst>) - (..class_name class) - method_name - (|> method type.descriptor descriptor.descriptor) - <interface?>))))] - - [INVOKESTATIC org/objectweb/asm/Opcodes::INVOKESTATIC false] - [INVOKEVIRTUAL org/objectweb/asm/Opcodes::INVOKEVIRTUAL false] - [INVOKESPECIAL org/objectweb/asm/Opcodes::INVOKESPECIAL false] - [INVOKEINTERFACE org/objectweb/asm/Opcodes::INVOKEINTERFACE true] - ) - -(template [<name>] - [(def: .public (<name> @where) - (-> //.Label Inst) - (function (_ visitor) - (do_to visitor - (org/objectweb/asm/MethodVisitor::visitJumpInsn (!prefix <name>) @where))))] - - [IF_ICMPEQ] [IF_ICMPGT] [IF_ICMPLT] - [IF_ICMPNE] [IF_ICMPGE] [IF_ICMPLE] - [IF_ACMPEQ] [IF_ACMPNE] [IFNULL] [IFNONNULL] - [IFEQ] [IFNE] [IFLT] [IFLE] [IFGT] [IFGE] - [GOTO] - ) - -(def: .public (LOOKUPSWITCH default keys+labels) - (-> //.Label (List [Int //.Label]) Inst) - (function (_ visitor) - (let [keys+labels (list.sorted (function (_ left right) - (i.< (product.left left) (product.left right))) - keys+labels) - array_size (list.size keys+labels) - keys_array (ffi.array int array_size) - labels_array (ffi.array org/objectweb/asm/Label array_size) - _ (loop (again [idx 0]) - (if (n.< array_size idx) - (let [[key label] (maybe.trusted (list.item idx keys+labels))] - (exec - (ffi.write! idx (ffi.long_to_int key) keys_array) - (ffi.write! idx label labels_array) - (again (++ idx)))) - []))] - (do_to visitor - (org/objectweb/asm/MethodVisitor::visitLookupSwitchInsn default keys_array labels_array))))) - -(def: .public (TABLESWITCH min max default labels) - (-> Int Int //.Label (List //.Label) Inst) - (function (_ visitor) - (let [num_labels (list.size labels) - labels_array (ffi.array org/objectweb/asm/Label num_labels) - _ (loop (again [idx 0]) - (if (n.< num_labels idx) - (exec (ffi.write! idx - (maybe.trusted (list.item idx labels)) - labels_array) - (again (++ idx))) - []))] - (do_to visitor - (org/objectweb/asm/MethodVisitor::visitTableSwitchInsn min max default labels_array))))) - -(def: .public (try @from @to @handler exception) - (-> //.Label //.Label //.Label (Type Class) Inst) - (function (_ visitor) - (do_to visitor - (org/objectweb/asm/MethodVisitor::visitTryCatchBlock @from @to @handler (..class_name exception))))) - -(def: .public (label @label) - (-> //.Label Inst) - (function (_ visitor) - (do_to visitor - (org/objectweb/asm/MethodVisitor::visitLabel @label)))) - -(def: .public (array elementT) - (-> (Type Value) Inst) - (case (type.primitive? elementT) - {.#Left elementT} - (ANEWARRAY elementT) - - {.#Right elementT} - (NEWARRAY elementT))) - -(template [<name> <boolean> <byte> <short> <int> <long> <float> <double> <char>] - [(def: (<name> type) - (-> (Type Primitive) Text) - (`` (cond (~~ (template [<descriptor> <output>] - [(type@= <descriptor> type) <output>] - - [type.boolean <boolean>] - [type.byte <byte>] - [type.short <short>] - [type.int <int>] - [type.long <long>] - [type.float <float>] - [type.double <double>] - [type.char <char>])) - ... else - (undefined))))] - - [primitive_wrapper - box.boolean box.byte box.short box.int - box.long box.float box.double box.char] - [primitive_unwrap - "booleanValue" "byteValue" "shortValue" "intValue" - "longValue" "floatValue" "doubleValue" "charValue"] - ) - -(def: .public (wrap type) - (-> (Type Primitive) Inst) - (let [wrapper (type.class (primitive_wrapper type) (list))] - (INVOKESTATIC wrapper "valueOf" (type.method [(list) (list type) wrapper (list)])))) - -(def: .public (unwrap type) - (-> (Type Primitive) Inst) - (let [wrapper (type.class (primitive_wrapper type) (list))] - (|>> (CHECKCAST wrapper) - (INVOKEVIRTUAL wrapper (primitive_unwrap type) (type.method [(list) (list) type (list)]))))) - -(def: .public (fuse insts) - (-> (List Inst) Inst) - (case insts - {.#End} - function.identity - - {.#Item singleton {.#End}} - singleton - - {.#Item head tail} - (function.composite (fuse tail) head))) diff --git a/lux-jvm/source/luxc/lang/translation/jvm.lux b/lux-jvm/source/luxc/lang/translation/jvm.lux deleted file mode 100644 index b9ec15962..000000000 --- a/lux-jvm/source/luxc/lang/translation/jvm.lux +++ /dev/null @@ -1,202 +0,0 @@ -(.using - [library - [lux {"-" Definition} - ["[0]" ffi {"+" import: do_to object}] - [abstract - [monad {"+" do}]] - [control - pipe - ["[0]" maybe] - ["[0]" try {"+" Try}] - ["[0]" exception {"+" exception:}] - ["[0]" io {"+" IO io}] - [concurrency - ["[0]" atom {"+" Atom atom}]]] - [data - [binary {"+" Binary}] - ["[0]" product] - ["[0]" text ("[1]@[0]" hash) - ["%" format {"+" format}]] - [collection - ["[0]" array] - ["[0]" dictionary {"+" Dictionary}]]] - [target - [jvm - ["[0]" loader {"+" Library}] - ["[0]" type - ["[0]" descriptor]]]] - [tool - [compiler - [language - [lux - ["[0]" version]]] - [meta - [io {"+" lux_context}] - [archive - ["[0]" unit]]]]]]] - [/// - [host - ["[0]" jvm {"+" Inst Definition Host State} - ["[0]" def] - ["[0]" inst]]]] - ) - -(import: java/lang/reflect/Field - "[1]::[0]" - (get ["?" java/lang/Object] "try" "?" java/lang/Object)) - -(import: (java/lang/Class a) - "[1]::[0]" - (getField [java/lang/String] "try" java/lang/reflect/Field)) - -(import: java/lang/Object - "[1]::[0]" - (getClass [] (java/lang/Class java/lang/Object))) - -(import: java/lang/ClassLoader - "[1]::[0]") - -(type: .public ByteCode Binary) - -(def: .public value_field Text "_value") -(def: .public $Value (type.class "java.lang.Object" (list))) - -(exception: .public (cannot_load [class Text - error Text]) - (exception.report - "Class" class - "Error" error)) - -(exception: .public (invalid_field [class Text - field Text - error Text]) - (exception.report - "Class" class - "Field" field - "Error" error)) - -(exception: .public (invalid_value [class Text]) - (exception.report - "Class" class)) - -(def: (class_value class_name class) - (-> Text (java/lang/Class java/lang/Object) (Try Any)) - (case (java/lang/Class::getField ..value_field class) - {try.#Success field} - (case (java/lang/reflect/Field::get {.#None} field) - {try.#Success ?value} - (case ?value - {.#Some value} - {try.#Success value} - - {.#None} - (exception.except ..invalid_value class_name)) - - {try.#Failure error} - (exception.except ..cannot_load [class_name error])) - - {try.#Failure error} - (exception.except ..invalid_field [class_name ..value_field error]))) - -(def: class_path_separator ".") - -(def: .public bytecode_name - (-> Text Text) - (text.replaced ..class_path_separator .module_separator)) - -(def: .public (class_name [module_id artifact_id]) - (-> unit.ID Text) - (format lux_context - ..class_path_separator (%.nat version.version) - ..class_path_separator (%.nat module_id) - ..class_path_separator (%.nat artifact_id))) - -(def: (evaluate! library loader eval_class valueI) - (-> Library java/lang/ClassLoader Text Inst (Try [Any Definition])) - (let [bytecode_name (..bytecode_name eval_class) - bytecode (def.class {jvm.#V1_6} - {jvm.#Public} jvm.noneC - bytecode_name - (list) $Value - (list) - (|>> (def.field {jvm.#Public} ($_ jvm.++F jvm.finalF jvm.staticF) - ..value_field ..$Value) - (def.method {jvm.#Public} ($_ jvm.++M jvm.staticM jvm.strictM) - "<clinit>" - (type.method [(list) (list) type.void (list)]) - (|>> valueI - (inst.PUTSTATIC (type.class bytecode_name (list)) ..value_field ..$Value) - inst.RETURN))))] - (io.run! (do (try.with io.monad) - [_ (loader.store eval_class bytecode library) - class (loader.load eval_class loader) - value (# io.monad in (..class_value eval_class class))] - (in [value - [eval_class bytecode]]))))) - -(def: (execute! library loader [class_name class_bytecode]) - (-> Library java/lang/ClassLoader Definition (Try Any)) - (io.run! (do (try.with io.monad) - [existing_class? (|> (atom.read! library) - (# io.monad each (function (_ library) - (dictionary.key? library class_name))) - (try.lifted io.monad) - (is (IO (Try Bit)))) - _ (if existing_class? - (in []) - (loader.store class_name class_bytecode library))] - (loader.load class_name loader)))) - -(def: (define! library loader context custom valueI) - (-> Library java/lang/ClassLoader unit.ID (Maybe Text) Inst (Try [Text Any Definition])) - (do try.monad - [[value definition] (evaluate! library loader (..class_name context) valueI)] - (in [(maybe.else (..class_name context) - custom) - value definition]))) - -(def: .public host - (IO [java/lang/ClassLoader Host]) - (io (let [library (loader.new_library []) - loader (loader.memory library)] - [loader - (is Host - (implementation - (def: (evaluate context valueI) - (# try.monad each product.left - (..evaluate! library loader (format "E" (..class_name context)) valueI))) - - (def: execute - (..execute! library loader)) - - (def: define - (..define! library loader)) - - (def: (ingest context bytecode) - [(..class_name context) bytecode]) - - (def: (re_learn context custom [_ bytecode]) - (io.run! - (loader.store (maybe.else (..class_name context) custom) bytecode library))) - - (def: (re_load context custom [directive_name bytecode]) - (io.run! - (do (try.with io.monad) - [.let [class_name (maybe.else (..class_name context) - custom)] - _ (loader.store class_name bytecode library) - class (loader.load class_name loader)] - (# io.monad in (..class_value class_name class)))))))]))) - -(def: .public $Variant - (type.array ..$Value)) - -(def: .public $Tuple - (type.array ..$Value)) - -(def: .public $Runtime - (type.class (..class_name [0 0]) (list))) - -(def: .public $Function - (type.class "library.lux.Function" ... (..class_name [0 1]) - (list))) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/case.lux b/lux-jvm/source/luxc/lang/translation/jvm/case.lux deleted file mode 100644 index cb5004f83..000000000 --- a/lux-jvm/source/luxc/lang/translation/jvm/case.lux +++ /dev/null @@ -1,301 +0,0 @@ -(.using - [library - [lux {"-" Type Label Primitive if exec let case} - [abstract - ["[0]" monad {"+" do}]] - [control - ["[0]" function] - ["ex" exception {"+" exception:}]] - [data - [collection - ["[0]" list ("[1]@[0]" mix)]]] - [macro - ["^" pattern]] - [math - [number - ["n" nat]]] - [target - [jvm - ["[0]" type {"+" Type} - ["[0]" category {"+" Void Value Return Primitive Object Class Array Var Parameter Method}] - ["[0]" descriptor {"+" Descriptor}] - ["[0]" signature {"+" Signature}]]]] - [tool - [compiler - ["[0]" phase ("operation@[0]" monad)] - [meta - [archive {"+" Archive}]] - [language - [lux - ["[0]" synthesis {"+" Path Synthesis}]]]]]]] - [luxc - [lang - [host - ["$" jvm {"+" Label Inst Operation Phase Generator} - ["_" inst]]]]] - ["[0]" // - ["[0]" runtime] - ["[0]" structure]]) - -(def: (pop_altI stack_depth) - (-> Nat Inst) - (.case stack_depth - 0 function.identity - 1 _.POP - 2 _.POP2 - _ ... (n.> 2) - (|>> _.POP2 - (pop_altI (n.- 2 stack_depth))))) - -(def: peekI - Inst - (|>> _.DUP - (_.int +0) - _.AALOAD)) - -(def: pushI - Inst - (_.INVOKESTATIC //.$Runtime "pm_push" (type.method [(list) (list runtime.$Stack //.$Value) runtime.$Stack (list)]))) - -(def: popI - (|>> (_.int +1) - _.AALOAD - (_.CHECKCAST runtime.$Stack))) - -(def: (leftsI value) - (-> Nat Inst) - (.case value - 0 _.ICONST_0 - 1 _.ICONST_1 - 2 _.ICONST_2 - 3 _.ICONST_3 - 4 _.ICONST_4 - 5 _.ICONST_5 - _ (_.int (.int value)))) - -(def: projectionJT - (type.method [(list) (list //.$Tuple runtime.$Index) //.$Value (list)])) - -(def: (left_projection lefts) - (-> Nat Inst) - (.let [[indexI accessI] (.case lefts - 0 - [_.ICONST_0 - _.AALOAD] - - lefts - [(leftsI lefts) - (_.INVOKESTATIC //.$Runtime "tuple_left" ..projectionJT)])] - (|>> (_.CHECKCAST //.$Tuple) - indexI - accessI))) - -(def: (right_projection lefts) - (-> Nat Inst) - (|>> (_.CHECKCAST //.$Tuple) - (leftsI lefts) - (_.INVOKESTATIC //.$Runtime "tuple_right" ..projectionJT))) - -(def: equalsJT - (type.method [(list) (list //.$Value) type.boolean (list)])) - -(def: sideJT - (type.method [(list) (list //.$Variant runtime.$Lefts runtime.$Right?) runtime.$Value (list)])) - -(def: (path' stack_depth @else @end phase archive path) - (-> Nat Label Label Phase Archive Path (Operation Inst)) - (.case path - {synthesis.#Pop} - (operation@in ..popI) - - {synthesis.#Bind register} - (operation@in (|>> peekI - (_.ASTORE register))) - - {synthesis.#Bit_Fork when thenP elseP} - (do phase.monad - [thenG (path' stack_depth @else @end phase archive thenP) - elseG (.case elseP - {.#Some elseP} - (path' stack_depth @else @end phase archive elseP) - - {.#None} - (in (_.GOTO @else))) - .let [ifI (.if when _.IFEQ _.IFNE)]] - (in (<| _.with_label (function (_ @else)) - (|>> peekI - (_.unwrap type.boolean) - (ifI @else) - thenG - (_.label @else) - elseG)))) - - (^.template [<tag> <unwrap> <dup> <pop> <test> <comparison> <if>] - [{<tag> cons} - (do [@ phase.monad] - [forkG (is (Operation Inst) - (monad.mix @ (function (_ [test thenP] elseG) - (do @ - [thenG (path' stack_depth @else @end phase archive thenP)] - (in (<| _.with_label (function (_ @else)) - (|>> <dup> - (<test> test) - <comparison> - (<if> @else) - <pop> - thenG - (_.label @else) - elseG))))) - (|>> <pop> - (_.GOTO @else)) - {.#Item cons}))] - (in (|>> peekI - <unwrap> - forkG)))]) - ([synthesis.#I64_Fork (_.unwrap type.long) _.DUP2 _.POP2 (|>> .int _.long) _.LCMP _.IFNE] - [synthesis.#F64_Fork (_.unwrap type.double) _.DUP2 _.POP2 _.double _.DCMPL _.IFNE] - [synthesis.#Text_Fork (|>) _.DUP _.POP _.string - (_.INVOKEVIRTUAL (type.class "java.lang.Object" (list)) "equals" ..equalsJT) - _.IFEQ]) - - {synthesis.#Then bodyS} - (do phase.monad - [bodyI (phase archive bodyS)] - (in (|>> (pop_altI stack_depth) - bodyI - (_.GOTO @end)))) - - (^.template [<pattern> <right?>] - [(pattern (<pattern> lefts)) - (operation@in (<| _.with_label (function (_ @success)) - _.with_label (function (_ @fail)) - (|>> peekI - (_.CHECKCAST //.$Variant) - (structure.tagI lefts <right?>) - (structure.flagI <right?>) - (_.INVOKESTATIC //.$Runtime "pm_variant" ..sideJT) - _.DUP - (_.IFNULL @fail) - (_.GOTO @success) - (_.label @fail) - _.POP - (_.GOTO @else) - (_.label @success) - pushI)))]) - ([synthesis.side/left false] - [synthesis.side/right true]) - - ... Extra optimization - (^.template [<path> <projection>] - [(pattern (<path> lefts)) - (operation@in (|>> peekI - (<projection> lefts) - pushI)) - - (pattern (synthesis.path/seq - (<path> lefts) - (synthesis.!bind_top register thenP))) - (do phase.monad - [then! (path' stack_depth @else @end phase archive thenP)] - (in (|>> peekI - (<projection> lefts) - (_.ASTORE register) - then!)))]) - ([synthesis.member/left ..left_projection] - [synthesis.member/right ..right_projection]) - - {synthesis.#Seq leftP rightP} - (do phase.monad - [leftI (path' stack_depth @else @end phase archive leftP) - rightI (path' stack_depth @else @end phase archive rightP)] - (in (|>> leftI - rightI))) - - {synthesis.#Alt leftP rightP} - (do phase.monad - [@alt_else _.make_label - leftI (path' (++ stack_depth) @alt_else @end phase archive leftP) - rightI (path' stack_depth @else @end phase archive rightP)] - (in (|>> _.DUP - leftI - (_.label @alt_else) - _.POP - rightI))) - )) - -(def: failJT - (type.method [(list) (list) type.void (list)])) - -(def: (path @end phase archive path) - (-> Label Phase Archive Path (Operation Inst)) - (do phase.monad - [@else _.make_label - pathI (..path' 1 @else @end phase archive path)] - (in (|>> pathI - (_.label @else) - _.POP - (_.INVOKESTATIC //.$Runtime "pm_fail" ..failJT) - _.NULL - (_.GOTO @end))))) - -(def: .public (if phase archive [testS thenS elseS]) - (Generator [Synthesis Synthesis Synthesis]) - (do phase.monad - [testI (phase archive testS) - thenI (phase archive thenS) - elseI (phase archive elseS)] - (in (<| _.with_label (function (_ @else)) - _.with_label (function (_ @end)) - (|>> testI - (_.unwrap type.boolean) - (_.IFEQ @else) - thenI - (_.GOTO @end) - (_.label @else) - elseI - (_.label @end)))))) - -(def: .public (exec phase archive [this that]) - (Generator [Synthesis Synthesis]) - (do phase.monad - [this! (phase archive this) - that! (phase archive that)] - (in (|>> this! - _.POP - that!)))) - -(def: .public (let phase archive [inputS register exprS]) - (Generator [Synthesis Nat Synthesis]) - (do phase.monad - [inputI (phase archive inputS) - exprI (phase archive exprS)] - (in (|>> inputI - (_.ASTORE register) - exprI)))) - -(def: .public (get phase archive [path recordS]) - (Generator [(List synthesis.Member) Synthesis]) - (do phase.monad - [recordG (phase archive recordS)] - (in (list@mix (function (_ step so_far) - (.let [next (.case step - {.#Left lefts} - (..left_projection lefts) - - {.#Right lefts} - (..right_projection lefts))] - (|>> so_far next))) - recordG - (list.reversed path))))) - -(def: .public (case phase archive [valueS path]) - (Generator [Synthesis Path]) - (do phase.monad - [@end _.make_label - valueI (phase archive valueS) - pathI (..path @end phase archive path)] - (in (|>> _.NULL - valueI - pushI - pathI - (_.label @end))))) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/expression.lux b/lux-jvm/source/luxc/lang/translation/jvm/expression.lux deleted file mode 100644 index 692835dc4..000000000 --- a/lux-jvm/source/luxc/lang/translation/jvm/expression.lux +++ /dev/null @@ -1,78 +0,0 @@ -(.using - [library - [lux "*" - [tool - [compiler - [language - [lux - ["[0]" synthesis] - [phase - ["[0]" extension]]]]]]]] - [luxc - [lang - [host - [jvm {"+" Phase}]]]] - [// - ["[0]" primitive] - ["[0]" structure] - ["[0]" reference] - ["[0]" case] - ["[0]" loop] - ["[0]" function]]) - -(def: .public (translate archive synthesis) - Phase - (case synthesis - (pattern (synthesis.bit value)) - (primitive.bit value) - - (pattern (synthesis.i64 value)) - (primitive.i64 value) - - (pattern (synthesis.f64 value)) - (primitive.f64 value) - - (pattern (synthesis.text value)) - (primitive.text value) - - (pattern (synthesis.variant data)) - (structure.variant translate archive data) - - (pattern (synthesis.tuple members)) - (structure.tuple translate archive members) - - (pattern (synthesis.variable variable)) - (reference.variable archive variable) - - (pattern (synthesis.constant constant)) - (reference.constant archive constant) - - (pattern (synthesis.branch/exec it)) - (case.exec translate archive it) - - (pattern (synthesis.branch/let data)) - (case.let translate archive data) - - (pattern (synthesis.branch/if data)) - (case.if translate archive data) - - (pattern (synthesis.branch/get data)) - (case.get translate archive data) - - (pattern (synthesis.branch/case data)) - (case.case translate archive data) - - (pattern (synthesis.loop/again data)) - (loop.again translate archive data) - - (pattern (synthesis.loop/scope data)) - (loop.scope translate archive data) - - (pattern (synthesis.function/apply data)) - (function.call translate archive data) - - (pattern (synthesis.function/abstraction data)) - (function.function translate archive data) - - {synthesis.#Extension extension} - (extension.apply archive translate extension))) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/extension.lux b/lux-jvm/source/luxc/lang/translation/jvm/extension.lux deleted file mode 100644 index 997f850ca..000000000 --- a/lux-jvm/source/luxc/lang/translation/jvm/extension.lux +++ /dev/null @@ -1,17 +0,0 @@ -(.using - [library - [lux "*" - [data - [collection - ["[0]" dictionary]]]]] - [//// - [host - [jvm {"+" Bundle}]]] - ["[0]" / "_" - ["[1][0]" common] - ["[1][0]" host]]) - -(def: .public bundle - Bundle - (dictionary.merged /common.bundle - /host.bundle)) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux b/lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux deleted file mode 100644 index 10fe4e948..000000000 --- a/lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux +++ /dev/null @@ -1,359 +0,0 @@ -(.using - [library - [lux {"-" Type Label} - [ffi {"+" import:}] - [abstract - ["[0]" monad {"+" do}]] - [control - ["[0]" try] - ["<>" parser - ["<s>" synthesis {"+" Parser}]]] - [data - ["[0]" product] - [collection - ["[0]" list ("[1]@[0]" monad)] - ["[0]" dictionary]]] - [math - [number - ["f" frac]]] - [target - [jvm - ["[0]" type]]] - [tool - [compiler - ["[0]" phase] - [meta - [archive {"+" Archive}]] - [language - [lux - ["[0]" synthesis {"+" Synthesis %synthesis}] - [phase - [generation - [extension {"+" Nullary Unary Binary Trinary Variadic - nullary unary binary trinary variadic}]] - ["[0]" extension - ["[0]" bundle]]]]]]]]] - [luxc - [lang - [host - ["$" jvm {"+" Label Inst Def Handler Bundle Operation Phase} - ["_" inst]]]]] - ["[0]" /// - ["[0]" runtime]]) - -(def: .public (custom [parser handler]) - (All (_ s) - (-> [(Parser s) - (-> Text Phase Archive s (Operation Inst))] - Handler)) - (function (_ extension_name phase archive input) - (case (<s>.result parser input) - {try.#Success input'} - (handler extension_name phase archive input') - - {try.#Failure error} - (phase.except extension.invalid_syntax [extension_name %synthesis input])))) - -(def: $String (type.class "java.lang.String" (list))) -(def: $CharSequence (type.class "java.lang.CharSequence" (list))) -(def: $System (type.class "java.lang.System" (list))) -(def: $Object (type.class "java.lang.Object" (list))) - -(def: lux_intI Inst (|>> _.I2L (_.wrap type.long))) -(def: jvm_intI Inst (|>> (_.unwrap type.long) _.L2I)) -(def: check_stringI Inst (_.CHECKCAST $String)) - -(def: (predicateI tester) - (-> (-> Label Inst) - Inst) - (let [$Boolean (type.class "java.lang.Boolean" (list))] - (<| _.with_label (function (_ @then)) - _.with_label (function (_ @end)) - (|>> (tester @then) - (_.GETSTATIC $Boolean "FALSE" $Boolean) - (_.GOTO @end) - (_.label @then) - (_.GETSTATIC $Boolean "TRUE" $Boolean) - (_.label @end) - )))) - -(def: unitI Inst (_.string synthesis.unit)) - -... TODO: Get rid of this ASAP -(def: lux::syntax_char_case! - (..custom [($_ <>.and - <s>.any - <s>.any - (<>.some (<s>.tuple ($_ <>.and - (<s>.tuple (<>.many <s>.i64)) - <s>.any)))) - (function (_ extension_name phase archive [input else conditionals]) - (<| _.with_label (function (_ @end)) - _.with_label (function (_ @else)) - (do [@ phase.monad] - [inputG (phase archive input) - elseG (phase archive else) - conditionalsG+ (is (Operation (List [(List [Int Label]) - Inst])) - (monad.each @ (function (_ [chars branch]) - (do @ - [branchG (phase archive branch)] - (in (<| _.with_label (function (_ @branch)) - [(list@each (function (_ char) - [(.int char) @branch]) - chars) - (|>> (_.label @branch) - branchG - (_.GOTO @end))])))) - conditionals)) - .let [table (|> conditionalsG+ - (list@each product.left) - list@conjoint) - conditionalsG (|> conditionalsG+ - (list@each product.right) - _.fuse)]] - (in (|>> inputG (_.unwrap type.long) _.L2I - (_.LOOKUPSWITCH @else table) - conditionalsG - (_.label @else) - elseG - (_.label @end))))))])) - -(def: (lux::is [referenceI sampleI]) - (Binary Inst) - (|>> referenceI - sampleI - (predicateI _.IF_ACMPEQ))) - -(def: (lux::try riskyI) - (Unary Inst) - (|>> riskyI - (_.CHECKCAST ///.$Function) - (_.INVOKESTATIC ///.$Runtime "try" runtime.try))) - -(template [<name> <op>] - [(def: (<name> [maskI inputI]) - (Binary Inst) - (|>> inputI (_.unwrap type.long) - maskI (_.unwrap type.long) - <op> (_.wrap type.long)))] - - [i64::and _.LAND] - [i64::or _.LOR] - [i64::xor _.LXOR] - ) - -(template [<name> <op>] - [(def: (<name> [shiftI inputI]) - (Binary Inst) - (|>> inputI (_.unwrap type.long) - shiftI jvm_intI - <op> - (_.wrap type.long)))] - - [i64::left_shift _.LSHL] - [i64::right_shift _.LUSHR] - ) - -(template [<name> <type> <op>] - [(def: (<name> [paramI subjectI]) - (Binary Inst) - (|>> subjectI (_.unwrap <type>) - paramI (_.unwrap <type>) - <op> - (_.wrap <type>)))] - - [i64::+ type.long _.LADD] - [i64::- type.long _.LSUB] - [i64::* type.long _.LMUL] - [i64::/ type.long _.LDIV] - [i64::% type.long _.LREM] - - [f64::+ type.double _.DADD] - [f64::- type.double _.DSUB] - [f64::* type.double _.DMUL] - [f64::/ type.double _.DDIV] - [f64::% type.double _.DREM] - ) - -(template [<eq> <lt> <type> <cmp>] - [(template [<name> <reference>] - [(def: (<name> [paramI subjectI]) - (Binary Inst) - (|>> subjectI (_.unwrap <type>) - paramI (_.unwrap <type>) - <cmp> - (_.int <reference>) - (predicateI _.IF_ICMPEQ)))] - - [<eq> +0] - [<lt> -1])] - - [i64::= i64::< type.long _.LCMP] - [f64::= f64::< type.double _.DCMPG] - ) - -(template [<name> <prepare> <transform>] - [(def: (<name> inputI) - (Unary Inst) - (|>> inputI <prepare> <transform>))] - - [i64::f64 (_.unwrap type.long) (<| (_.wrap type.double) _.L2D)] - [i64::char (_.unwrap type.long) - ((|>> _.L2I _.I2C (_.INVOKESTATIC (type.class "java.lang.Character" (list)) "toString" (type.method [(list) (list type.char) $String (list)]))))] - - [f64::i64 (_.unwrap type.double) (<| (_.wrap type.long) _.D2L)] - [f64::encode (_.unwrap type.double) - (_.INVOKESTATIC (type.class "java.lang.Double" (list)) "toString" (type.method [(list) (list type.double) $String (list)]))] - [f64::decode ..check_stringI - (_.INVOKESTATIC ///.$Runtime "decode_frac" (type.method [(list) (list $String) ///.$Variant (list)]))] - ) - -(def: (text::size inputI) - (Unary Inst) - (|>> inputI - ..check_stringI - (_.INVOKEVIRTUAL $String "length" (type.method [(list) (list) type.int (list)])) - lux_intI)) - -(template [<name> <pre_subject> <pre_param> <op> <post>] - [(def: (<name> [paramI subjectI]) - (Binary Inst) - (|>> subjectI <pre_subject> - paramI <pre_param> - <op> <post>))] - - [text::= (<|) (<|) - (_.INVOKEVIRTUAL $Object "equals" (type.method [(list) (list $Object) type.boolean (list)])) - (_.wrap type.boolean)] - [text::< ..check_stringI ..check_stringI - (_.INVOKEVIRTUAL $String "compareTo" (type.method [(list) (list $String) type.int (list)])) - (predicateI _.IFLT)] - [text::char ..check_stringI jvm_intI - (_.INVOKEVIRTUAL $String "charAt" (type.method [(list) (list type.int) type.char (list)])) - lux_intI] - ) - -(def: (text::concat [leftI rightI]) - (Binary Inst) - (|>> leftI ..check_stringI - rightI ..check_stringI - (_.INVOKEVIRTUAL $String "concat" (type.method [(list) (list $String) $String (list)])))) - -(def: (text::clip [offsetI lengthI subjectI]) - (Trinary Inst) - (|>> subjectI ..check_stringI - offsetI jvm_intI - _.DUP - lengthI jvm_intI - _.IADD - (_.INVOKEVIRTUAL $String "substring" (type.method [(list) (list type.int type.int) $String (list)])))) - -(def: index_method (type.method [(list) (list $String type.int) type.int (list)])) -(def: (text::index [startI partI textI]) - (Trinary Inst) - (<| _.with_label (function (_ @not_found)) - _.with_label (function (_ @end)) - (|>> textI ..check_stringI - partI ..check_stringI - startI jvm_intI - (_.INVOKEVIRTUAL $String "indexOf" index_method) - _.DUP - (_.int -1) - (_.IF_ICMPEQ @not_found) - lux_intI - runtime.someI - (_.GOTO @end) - (_.label @not_found) - _.POP - runtime.noneI - (_.label @end)))) - -(def: string_method (type.method [(list) (list $String) type.void (list)])) -(def: (io::log messageI) - (Unary Inst) - (let [$PrintStream (type.class "java.io.PrintStream" (list))] - (|>> (_.GETSTATIC $System "out" $PrintStream) - messageI - ..check_stringI - (_.INVOKEVIRTUAL $PrintStream "println" string_method) - unitI))) - -(def: (io::error messageI) - (Unary Inst) - (let [$Error (type.class "java.lang.Error" (list))] - (|>> (_.NEW $Error) - _.DUP - messageI - ..check_stringI - (_.INVOKESPECIAL $Error "<init>" string_method) - _.ATHROW))) - -(def: bundle::lux - Bundle - (|> (is Bundle bundle.empty) - (bundle.install "syntax char case!" lux::syntax_char_case!) - (bundle.install "is" (binary lux::is)) - (bundle.install "try" (unary lux::try)))) - -(def: bundle::i64 - Bundle - (<| (bundle.prefix "i64") - (|> (is Bundle bundle.empty) - (bundle.install "and" (binary i64::and)) - (bundle.install "or" (binary i64::or)) - (bundle.install "xor" (binary i64::xor)) - (bundle.install "left-shift" (binary i64::left_shift)) - (bundle.install "right-shift" (binary i64::right_shift)) - (bundle.install "=" (binary i64::=)) - (bundle.install "<" (binary i64::<)) - (bundle.install "+" (binary i64::+)) - (bundle.install "-" (binary i64::-)) - (bundle.install "*" (binary i64::*)) - (bundle.install "/" (binary i64::/)) - (bundle.install "%" (binary i64::%)) - (bundle.install "f64" (unary i64::f64)) - (bundle.install "char" (unary i64::char))))) - -(def: bundle::f64 - Bundle - (<| (bundle.prefix "f64") - (|> (is Bundle bundle.empty) - (bundle.install "+" (binary f64::+)) - (bundle.install "-" (binary f64::-)) - (bundle.install "*" (binary f64::*)) - (bundle.install "/" (binary f64::/)) - (bundle.install "%" (binary f64::%)) - (bundle.install "=" (binary f64::=)) - (bundle.install "<" (binary f64::<)) - (bundle.install "i64" (unary f64::i64)) - (bundle.install "encode" (unary f64::encode)) - (bundle.install "decode" (unary f64::decode))))) - -(def: bundle::text - Bundle - (<| (bundle.prefix "text") - (|> (is Bundle bundle.empty) - (bundle.install "=" (binary text::=)) - (bundle.install "<" (binary text::<)) - (bundle.install "concat" (binary text::concat)) - (bundle.install "index" (trinary text::index)) - (bundle.install "size" (unary text::size)) - (bundle.install "char" (binary text::char)) - (bundle.install "clip" (trinary text::clip))))) - -(def: bundle::io - Bundle - (<| (bundle.prefix "io") - (|> (is Bundle bundle.empty) - (bundle.install "log" (unary io::log)) - (bundle.install "error" (unary io::error))))) - -(def: .public bundle - Bundle - (<| (bundle.prefix "lux") - (|> bundle::lux - (dictionary.merged bundle::i64) - (dictionary.merged bundle::f64) - (dictionary.merged bundle::text) - (dictionary.merged bundle::io)))) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux deleted file mode 100644 index cb1ce6f6c..000000000 --- a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux +++ /dev/null @@ -1,1248 +0,0 @@ -(.using - [library - [lux {"-" Type Label Primitive int char type} - [ffi {"+" import:}] - [abstract - ["[0]" monad {"+" do}]] - [control - ["[0]" maybe ("[1]#[0]" functor)] - ["[0]" exception {"+" exception:}] - ["[0]" function] - ["<>" parser ("[1]#[0]" monad) - ["<[0]>" text] - ["<[0]>" synthesis {"+" Parser}]]] - [data - ["[0]" product] - ["[0]" text ("[1]#[0]" equivalence) - ["%" format {"+" format}]] - [collection - ["[0]" list ("[1]#[0]" monoid mix monad)] - ["[0]" dictionary {"+" Dictionary}] - ["[0]" set {"+" Set}]]] - [macro - ["^" pattern] - ["[0]" template]] - [math - [number - ["n" nat]]] - [target - [jvm - ["[0]" type {"+" Type Typed Argument} - ["[0]" category {"+" Void Value Return Primitive Object Class Array Var Parameter Method}] - ["[0]" box] - ["[0]" reflection] - ["[0]" signature] - ["[0]" descriptor] - ["[0]" parser]]]] - [tool - [compiler - ["[0]" phase ("[1]#[0]" monad)] - [reference {"+" } - ["[0]" variable {"+" Variable Register}]] - [meta - [archive {"+" Archive} - ["[0]" unit]] - ["[0]" cache "_" - ["[1]" artifact]]] - [language - [lux - [analysis {"+" Environment}] - ["[0]" synthesis {"+" Synthesis Path %synthesis}] - ["[0]" generation] - [phase - [generation - [extension {"+" Nullary Unary Binary - nullary unary binary}]] - [analysis - ["[0]A" reference]] - ["[0]" extension - ["[0]" bundle] - [analysis - ["/" jvm]]]]]]]]]] - [luxc - [lang - [host - ["$" jvm {"+" Label Inst Def Handler Bundle Operation Phase} - ["_" inst] - ["_[0]" def]]]]] - ["[0]" // "_" - [common {"+" custom}] - ["/[1]" // - ["[1][0]" reference] - ["[1][0]" function]]]) - -(template [<name> <category> <parser>] - [(def: .public <name> - (Parser (Type <category>)) - (<text>.then <parser> <synthesis>.text))] - - [var Var parser.var] - [class Class parser.class] - [object Object parser.object] - [value Value parser.value] - [return Return parser.return] - ) - -(def: signature - (All (_ a) (-> (Type a) Text)) - (|>> type.signature signature.signature)) - -(def: descriptor - (All (_ a) (-> (Type a) Text)) - (|>> type.descriptor descriptor.descriptor)) - -(exception: .public (not_an_object_array [arrayJT (Type Array)]) - (exception.report - "JVM Type" (..signature arrayJT))) - -(def: .public object_array - (Parser (Type Object)) - (do <>.monad - [arrayJT (<text>.then parser.array <synthesis>.text)] - (case (parser.array? arrayJT) - {.#Some elementJT} - (case (parser.object? elementJT) - {.#Some elementJT} - (in elementJT) - - {.#None} - (<>.failure (exception.error ..not_an_object_array [arrayJT]))) - - {.#None} - (undefined)))) - -(template [<name> <inst>] - [(def: <name> - Inst - (|>> _.L2I <inst>))] - - [L2S _.I2S] - [L2B _.I2B] - [L2C _.I2C] - ) - -(template [<conversion> <name>] - [(def: (<name> inputI) - (Unary Inst) - (if (same? _.NOP <conversion>) - inputI - (|>> inputI - <conversion>)))] - - [_.D2F conversion::double_to_float] - [_.D2I conversion::double_to_int] - [_.D2L conversion::double_to_long] - - [_.F2D conversion::float_to_double] - [_.F2I conversion::float_to_int] - [_.F2L conversion::float_to_long] - - [_.I2B conversion::int_to_byte] - [_.I2C conversion::int_to_char] - [_.I2D conversion::int_to_double] - [_.I2F conversion::int_to_float] - [_.I2L conversion::int_to_long] - [_.I2S conversion::int_to_short] - - [_.L2D conversion::long_to_double] - [_.L2F conversion::long_to_float] - [_.L2I conversion::long_to_int] - [..L2S conversion::long_to_short] - [..L2B conversion::long_to_byte] - [..L2C conversion::long_to_char] - - [_.I2B conversion::char_to_byte] - [_.I2S conversion::char_to_short] - [_.NOP conversion::char_to_int] - [_.I2L conversion::char_to_long] - - [_.I2L conversion::byte_to_long] - - [_.I2L conversion::short_to_long] - ) - -(def: conversion_bundle - Bundle - (<| (bundle.prefix "conversion") - (|> (is Bundle bundle.empty) - (bundle.install "double-to-float" (unary conversion::double_to_float)) - (bundle.install "double-to-int" (unary conversion::double_to_int)) - (bundle.install "double-to-long" (unary conversion::double_to_long)) - - (bundle.install "float-to-double" (unary conversion::float_to_double)) - (bundle.install "float-to-int" (unary conversion::float_to_int)) - (bundle.install "float-to-long" (unary conversion::float_to_long)) - - (bundle.install "int-to-byte" (unary conversion::int_to_byte)) - (bundle.install "int-to-char" (unary conversion::int_to_char)) - (bundle.install "int-to-double" (unary conversion::int_to_double)) - (bundle.install "int-to-float" (unary conversion::int_to_float)) - (bundle.install "int-to-long" (unary conversion::int_to_long)) - (bundle.install "int-to-short" (unary conversion::int_to_short)) - - (bundle.install "long-to-double" (unary conversion::long_to_double)) - (bundle.install "long-to-float" (unary conversion::long_to_float)) - (bundle.install "long-to-int" (unary conversion::long_to_int)) - (bundle.install "long-to-short" (unary conversion::long_to_short)) - (bundle.install "long-to-byte" (unary conversion::long_to_byte)) - (bundle.install "long-to-char" (unary conversion::long_to_char)) - - (bundle.install "char-to-byte" (unary conversion::char_to_byte)) - (bundle.install "char-to-short" (unary conversion::char_to_short)) - (bundle.install "char-to-int" (unary conversion::char_to_int)) - (bundle.install "char-to-long" (unary conversion::char_to_long)) - - (bundle.install "byte-to-long" (unary conversion::byte_to_long)) - - (bundle.install "short-to-long" (unary conversion::short_to_long)) - ))) - -(template [<name> <op>] - [(def: (<name> [parameterI subjectI]) - (Binary Inst) - (|>> subjectI - parameterI - <op>))] - - [int::+ _.IADD] - [int::- _.ISUB] - [int::* _.IMUL] - [int::/ _.IDIV] - [int::% _.IREM] - [int::and _.IAND] - [int::or _.IOR] - [int::xor _.IXOR] - [int::shl _.ISHL] - [int::shr _.ISHR] - [int::ushr _.IUSHR] - - [long::+ _.LADD] - [long::- _.LSUB] - [long::* _.LMUL] - [long::/ _.LDIV] - [long::% _.LREM] - [long::and _.LAND] - [long::or _.LOR] - [long::xor _.LXOR] - [long::shl _.LSHL] - [long::shr _.LSHR] - [long::ushr _.LUSHR] - - [float::+ _.FADD] - [float::- _.FSUB] - [float::* _.FMUL] - [float::/ _.FDIV] - [float::% _.FREM] - - [double::+ _.DADD] - [double::- _.DSUB] - [double::* _.DMUL] - [double::/ _.DDIV] - [double::% _.DREM] - ) - -(def: $Boolean (type.class box.boolean (list))) -(def: falseI (_.GETSTATIC $Boolean "FALSE" $Boolean)) -(def: trueI (_.GETSTATIC $Boolean "TRUE" $Boolean)) - -(template [<name> <op>] - [(def: (<name> [referenceI subjectI]) - (Binary Inst) - (<| _.with_label (function (_ @then)) - _.with_label (function (_ @end)) - (|>> subjectI - referenceI - (<op> @then) - falseI - (_.GOTO @end) - (_.label @then) - trueI - (_.label @end))))] - - [int::= _.IF_ICMPEQ] - [int::< _.IF_ICMPLT] - - [char::= _.IF_ICMPEQ] - [char::< _.IF_ICMPLT] - ) - -(template [<name> <op> <reference>] - [(def: (<name> [referenceI subjectI]) - (Binary Inst) - (<| _.with_label (function (_ @then)) - _.with_label (function (_ @end)) - (|>> subjectI - referenceI - <op> - (_.int <reference>) - (_.IF_ICMPEQ @then) - falseI - (_.GOTO @end) - (_.label @then) - trueI - (_.label @end))))] - - [long::= _.LCMP +0] - [long::< _.LCMP -1] - - [float::= _.FCMPG +0] - [float::< _.FCMPG -1] - - [double::= _.DCMPG +0] - [double::< _.DCMPG -1] - ) - -(def: int_bundle - Bundle - (<| (bundle.prefix (reflection.reflection reflection.int)) - (|> (is Bundle bundle.empty) - (bundle.install "+" (binary int::+)) - (bundle.install "-" (binary int::-)) - (bundle.install "*" (binary int::*)) - (bundle.install "/" (binary int::/)) - (bundle.install "%" (binary int::%)) - (bundle.install "=" (binary int::=)) - (bundle.install "<" (binary int::<)) - (bundle.install "and" (binary int::and)) - (bundle.install "or" (binary int::or)) - (bundle.install "xor" (binary int::xor)) - (bundle.install "shl" (binary int::shl)) - (bundle.install "shr" (binary int::shr)) - (bundle.install "ushr" (binary int::ushr)) - ))) - -(def: long_bundle - Bundle - (<| (bundle.prefix (reflection.reflection reflection.long)) - (|> (is Bundle bundle.empty) - (bundle.install "+" (binary long::+)) - (bundle.install "-" (binary long::-)) - (bundle.install "*" (binary long::*)) - (bundle.install "/" (binary long::/)) - (bundle.install "%" (binary long::%)) - (bundle.install "=" (binary long::=)) - (bundle.install "<" (binary long::<)) - (bundle.install "and" (binary long::and)) - (bundle.install "or" (binary long::or)) - (bundle.install "xor" (binary long::xor)) - (bundle.install "shl" (binary long::shl)) - (bundle.install "shr" (binary long::shr)) - (bundle.install "ushr" (binary long::ushr)) - ))) - -(def: float_bundle - Bundle - (<| (bundle.prefix (reflection.reflection reflection.float)) - (|> (is Bundle bundle.empty) - (bundle.install "+" (binary float::+)) - (bundle.install "-" (binary float::-)) - (bundle.install "*" (binary float::*)) - (bundle.install "/" (binary float::/)) - (bundle.install "%" (binary float::%)) - (bundle.install "=" (binary float::=)) - (bundle.install "<" (binary float::<)) - ))) - -(def: double_bundle - Bundle - (<| (bundle.prefix (reflection.reflection reflection.double)) - (|> (is Bundle bundle.empty) - (bundle.install "+" (binary double::+)) - (bundle.install "-" (binary double::-)) - (bundle.install "*" (binary double::*)) - (bundle.install "/" (binary double::/)) - (bundle.install "%" (binary double::%)) - (bundle.install "=" (binary double::=)) - (bundle.install "<" (binary double::<)) - ))) - -(def: char_bundle - Bundle - (<| (bundle.prefix (reflection.reflection reflection.char)) - (|> (is Bundle bundle.empty) - (bundle.install "=" (binary char::=)) - (bundle.install "<" (binary char::<)) - ))) - -(def: (primitive_array_length_handler jvm_primitive) - (-> (Type Primitive) Handler) - (..custom - [<synthesis>.any - (function (_ extension_name generate archive arrayS) - (do phase.monad - [arrayI (generate archive arrayS)] - (in (|>> arrayI - (_.CHECKCAST (type.array jvm_primitive)) - _.ARRAYLENGTH))))])) - -(def: array::length::object - Handler - (..custom - [($_ <>.and ..object_array <synthesis>.any) - (function (_ extension_name generate archive [elementJT arrayS]) - (do phase.monad - [arrayI (generate archive arrayS)] - (in (|>> arrayI - (_.CHECKCAST (type.array elementJT)) - _.ARRAYLENGTH))))])) - -(def: (new_primitive_array_handler jvm_primitive) - (-> (Type Primitive) Handler) - (function (_ extension_name generate archive inputs) - (case inputs - (pattern (list lengthS)) - (do phase.monad - [lengthI (generate archive lengthS)] - (in (|>> lengthI - (_.array jvm_primitive)))) - - _ - (phase.except extension.invalid_syntax [extension_name %synthesis inputs])))) - -(def: array::new::object - Handler - (..custom - [($_ <>.and ..object <synthesis>.any) - (function (_ extension_name generate archive [objectJT lengthS]) - (do phase.monad - [lengthI (generate archive lengthS)] - (in (|>> lengthI - (_.ANEWARRAY objectJT)))))])) - -(def: (read_primitive_array_handler jvm_primitive loadI) - (-> (Type Primitive) Inst Handler) - (function (_ extension_name generate archive inputs) - (case inputs - (pattern (list idxS arrayS)) - (do phase.monad - [arrayI (generate archive arrayS) - idxI (generate archive idxS)] - (in (|>> arrayI - (_.CHECKCAST (type.array jvm_primitive)) - idxI - loadI))) - - _ - (phase.except extension.invalid_syntax [extension_name %synthesis inputs])))) - -(def: array::read::object - Handler - (..custom - [($_ <>.and ..object_array <synthesis>.any <synthesis>.any) - (function (_ extension_name generate archive [elementJT idxS arrayS]) - (do phase.monad - [arrayI (generate archive arrayS) - idxI (generate archive idxS)] - (in (|>> arrayI - (_.CHECKCAST (type.array elementJT)) - idxI - _.AALOAD))))])) - -(def: (write_primitive_array_handler jvm_primitive storeI) - (-> (Type Primitive) Inst Handler) - (function (_ extension_name generate archive inputs) - (case inputs - (pattern (list idxS valueS arrayS)) - (do phase.monad - [arrayI (generate archive arrayS) - idxI (generate archive idxS) - valueI (generate archive valueS)] - (in (|>> arrayI - (_.CHECKCAST (type.array jvm_primitive)) - _.DUP - idxI - valueI - storeI))) - - _ - (phase.except extension.invalid_syntax [extension_name %synthesis inputs])))) - -(def: array::write::object - Handler - (..custom - [($_ <>.and ..object_array <synthesis>.any <synthesis>.any <synthesis>.any) - (function (_ extension_name generate archive [elementJT idxS valueS arrayS]) - (do phase.monad - [arrayI (generate archive arrayS) - idxI (generate archive idxS) - valueI (generate archive valueS)] - (in (|>> arrayI - (_.CHECKCAST (type.array elementJT)) - _.DUP - idxI - valueI - _.AASTORE))))])) - -(def: array_bundle - Bundle - (<| (bundle.prefix "array") - (|> bundle.empty - (dictionary.merged (<| (bundle.prefix "length") - (|> bundle.empty - (bundle.install (reflection.reflection reflection.boolean) (primitive_array_length_handler type.boolean)) - (bundle.install (reflection.reflection reflection.byte) (primitive_array_length_handler type.byte)) - (bundle.install (reflection.reflection reflection.short) (primitive_array_length_handler type.short)) - (bundle.install (reflection.reflection reflection.int) (primitive_array_length_handler type.int)) - (bundle.install (reflection.reflection reflection.long) (primitive_array_length_handler type.long)) - (bundle.install (reflection.reflection reflection.float) (primitive_array_length_handler type.float)) - (bundle.install (reflection.reflection reflection.double) (primitive_array_length_handler type.double)) - (bundle.install (reflection.reflection reflection.char) (primitive_array_length_handler type.char)) - (bundle.install "object" array::length::object)))) - (dictionary.merged (<| (bundle.prefix "new") - (|> bundle.empty - (bundle.install (reflection.reflection reflection.boolean) (new_primitive_array_handler type.boolean)) - (bundle.install (reflection.reflection reflection.byte) (new_primitive_array_handler type.byte)) - (bundle.install (reflection.reflection reflection.short) (new_primitive_array_handler type.short)) - (bundle.install (reflection.reflection reflection.int) (new_primitive_array_handler type.int)) - (bundle.install (reflection.reflection reflection.long) (new_primitive_array_handler type.long)) - (bundle.install (reflection.reflection reflection.float) (new_primitive_array_handler type.float)) - (bundle.install (reflection.reflection reflection.double) (new_primitive_array_handler type.double)) - (bundle.install (reflection.reflection reflection.char) (new_primitive_array_handler type.char)) - (bundle.install "object" array::new::object)))) - (dictionary.merged (<| (bundle.prefix "read") - (|> bundle.empty - (bundle.install (reflection.reflection reflection.boolean) (read_primitive_array_handler type.boolean _.BALOAD)) - (bundle.install (reflection.reflection reflection.byte) (read_primitive_array_handler type.byte _.BALOAD)) - (bundle.install (reflection.reflection reflection.short) (read_primitive_array_handler type.short _.SALOAD)) - (bundle.install (reflection.reflection reflection.int) (read_primitive_array_handler type.int _.IALOAD)) - (bundle.install (reflection.reflection reflection.long) (read_primitive_array_handler type.long _.LALOAD)) - (bundle.install (reflection.reflection reflection.float) (read_primitive_array_handler type.float _.FALOAD)) - (bundle.install (reflection.reflection reflection.double) (read_primitive_array_handler type.double _.DALOAD)) - (bundle.install (reflection.reflection reflection.char) (read_primitive_array_handler type.char _.CALOAD)) - (bundle.install "object" array::read::object)))) - (dictionary.merged (<| (bundle.prefix "write") - (|> bundle.empty - (bundle.install (reflection.reflection reflection.boolean) (write_primitive_array_handler type.boolean _.BASTORE)) - (bundle.install (reflection.reflection reflection.byte) (write_primitive_array_handler type.byte _.BASTORE)) - (bundle.install (reflection.reflection reflection.short) (write_primitive_array_handler type.short _.SASTORE)) - (bundle.install (reflection.reflection reflection.int) (write_primitive_array_handler type.int _.IASTORE)) - (bundle.install (reflection.reflection reflection.long) (write_primitive_array_handler type.long _.LASTORE)) - (bundle.install (reflection.reflection reflection.float) (write_primitive_array_handler type.float _.FASTORE)) - (bundle.install (reflection.reflection reflection.double) (write_primitive_array_handler type.double _.DASTORE)) - (bundle.install (reflection.reflection reflection.char) (write_primitive_array_handler type.char _.CASTORE)) - (bundle.install "object" array::write::object)))) - ))) - -(def: (object::null _) - (Nullary Inst) - _.NULL) - -(def: (object::null? objectI) - (Unary Inst) - (<| _.with_label (function (_ @then)) - _.with_label (function (_ @end)) - (|>> objectI - (_.IFNULL @then) - falseI - (_.GOTO @end) - (_.label @then) - trueI - (_.label @end)))) - -(def: (object::synchronized [monitorI exprI]) - (Binary Inst) - (|>> monitorI - _.DUP - _.MONITORENTER - exprI - _.SWAP - _.MONITOREXIT)) - -(def: (object::throw exceptionI) - (Unary Inst) - (|>> exceptionI - _.ATHROW)) - -(def: $Class - (type.class "java.lang.Class" (list))) - -(def: (object::class extension_name generate archive inputs) - Handler - (case inputs - (pattern (list (synthesis.text class))) - (do phase.monad - [] - (in (|>> (_.string class) - (_.INVOKESTATIC $Class "forName" (type.method [(list) (list (type.class "java.lang.String" (list))) $Class (list)]))))) - - _ - (phase.except extension.invalid_syntax [extension_name %synthesis inputs]))) - -(def: object::instance? - Handler - (..custom - [($_ <>.and <synthesis>.text <synthesis>.any) - (function (_ extension_name generate archive [class objectS]) - (do phase.monad - [objectI (generate archive objectS)] - (in (|>> objectI - (_.INSTANCEOF (type.class class (list))) - (_.wrap type.boolean)))))])) - -(def: (object::cast extension_name generate archive inputs) - Handler - (case inputs - (pattern (list (synthesis.text from) (synthesis.text to) valueS)) - (do phase.monad - [valueI (generate archive valueS)] - (`` (cond (~~ (template [<object> <primitive>] - [(and (text#= (reflection.reflection (type.reflection <primitive>)) - from) - (text#= <object> - to)) - (in (|>> valueI (_.wrap <primitive>))) - - (and (text#= <object> - from) - (text#= (reflection.reflection (type.reflection <primitive>)) - to)) - (in (|>> valueI (_.unwrap <primitive>)))] - - [box.boolean type.boolean] - [box.byte type.byte] - [box.short type.short] - [box.int type.int] - [box.long type.long] - [box.float type.float] - [box.double type.double] - [box.char type.char])) - ... else - (in valueI)))) - - _ - (phase.except extension.invalid_syntax [extension_name %synthesis inputs]))) - -(def: object_bundle - Bundle - (<| (bundle.prefix "object") - (|> (is Bundle bundle.empty) - (bundle.install "null" (nullary object::null)) - (bundle.install "null?" (unary object::null?)) - (bundle.install "synchronized" (binary object::synchronized)) - (bundle.install "throw" (unary object::throw)) - (bundle.install "class" object::class) - (bundle.install "instance?" object::instance?) - (bundle.install "cast" object::cast) - ))) - -(def: primitives - (Dictionary Text (Type Primitive)) - (|> (list [(reflection.reflection reflection.boolean) type.boolean] - [(reflection.reflection reflection.byte) type.byte] - [(reflection.reflection reflection.short) type.short] - [(reflection.reflection reflection.int) type.int] - [(reflection.reflection reflection.long) type.long] - [(reflection.reflection reflection.float) type.float] - [(reflection.reflection reflection.double) type.double] - [(reflection.reflection reflection.char) type.char]) - (dictionary.of_list text.hash))) - -(def: get::static - Handler - (..custom - [($_ <>.and <synthesis>.text <synthesis>.text <synthesis>.text) - (function (_ extension_name generate archive [class field unboxed]) - (do phase.monad - [] - (case (dictionary.value unboxed ..primitives) - {.#Some primitive} - (in (_.GETSTATIC (type.class class (list)) field primitive)) - - {.#None} - (in (_.GETSTATIC (type.class class (list)) field (type.class unboxed (list)))))))])) - -(def: put::static - Handler - (..custom - [($_ <>.and <synthesis>.text <synthesis>.text <synthesis>.text <synthesis>.any) - (function (_ extension_name generate archive [class field unboxed valueS]) - (do phase.monad - [valueI (generate archive valueS) - .let [$class (type.class class (list))]] - (case (dictionary.value unboxed ..primitives) - {.#Some primitive} - (in (|>> valueI - (_.PUTSTATIC $class field primitive) - (_.string synthesis.unit))) - - {.#None} - (in (|>> valueI - (_.CHECKCAST $class) - (_.PUTSTATIC $class field $class) - (_.string synthesis.unit))))))])) - -(def: get::virtual - Handler - (..custom - [($_ <>.and <synthesis>.text <synthesis>.text <synthesis>.text <synthesis>.any) - (function (_ extension_name generate archive [class field unboxed objectS]) - (do phase.monad - [objectI (generate archive objectS) - .let [$class (type.class class (list)) - getI (case (dictionary.value unboxed ..primitives) - {.#Some primitive} - (_.GETFIELD $class field primitive) - - {.#None} - (_.GETFIELD $class field (type.class unboxed (list))))]] - (in (|>> objectI - (_.CHECKCAST $class) - getI))))])) - -(def: put::virtual - Handler - (..custom - [($_ <>.and <synthesis>.text <synthesis>.text <synthesis>.text <synthesis>.any <synthesis>.any) - (function (_ extension_name generate archive [class field unboxed valueS objectS]) - (do phase.monad - [valueI (generate archive valueS) - objectI (generate archive objectS) - .let [$class (type.class class (list)) - putI (case (dictionary.value unboxed ..primitives) - {.#Some primitive} - (_.PUTFIELD $class field primitive) - - {.#None} - (let [$unboxed (type.class unboxed (list))] - (|>> (_.CHECKCAST $unboxed) - (_.PUTFIELD $class field $unboxed))))]] - (in (|>> objectI - (_.CHECKCAST $class) - _.DUP - valueI - putI))))])) - -(type: Input - (Typed Synthesis)) - -(def: input - (Parser Input) - (<synthesis>.tuple (<>.and ..value <synthesis>.any))) - -(def: (generate_input generate archive [valueT valueS]) - (-> Phase Archive Input - (Operation (Typed Inst))) - (do phase.monad - [valueI (generate archive valueS)] - (case (type.primitive? valueT) - {.#Right valueT} - (in [valueT valueI]) - - {.#Left valueT} - (in [valueT (|>> valueI - (_.CHECKCAST valueT))])))) - -(def: voidI - (_.string synthesis.unit)) - -(def: (prepare_output outputT) - (-> (Type Return) Inst) - (case (type.void? outputT) - {.#Right outputT} - ..voidI - - {.#Left outputT} - function.identity)) - -(def: invoke::static - Handler - (..custom - [($_ <>.and ..class <synthesis>.text ..return (<>.some ..input)) - (function (_ extension_name generate archive [class method outputT inputsTS]) - (do [! phase.monad] - [inputsTI (monad.each ! (generate_input generate archive) inputsTS)] - (in (|>> (_.fuse (list#each product.right inputsTI)) - (_.INVOKESTATIC class method (type.method [(list) (list#each product.left inputsTI) outputT (list)])) - (prepare_output outputT)))))])) - -(template [<name> <invoke>] - [(def: <name> - Handler - (..custom - [($_ <>.and ..class <synthesis>.text ..return <synthesis>.any (<>.some ..input)) - (function (_ extension_name generate archive [class method outputT objectS inputsTS]) - (do [! phase.monad] - [objectI (generate archive objectS) - inputsTI (monad.each ! (generate_input generate archive) inputsTS)] - (in (|>> objectI - (_.CHECKCAST class) - (_.fuse (list#each product.right inputsTI)) - (<invoke> class method - (type.method [(list) - (list#each product.left inputsTI) - outputT - (list)])) - (prepare_output outputT)))))]))] - - [invoke::virtual _.INVOKEVIRTUAL] - [invoke::special _.INVOKESPECIAL] - [invoke::interface _.INVOKEINTERFACE] - ) - -(def: invoke::constructor - Handler - (..custom - [($_ <>.and ..class (<>.some ..input)) - (function (_ extension_name generate archive [class inputsTS]) - (do [! phase.monad] - [inputsTI (monad.each ! (generate_input generate archive) inputsTS)] - (in (|>> (_.NEW class) - _.DUP - (_.fuse (list#each product.right inputsTI)) - (_.INVOKESPECIAL class "<init>" (type.method [(list) (list#each product.left inputsTI) type.void (list)]))))))])) - -(def: member_bundle - Bundle - (<| (bundle.prefix "member") - (|> (is Bundle bundle.empty) - (dictionary.merged (<| (bundle.prefix "get") - (|> (is Bundle bundle.empty) - (bundle.install "static" get::static) - (bundle.install "virtual" get::virtual)))) - (dictionary.merged (<| (bundle.prefix "put") - (|> (is Bundle bundle.empty) - (bundle.install "static" put::static) - (bundle.install "virtual" put::virtual)))) - (dictionary.merged (<| (bundle.prefix "invoke") - (|> (is Bundle bundle.empty) - (bundle.install "static" invoke::static) - (bundle.install "virtual" invoke::virtual) - (bundle.install "special" invoke::special) - (bundle.install "interface" invoke::interface) - (bundle.install "constructor" invoke::constructor)))) - ))) - -(def: annotation_parameter - (Parser (/.Annotation_Parameter Synthesis)) - (<synthesis>.tuple (<>.and <synthesis>.text <synthesis>.any))) - -(def: annotation - (Parser (/.Annotation Synthesis)) - (<synthesis>.tuple (<>.and <synthesis>.text (<>.some ..annotation_parameter)))) - -(def: argument - (Parser Argument) - (<synthesis>.tuple (<>.and <synthesis>.text ..value))) - -(def: .public (hidden_method_body arity body) - (-> Nat Synthesis Synthesis) - (case [arity body] - [0 _] body - [1 _] body - - [2 {synthesis.#Control {synthesis.#Branch {synthesis.#Let _ 2 hidden}}}] - hidden - - [_ {synthesis.#Control {synthesis.#Branch {synthesis.#Case _ path}}}] - (loop (again [path (is synthesis.Path path)]) - (case path - (^.or {synthesis.#Pop} - {synthesis.#Access _} - {synthesis.#Bind _} - {synthesis.#Bit_Fork _} - {synthesis.#I64_Fork _} - {synthesis.#F64_Fork _} - {synthesis.#Text_Fork _} - {synthesis.#Alt _}) - body - - {synthesis.#Seq _ next} - (again next) - - {synthesis.#Then hidden} - hidden)) - - _ - body)) - -(def: overriden_method_definition - (Parser [(Environment Synthesis) (/.Overriden_Method Synthesis)]) - (<synthesis>.tuple - (do <>.monad - [_ (<synthesis>.this_text /.overriden_tag) - ownerT ..class - name <synthesis>.text - strict_fp? <synthesis>.bit - annotations (<synthesis>.tuple (<>.some ..annotation)) - vars (<synthesis>.tuple (<>.some ..var)) - self_name <synthesis>.text - arguments (<synthesis>.tuple (<>.some ..argument)) - returnT ..return - exceptionsT (<synthesis>.tuple (<>.some ..class)) - [environment _ _ body] (<| (<synthesis>.function 1) - (<synthesis>.loop (<>.exactly 0 <synthesis>.any)) - <synthesis>.tuple - (<>.after <synthesis>.any) - <synthesis>.any)] - (in [environment - [ownerT name - strict_fp? annotations vars - self_name arguments returnT exceptionsT - (..hidden_method_body (list.size arguments) body)]])))) - -(def: (normalize_path normalize) - (-> (-> Synthesis Synthesis) - (-> Path Path)) - (function (again path) - (case path - (pattern (synthesis.path/then bodyS)) - (synthesis.path/then (normalize bodyS)) - - (^.template [<tag>] - [(pattern {<tag> leftP rightP}) - {<tag> (again leftP) (again rightP)}]) - ([synthesis.#Alt] - [synthesis.#Seq]) - - (^.template [<tag>] - [(pattern {<tag> _}) - path]) - ([synthesis.#Pop] - [synthesis.#Bind] - [synthesis.#Access]) - - {synthesis.#Bit_Fork when then else} - {synthesis.#Bit_Fork when (again then) (maybe#each again else)} - - (^.template [<tag>] - [{<tag> [[test then] elses]} - {<tag> [[test (again then)] - (list#each (function (_ [else_test else_then]) - [else_test (again else_then)]) - elses)]}]) - ([synthesis.#I64_Fork] - [synthesis.#F64_Fork] - [synthesis.#Text_Fork]) - ))) - -(type: Mapping - (Dictionary Synthesis Variable)) - -(def: (local_mapping global_mapping) - (-> Mapping (Environment Synthesis) Mapping) - (|>> list.enumeration - (list#each (function (_ [foreign_id capture]) - [(synthesis.variable/foreign foreign_id) - (|> global_mapping - (dictionary.value capture) - maybe.trusted)])) - (dictionary.of_list synthesis.hash))) - -(def: (init_mapping global_mapping) - (-> Mapping (Environment Synthesis) Mapping) - (|>> list.enumeration - (list#each (function (_ [id capture]) - [(synthesis.variable/foreign id) - {variable.#Local (++ id)}])) - (dictionary.of_list synthesis.hash))) - -(def: (normalize_method_body mapping) - (-> Mapping Synthesis Synthesis) - (function (again body) - (case body - (^.template [<tag>] - [(pattern <tag>) - body]) - ([{synthesis.#Primitive _}] - [(synthesis.constant _)]) - - (pattern (synthesis.variant [lefts right? sub])) - (synthesis.variant [lefts right? (again sub)]) - - (pattern (synthesis.tuple members)) - (synthesis.tuple (list#each again members)) - - (pattern (synthesis.variable var)) - (|> mapping - (dictionary.value body) - (maybe.else var) - synthesis.variable) - - (pattern (synthesis.branch/case [inputS pathS])) - (synthesis.branch/case [(again inputS) (normalize_path again pathS)]) - - (pattern (synthesis.branch/exec [this that])) - (synthesis.branch/exec [(again this) (again that)]) - - (pattern (synthesis.branch/let [inputS register outputS])) - (synthesis.branch/let [(again inputS) register (again outputS)]) - - (pattern (synthesis.branch/if [testS thenS elseS])) - (synthesis.branch/if [(again testS) (again thenS) (again elseS)]) - - (pattern (synthesis.branch/get [path recordS])) - (synthesis.branch/get [path (again recordS)]) - - (pattern (synthesis.loop/scope [offset initsS+ bodyS])) - (synthesis.loop/scope [offset (list#each again initsS+) (again bodyS)]) - - (pattern (synthesis.loop/again updatesS+)) - (synthesis.loop/again (list#each again updatesS+)) - - (pattern (synthesis.function/abstraction [environment arity bodyS])) - (synthesis.function/abstraction [(list#each (function (_ captured) - (case captured - (pattern (synthesis.variable var)) - (|> mapping - (dictionary.value captured) - (maybe.else var) - synthesis.variable) - - _ - captured)) - environment) - arity - bodyS]) - - (pattern (synthesis.function/apply [functionS inputsS+])) - (synthesis.function/apply [(again functionS) (list#each again inputsS+)]) - - {synthesis.#Extension [name inputsS+]} - {synthesis.#Extension [name (list#each again inputsS+)]}))) - -(def: $Object - (type.class "java.lang.Object" (list))) - -(def: (anonymous_init_method env inputsTI) - (-> (Environment Synthesis) (List (Typed Inst)) (Type Method)) - (type.method [(list) - (list.repeated (n.+ (list.size inputsTI) (list.size env)) $Object) - type.void - (list)])) - -(def: (with_anonymous_init class env super_class inputsTI) - (-> (Type Class) (Environment Synthesis) (Type Class) (List (Typed Inst)) Def) - (let [inputs_offset (list.size inputsTI) - inputs! (|> inputsTI - list.enumeration - (list#each (function (_ [register [type term]]) - (let [then! (case (type.primitive? type) - {.#Right type} - (_.unwrap type) - - {.#Left type} - (_.CHECKCAST type))] - (|>> (_.ALOAD (++ register)) - then!)))) - _.fuse) - store_capturedI (|> env - list.size - list.indices - (list#each (.function (_ register) - (|>> (_.ALOAD 0) - (_.ALOAD (n.+ inputs_offset (++ register))) - (_.PUTFIELD class (///reference.foreign_name register) $Object)))) - _.fuse)] - (_def.method {$.#Public} $.noneM "<init>" (anonymous_init_method env inputsTI) - (|>> (_.ALOAD 0) - inputs! - (_.INVOKESPECIAL super_class "<init>" (type.method [(list) (list#each product.left inputsTI) type.void (list)])) - store_capturedI - _.RETURN)))) - -(def: (anonymous_instance generate archive class env inputsTI) - (-> Phase Archive (Type Class) (Environment Synthesis) (List (Typed Inst)) (Operation Inst)) - (do [! phase.monad] - [captureI+ (monad.each ! (generate archive) env)] - (in (|>> (_.NEW class) - _.DUP - ((_.fuse (list#each product.right inputsTI))) - ((_.fuse captureI+)) - (_.INVOKESPECIAL class "<init>" (anonymous_init_method env inputsTI)))))) - -(def: (prepare_argument lux_register argumentT jvm_register) - (-> Register (Type Value) Register [Register Inst]) - (case (type.primitive? argumentT) - {.#Left argumentT} - [(n.+ 1 jvm_register) - (if (n.= lux_register jvm_register) - (|>>) - (|>> (_.ALOAD jvm_register) - (_.ASTORE lux_register)))] - - {.#Right argumentT} - (template.let [(wrap_primitive <shift> <load> <type>) - [[(n.+ <shift> jvm_register) - (|>> (<load> jvm_register) - (_.wrap <type>) - (_.ASTORE lux_register))]]] - (`` (cond (~~ (template [<shift> <load> <type>] - [(# type.equivalence = <type> argumentT) - (wrap_primitive <shift> <load> <type>)] - - [1 _.ILOAD type.boolean] - [1 _.ILOAD type.byte] - [1 _.ILOAD type.short] - [1 _.ILOAD type.int] - [1 _.ILOAD type.char] - [1 _.FLOAD type.float] - [2 _.LLOAD type.long])) - - ... (# type.equivalence = type.double argumentT) - (wrap_primitive 2 _.DLOAD type.double)))))) - -(def: .public (prepare_arguments offset types) - (-> Nat (List (Type Value)) Inst) - (|> types - list.enumeration - (list#mix (function (_ [lux_register type] [jvm_register before]) - (let [[jvm_register' after] (prepare_argument (n.+ offset lux_register) type jvm_register)] - [jvm_register' (|>> before after)])) - (is [Register Inst] [offset (|>>)])) - product.right)) - -(def: .public (returnI returnT) - (-> (Type Return) Inst) - (case (type.void? returnT) - {.#Right returnT} - _.RETURN - - {.#Left returnT} - (case (type.primitive? returnT) - {.#Left returnT} - (case (type.class? returnT) - {.#Some class_name} - (|>> (_.CHECKCAST returnT) - _.ARETURN) - - {.#None} - _.ARETURN) - - {.#Right returnT} - (template.let [(unwrap_primitive <return> <type>) - [(|>> (_.unwrap <type>) - <return>)]] - (`` (cond (~~ (template [<return> <type>] - [(# type.equivalence = <type> returnT) - (unwrap_primitive <return> <type>)] - - [_.IRETURN type.boolean] - [_.IRETURN type.byte] - [_.IRETURN type.short] - [_.IRETURN type.int] - [_.IRETURN type.char] - [_.FRETURN type.float] - [_.LRETURN type.long])) - - ... (# type.equivalence = type.double returnT) - (unwrap_primitive _.DRETURN type.double))))))) - -(def: (method_dependencies archive method) - (-> Archive (/.Overriden_Method Synthesis) (Operation (Set unit.ID))) - (let [[_super _name _strict_fp? _annotations - _t_vars _this _arguments _return _exceptions - bodyS] method] - (cache.dependencies archive bodyS))) - -(def: class::anonymous - Handler - (..custom - [($_ <>.and - ..class - (<synthesis>.tuple (<>.some ..class)) - (<synthesis>.tuple (<>.some ..input)) - (<synthesis>.tuple (<>.some ..overriden_method_definition))) - (function (_ extension_name generate archive [super_class - super_interfaces - inputsTS - overriden_methods]) - (do [! phase.monad] - [all_input_dependencies (monad.each ! (|>> product.right (cache.dependencies archive)) inputsTS) - all_closure_dependencies (|> overriden_methods - (list#each product.left) - list.together - (monad.each ! (cache.dependencies archive))) - all_method_dependencies (monad.each ! (|>> product.right (method_dependencies archive)) overriden_methods) - .let [all_dependencies (cache.all ($_ list#composite - all_input_dependencies - all_closure_dependencies - all_method_dependencies))] - [context _] (generation.with_new_context - archive - all_dependencies - (in [])) - .let [[module_id artifact_id] context - anonymous_class_name (///.class_name context) - class (type.class anonymous_class_name (list)) - total_environment (|> overriden_methods - ... Get all the environments. - (list#each product.left) - ... Combine them. - list#conjoint - ... Remove duplicates. - (set.of_list synthesis.hash) - set.list) - global_mapping (|> total_environment - ... Give them names as "foreign" variables. - list.enumeration - (list#each (function (_ [id capture]) - [capture {variable.#Foreign id}])) - (dictionary.of_list synthesis.hash)) - normalized_methods (list#each (function (_ [environment - [ownerT name - strict_fp? annotations vars - self_name arguments returnT exceptionsT - body]]) - [ownerT name - strict_fp? annotations vars - self_name arguments returnT exceptionsT - (normalize_method_body (..local_mapping global_mapping environment) - body)]) - overriden_methods) - inputsTS (let [mapping (..init_mapping global_mapping total_environment)] - (list#each (function (_ [type term]) - [type (normalize_method_body mapping term)]) - inputsTS))] - inputsTI (generation.with_context artifact_id - (monad.each ! (generate_input generate archive) inputsTS)) - method_definitions (|> normalized_methods - (monad.each ! (function (_ [ownerT name - strict_fp? annotations varsT - self_name arguments returnT exceptionsT - bodyS]) - (do ! - [bodyG (generation.with_context artifact_id - (generate archive bodyS)) - .let [argumentsT (list#each product.right arguments)]] - (in (_def.method {$.#Public} - (if strict_fp? - ($_ $.++M $.finalM $.strictM) - $.finalM) - name - (type.method [varsT argumentsT returnT exceptionsT]) - (|>> (prepare_arguments 1 argumentsT) - bodyG - (returnI returnT))))))) - (# ! each _def.fuse)) - .let [directive [anonymous_class_name - (_def.class {$.#V1_6} {$.#Public} $.finalC - anonymous_class_name (list) - super_class super_interfaces - (|>> (///function.with_environment total_environment) - (..with_anonymous_init class total_environment super_class inputsTI) - method_definitions))]] - _ (generation.execute! directive) - _ (generation.save! artifact_id {.#None} directive)] - (..anonymous_instance generate archive class total_environment inputsTI)))])) - -(def: class_bundle - Bundle - (<| (bundle.prefix "class") - (|> (is Bundle bundle.empty) - (bundle.install "anonymous" class::anonymous) - ))) - -(def: .public bundle - Bundle - (<| (bundle.prefix "jvm") - (|> ..conversion_bundle - (dictionary.merged ..int_bundle) - (dictionary.merged ..long_bundle) - (dictionary.merged ..float_bundle) - (dictionary.merged ..double_bundle) - (dictionary.merged ..char_bundle) - (dictionary.merged ..array_bundle) - (dictionary.merged ..object_bundle) - (dictionary.merged ..member_bundle) - (dictionary.merged ..class_bundle) - ))) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/function.lux b/lux-jvm/source/luxc/lang/translation/jvm/function.lux deleted file mode 100644 index 49147b68b..000000000 --- a/lux-jvm/source/luxc/lang/translation/jvm/function.lux +++ /dev/null @@ -1,359 +0,0 @@ -(.using - [library - [lux {"-" Type Label Primitive function} - [abstract - ["[0]" monad {"+" do}] - ["[0]" enum]] - [control - ["[0]" pipe] - ["[0]" function]] - [data - ["[0]" product] - [text - ["%" format {"+" format}]] - [collection - ["[0]" list ("[1]@[0]" functor monoid)]]] - [math - [number - ["n" nat] - ["i" int]]] - [target - [jvm - ["[0]" type {"+" Type} - ["[0]" category {"+" Void Value Return Primitive Object Class Array Var Parameter Method}]]]] - [tool - [compiler - [arity {"+" Arity}] - ["[0]" phase] - [reference - [variable {"+" Register}]] - [language - [lux - [analysis {"+" Environment}] - [synthesis {"+" Synthesis Abstraction Apply}] - ["[0]" generation]]] - [meta - [archive {"+" Archive} - ["[0]" unit]] - ["[0]" cache "_" - ["[1]" artifact]]]]]]] - [luxc - [lang - [host - ["$" jvm {"+" Label Inst Def Operation Phase Generator} - ["[0]" def] - ["_" inst]]]]] - ["[0]" // - ["[1][0]" runtime] - ["[0]" reference]]) - -(def: arity_field Text "arity") - -(def: poly_arg? - (-> Arity Bit) - (n.> 1)) - -(def: (captured_args env) - (-> (Environment Synthesis) (List (Type Value))) - (list.repeated (list.size env) //.$Value)) - -(def: (init_method env arity) - (-> (Environment Synthesis) Arity (Type Method)) - (if (poly_arg? arity) - (type.method [(list) - (list.together (list (captured_args env) - (list type.int) - (list.repeated (-- arity) //.$Value))) - type.void - (list)]) - (type.method [(list) (captured_args env) type.void (list)]))) - -(def: (implementation_method arity) - (type.method [(list) (list.repeated arity //.$Value) //.$Value (list)])) - -(def: get_amount_of_partialsI - Inst - (|>> (_.ALOAD 0) - (_.GETFIELD //.$Function //runtime.partials_field type.int))) - -(def: (load_fieldI class field) - (-> (Type Class) Text Inst) - (|>> (_.ALOAD 0) - (_.GETFIELD class field //.$Value))) - -(def: (inputsI start amount) - (-> Register Nat Inst) - (|> (enum.range n.enum start (n.+ start (-- amount))) - (list@each _.ALOAD) - _.fuse)) - -(def: (applysI start amount) - (-> Register Nat Inst) - (let [max_args (n.min amount //runtime.num_apply_variants) - later_applysI (if (n.> //runtime.num_apply_variants amount) - (applysI (n.+ //runtime.num_apply_variants start) (n.- //runtime.num_apply_variants amount)) - function.identity)] - (|>> (_.CHECKCAST //.$Function) - (inputsI start max_args) - (_.INVOKEVIRTUAL //.$Function //runtime.apply_method (//runtime.apply_signature max_args)) - later_applysI))) - -(def: (inc_intI by) - (-> Nat Inst) - (|>> (_.int (.int by)) - _.IADD)) - -(def: (nullsI amount) - (-> Nat Inst) - (|> _.NULL - (list.repeated amount) - _.fuse)) - -(def: (instance generate archive class arity env) - (-> Phase Archive (Type Class) Arity (Environment Synthesis) (Operation Inst)) - (do [@ phase.monad] - [captureI+ (monad.each @ (generate archive) env) - .let [argsI (if (poly_arg? arity) - (|> (nullsI (-- arity)) - (list (_.int +0)) - _.fuse) - function.identity)]] - (in (|>> (_.NEW class) - _.DUP - (_.fuse captureI+) - argsI - (_.INVOKESPECIAL class "<init>" (init_method env arity)))))) - -(def: (reset_method return) - (-> (Type Class) (Type Method)) - (type.method [(list) (list) return (list)])) - -(def: (with_reset class arity env) - (-> (Type Class) Arity (Environment Synthesis) Def) - (def.method {$.#Public} $.noneM "reset" (reset_method class) - (if (poly_arg? arity) - (let [env_size (list.size env) - captureI (|> (case env_size - 0 (list) - _ (enum.range n.enum 0 (-- env_size))) - (list@each (.function (_ source) - (|>> (_.ALOAD 0) - (_.GETFIELD class (reference.foreign_name source) //.$Value)))) - _.fuse) - argsI (|> (nullsI (-- arity)) - (list (_.int +0)) - _.fuse)] - (|>> (_.NEW class) - _.DUP - captureI - argsI - (_.INVOKESPECIAL class "<init>" (init_method env arity)) - _.ARETURN)) - (|>> (_.ALOAD 0) - _.ARETURN)))) - -(def: (with_implementation arity @begin bodyI) - (-> Nat Label Inst Def) - (def.method {$.#Public} $.strictM "impl" (implementation_method arity) - (|>> (_.label @begin) - bodyI - _.ARETURN))) - -(def: function_init_method - (type.method [(list) (list type.int) type.void (list)])) - -(def: (function_init arity env_size) - (-> Arity Nat Inst) - (if (n.= 1 arity) - (|>> (_.int +0) - (_.INVOKESPECIAL //.$Function "<init>" function_init_method)) - (|>> (_.ILOAD (++ env_size)) - (_.INVOKESPECIAL //.$Function "<init>" function_init_method)))) - -(def: (with_init class env arity) - (-> (Type Class) (Environment Synthesis) Arity Def) - (let [env_size (list.size env) - offset_partial (is (-> Nat Nat) - (|>> ++ (n.+ env_size))) - store_capturedI (|> (case env_size - 0 (list) - _ (enum.range n.enum 0 (-- env_size))) - (list@each (.function (_ register) - (|>> (_.ALOAD 0) - (_.ALOAD (++ register)) - (_.PUTFIELD class (reference.foreign_name register) //.$Value)))) - _.fuse) - store_partialI (if (poly_arg? arity) - (|> (enum.range n.enum 0 (n.- 2 arity)) - (list@each (.function (_ idx) - (let [register (offset_partial idx)] - (|>> (_.ALOAD 0) - (_.ALOAD (++ register)) - (_.PUTFIELD class (reference.partial_name idx) //.$Value))))) - _.fuse) - function.identity)] - (def.method {$.#Public} $.noneM "<init>" (init_method env arity) - (|>> (_.ALOAD 0) - (function_init arity env_size) - store_capturedI - store_partialI - _.RETURN)))) - -(def: (with_apply class env function_arity @begin bodyI apply_arity) - (-> (Type Class) (Environment Synthesis) Arity Label Inst Arity - Def) - (let [num_partials (-- function_arity) - @default ($.new_label []) - @labels (list@each $.new_label (list.repeated num_partials [])) - over_extent (|> (.int function_arity) (i.- (.int apply_arity))) - casesI (|> (list@composite @labels (list @default)) - (list.zipped_2 (enum.range n.enum 0 num_partials)) - (list@each (.function (_ [stage @label]) - (let [load_partialsI (if (n.> 0 stage) - (|> (enum.range n.enum 0 (-- stage)) - (list@each (|>> reference.partial_name (load_fieldI class))) - _.fuse) - function.identity)] - (cond (i.= over_extent (.int stage)) - (|>> (_.label @label) - (_.ALOAD 0) - (pipe.when [(pipe.new (n.> 0 stage) [])] - [(_.INVOKEVIRTUAL class "reset" (reset_method class))]) - load_partialsI - (inputsI 1 apply_arity) - (_.INVOKEVIRTUAL class "impl" (implementation_method function_arity)) - _.ARETURN) - - (i.> over_extent (.int stage)) - (let [args_to_completion (|> function_arity (n.- stage)) - args_left (|> apply_arity (n.- args_to_completion))] - (|>> (_.label @label) - (_.ALOAD 0) - (_.INVOKEVIRTUAL class "reset" (reset_method class)) - load_partialsI - (inputsI 1 args_to_completion) - (_.INVOKEVIRTUAL class "impl" (implementation_method function_arity)) - (applysI (++ args_to_completion) args_left) - _.ARETURN)) - - ... (i.< over_extent (.int stage)) - (let [env_size (list.size env) - load_capturedI (|> (case env_size - 0 (list) - _ (enum.range n.enum 0 (-- env_size))) - (list@each (|>> reference.foreign_name (load_fieldI class))) - _.fuse)] - (|>> (_.label @label) - (_.NEW class) - _.DUP - load_capturedI - get_amount_of_partialsI - (inc_intI apply_arity) - load_partialsI - (inputsI 1 apply_arity) - (nullsI (|> num_partials (n.- apply_arity) (n.- stage))) - (_.INVOKESPECIAL class "<init>" (init_method env function_arity)) - _.ARETURN)) - )))) - _.fuse)] - (def.method {$.#Public} $.noneM //runtime.apply_method (//runtime.apply_signature apply_arity) - (|>> get_amount_of_partialsI - (_.TABLESWITCH +0 (|> num_partials -- .int) - @default @labels) - casesI - )))) - -(def: .public with_environment - (-> (Environment Synthesis) Def) - (|>> list.enumeration - (list@each (.function (_ [env_idx env_source]) - (def.field {$.#Private} $.finalF (reference.foreign_name env_idx) //.$Value))) - def.fuse)) - -(def: (with_partial arity) - (-> Arity Def) - (if (poly_arg? arity) - (|> (enum.range n.enum 0 (n.- 2 arity)) - (list@each (.function (_ idx) - (def.field {$.#Private} $.finalF (reference.partial_name idx) //.$Value))) - def.fuse) - function.identity)) - -(def: .public (with_function generate archive @begin class env arity bodyI) - (-> Phase Archive Label Text (Environment Synthesis) Arity Inst - (Operation [Def Inst])) - (let [classD (type.class class (list)) - applyD (is Def - (if (poly_arg? arity) - (|> (n.min arity //runtime.num_apply_variants) - (enum.range n.enum 1) - (list@each (with_apply classD env arity @begin bodyI)) - (list& (with_implementation arity @begin bodyI)) - def.fuse) - (def.method {$.#Public} $.strictM //runtime.apply_method (//runtime.apply_signature 1) - (|>> (_.label @begin) - bodyI - _.ARETURN)))) - functionD (is Def - (|>> (def.int_field {$.#Public} ($_ $.++F $.staticF $.finalF) arity_field (.int arity)) - (with_environment env) - (with_partial arity) - (with_init classD env arity) - (with_reset classD arity env) - applyD - ))] - (do phase.monad - [instanceI (..instance generate archive classD arity env)] - (in [functionD instanceI])))) - -(def: .public (function' forced_context generate archive [env arity bodyS]) - (-> (Maybe unit.ID) (Generator Abstraction)) - (do [! phase.monad] - [@begin _.make_label - dependencies (cache.dependencies archive bodyS) - [function_context bodyI] (case forced_context - {.#Some function_context} - (do ! - [without_context (generation.with_anchor [@begin 1] - (generate archive bodyS))] - (in [function_context - without_context])) - - {.#None} - (generation.with_new_context archive dependencies - (generation.with_anchor [@begin 1] - (generate archive bodyS)))) - .let [function_class (//.class_name function_context)] - [functionD instanceI] (..with_function generate archive @begin function_class env arity bodyI) - .let [directive [function_class - (def.class {$.#V1_6} {$.#Public} $.finalC - function_class (list) - //.$Function (list) - functionD)]] - _ (generation.execute! directive) - _ (case forced_context - {.#None} - (generation.save! (product.right function_context) {.#None} directive) - - {.#Some function_context} - (in []))] - (in instanceI))) - -(def: .public function - (Generator Abstraction) - (..function' {.#None})) - -(def: .public (call generate archive [functionS argsS]) - (Generator Apply) - (do [@ phase.monad] - [functionI (generate archive functionS) - argsI (monad.each @ (generate archive) argsS) - .let [applyI (|> argsI - (list.sub //runtime.num_apply_variants) - (list@each (.function (_ subI+) - (|>> (_.CHECKCAST //.$Function) - (_.fuse subI+) - (_.INVOKEVIRTUAL //.$Function //runtime.apply_method (//runtime.apply_signature (list.size subI+)))))) - _.fuse)]] - (in (|>> functionI - applyI)))) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/loop.lux b/lux-jvm/source/luxc/lang/translation/jvm/loop.lux deleted file mode 100644 index 4449b3606..000000000 --- a/lux-jvm/source/luxc/lang/translation/jvm/loop.lux +++ /dev/null @@ -1,85 +0,0 @@ -(.using - [library - [lux "*" - [abstract - ["[0]" monad {"+" do}]] - [control - ["[0]" function]] - [data - [collection - ["[0]" list ("[1]@[0]" functor monoid)]]] - [math - [number - ["n" nat]]] - [tool - [compiler - ["[0]" phase] - [reference - [variable {"+" Register}]] - [language - [lux - ["[0]" synthesis {"+" Synthesis}] - ["[0]" generation]]]]]]] - [luxc - [lang - [host - [jvm {"+" Inst Operation Phase Generator} - ["_" inst]]]]] - ["[0]" //]) - -(def: (invariant? expected actual) - (-> Register Synthesis Bit) - (case actual - (pattern (synthesis.variable/local actual)) - (n.= expected actual) - - _ - false)) - -(def: .public (again translate archive argsS) - (Generator (List Synthesis)) - (do [@ phase.monad] - [[@begin start] generation.anchor - .let [pairs (|> argsS - list.enumeration - (list@each (function (_ [register argument]) - [(n.+ start register) argument])))] - ... It may look weird that first I compile the values separately, - ... and then I compile the stores/allocations. - ... It must be done that way in order to avoid a potential bug. - ... Let's say that you'll recur with 2 expressions: X and Y. - ... If Y depends on the value of X, and you don't compile values - ... and stores separately, then by the time Y is evaluated, it - ... will refer to the new value of X, instead of the old value, and - ... shouldn't be the case. - valuesI+ (monad.each @ (function (_ [register argS]) - (is (Operation Inst) - (if (invariant? register argS) - (in function.identity) - (translate archive argS)))) - pairs) - .let [storesI+ (list@each (function (_ [register argS]) - (is Inst - (if (invariant? register argS) - function.identity - (_.ASTORE register)))) - (list.reversed pairs))]] - (in (|>> (_.fuse valuesI+) - (_.fuse storesI+) - (_.GOTO @begin))))) - -(def: .public (scope translate archive [start initsS+ iterationS]) - (Generator [Nat (List Synthesis) Synthesis]) - (do [@ phase.monad] - [@begin _.make_label - initsI+ (monad.each @ (translate archive) initsS+) - iterationI (generation.with_anchor [@begin start] - (translate archive iterationS)) - .let [initializationI (|> (list.enumeration initsI+) - (list@each (function (_ [register initI]) - (|>> initI - (_.ASTORE (n.+ start register))))) - _.fuse)]] - (in (|>> initializationI - (_.label @begin) - iterationI)))) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/primitive.lux b/lux-jvm/source/luxc/lang/translation/jvm/primitive.lux deleted file mode 100644 index 734b55316..000000000 --- a/lux-jvm/source/luxc/lang/translation/jvm/primitive.lux +++ /dev/null @@ -1,114 +0,0 @@ -(.using - [library - [lux {"-" i64} - ["[0]" ffi {"+" import:}] - [macro - ["^" pattern]] - [math - [number - ["i" int]]] - [target - [jvm - ["[0]" type]]] - [tool - [compiler - [phase ("operation@[0]" monad)]]]]] - [luxc - [lang - [host - ["[0]" jvm {"+" Inst Operation} - ["_" inst]]]]]) - -(def: .public bit - (-> Bit (Operation Inst)) - (let [Boolean (type.class "java.lang.Boolean" (list))] - (function (_ value) - (operation@in (_.GETSTATIC Boolean (if value "TRUE" "FALSE") Boolean))))) - -(import: java/lang/Byte - "[1]::[0]" - ("static" MAX_VALUE byte) - ("static" MIN_VALUE byte)) - -(import: java/lang/Short - "[1]::[0]" - ("static" MAX_VALUE short) - ("static" MIN_VALUE short)) - -(def: .public (i64 value) - (-> (I64 Any) (Operation Inst)) - (case (.int value) - (^.template [<int> <instruction>] - [<int> - (operation@in (|>> <instruction> (_.wrap type.long)))]) - ([+0 _.LCONST_0] - [+1 _.LCONST_1]) - - (^.template [<int> <instruction>] - [<int> - (operation@in (|>> <instruction> _.I2L (_.wrap type.long)))]) - ([-1 _.ICONST_M1] - ... [+0 _.ICONST_0] - ... [+1 _.ICONST_1] - [+2 _.ICONST_2] - [+3 _.ICONST_3] - [+4 _.ICONST_4] - [+5 _.ICONST_5]) - - value - (let [constantI (cond (and (i.>= (java/lang/Byte::MIN_VALUE) value) - (i.<= (java/lang/Byte::MAX_VALUE) value)) - (|>> (_.BIPUSH value) _.I2L) - - (and (i.>= (java/lang/Short::MIN_VALUE) value) - (i.<= (java/lang/Short::MAX_VALUE) value)) - (|>> (_.SIPUSH value) _.I2L) - - ... else - (|> value .int _.long))] - (operation@in (|>> constantI (_.wrap type.long)))))) - -(import: java/lang/Double - "[1]::[0]" - ("static" doubleToRawLongBits "manual" [double] int)) - -(def: d0-bits - Int - (java/lang/Double::doubleToRawLongBits +0.0)) - -(def: .public (f64 value) - (-> Frac (Operation Inst)) - (case value - (^.template [<int> <instruction>] - [<int> - (operation@in (|>> <instruction> (_.wrap type.double)))]) - ([+1.0 _.DCONST_1]) - - (^.template [<int> <instruction>] - [<int> - (operation@in (|>> <instruction> _.F2D (_.wrap type.double)))]) - ([+2.0 _.FCONST_2]) - - (^.template [<int> <instruction>] - [<int> - (operation@in (|>> <instruction> _.I2D (_.wrap type.double)))]) - ([-1.0 _.ICONST_M1] - ... [+0.0 _.ICONST_0] - ... [+1.0 _.ICONST_1] - ... [+2.0 _.ICONST_2] - [+3.0 _.ICONST_3] - [+4.0 _.ICONST_4] - [+5.0 _.ICONST_5]) - - _ - (let [constantI (if (|> value - (as java/lang/Double) - java/lang/Double::doubleToRawLongBits - (i.= ..d0-bits)) - _.DCONST_0 - (_.double value))] - (operation@in (|>> constantI (_.wrap type.double)))))) - -(def: .public text - (-> Text (Operation Inst)) - (|>> _.string operation@in)) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/program.lux b/lux-jvm/source/luxc/lang/translation/jvm/program.lux deleted file mode 100644 index 4efe0fd3d..000000000 --- a/lux-jvm/source/luxc/lang/translation/jvm/program.lux +++ /dev/null @@ -1,94 +0,0 @@ -(.using - [library - [lux "*" - [data - [text - ["%" format {"+" format}]]] - [target - [jvm - ["$t" type]]] - [tool - [compiler - [language - [lux - [program {"+" Program}]]] - [meta - [archive - ["[0]" unit]]]]]]] - [luxc - [lang - [host - ["_" jvm - ["$d" def] - ["$i" inst]]] - [translation - ["[0]" jvm - ["[0]" runtime]]]]]) - -(def: ^Object ($t.class "java.lang.Object" (list))) - -(def: .public (program artifact_name context programI) - (-> (-> unit.ID Text) (Program _.Inst _.Definition)) - (let [nilI runtime.noneI - num_inputsI (|>> ($i.ALOAD 0) $i.ARRAYLENGTH) - --I (|>> ($i.int +1) $i.ISUB) - headI (|>> $i.DUP - ($i.ALOAD 0) - $i.SWAP - $i.AALOAD - $i.SWAP - $i.DUP_X2 - $i.POP) - pairI (|>> ($i.int +2) - ($i.ANEWARRAY ..^Object) - $i.DUP_X1 - $i.SWAP - ($i.int +0) - $i.SWAP - $i.AASTORE - $i.DUP_X1 - $i.SWAP - ($i.int +1) - $i.SWAP - $i.AASTORE) - consI (|>> ($i.int +0) - ($i.string "") - $i.DUP2_X1 - $i.POP2 - runtime.variantI) - prepare_input_listI (<| $i.with_label (function (_ @loop)) - $i.with_label (function (_ @end)) - (|>> nilI - num_inputsI - ($i.label @loop) - --I - $i.DUP - ($i.IFLT @end) - headI - pairI - consI - $i.SWAP - ($i.GOTO @loop) - ($i.label @end) - $i.POP)) - feed_inputsI ($i.INVOKEVIRTUAL jvm.$Function runtime.apply_method (runtime.apply_signature 1)) - run_ioI (|>> ($i.CHECKCAST jvm.$Function) - $i.NULL - ($i.INVOKEVIRTUAL jvm.$Function runtime.apply_method (runtime.apply_signature 1))) - main_type ($t.method [(list) - (list ($t.array ($t.class "java.lang.String" (list)))) - $t.void - (list)]) - class (artifact_name context)] - [class - ($d.class {_.#V1_6} - {_.#Public} _.finalC - class - (list) ..^Object - (list) - (|>> ($d.method {_.#Public} _.staticM "main" main_type - (|>> programI - prepare_input_listI - feed_inputsI - run_ioI - $i.RETURN))))])) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/reference.lux b/lux-jvm/source/luxc/lang/translation/jvm/reference.lux deleted file mode 100644 index 88b2af2ed..000000000 --- a/lux-jvm/source/luxc/lang/translation/jvm/reference.lux +++ /dev/null @@ -1,67 +0,0 @@ -(.using - [library - [lux {"-" local} - [abstract - [monad {"+" do}]] - [data - [text - ["%" format {"+" format}]]] - [target - [jvm - ["[0]" type]]] - [tool - [compiler - [reference - ["[0]" variable {"+" Register Variable}]] - ["[0]" phase ("operation@[0]" monad)] - [meta - [archive {"+" Archive}]] - [language - [lux - ["[0]" generation]]]]]]] - [luxc - [lang - [host - [jvm {"+" Inst Operation} - ["_" inst]]]]] - ["[0]" // - ["[1][0]" runtime]]) - -(template [<name> <prefix>] - [(def: .public <name> - (-> Nat Text) - (|>> %.nat (format <prefix>)))] - - [foreign_name "f"] - [partial_name "p"] - ) - -(def: (foreign archive variable) - (-> Archive Register (Operation Inst)) - (do [@ phase.monad] - [class_name (# @ each //.class_name - (generation.context archive))] - (in (|>> (_.ALOAD 0) - (_.GETFIELD (type.class class_name (list)) - (|> variable .nat foreign_name) - //.$Value))))) - -(def: local - (-> Register Inst) - (|>> _.ALOAD)) - -(def: .public (variable archive variable) - (-> Archive Variable (Operation Inst)) - (case variable - {variable.#Local variable} - (operation@in (local variable)) - - {variable.#Foreign variable} - (foreign archive variable))) - -(def: .public (constant archive name) - (-> Archive Symbol (Operation Inst)) - (do [@ phase.monad] - [class_name (# @ each //.class_name - (generation.remember archive name))] - (in (_.GETSTATIC (type.class class_name (list)) //.value_field //.$Value)))) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux b/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux deleted file mode 100644 index 76c170725..000000000 --- a/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux +++ /dev/null @@ -1,425 +0,0 @@ -(.using - [library - [lux {"-" Type Label Primitive try} - [abstract - [monad {"+" do}] - ["[0]" enum]] - [data - [binary {"+" Binary}] - ["[0]" product] - [text - ["%" format {"+" format}]] - [collection - ["[0]" list ("[1]@[0]" functor)] - ["[0]" sequence] - ["[0]" set]]] - ["[0]" math - [number - ["n" nat]]] - [target - [jvm - ["[0]" type {"+" Type} - ["[0]" category {"+" Void Value' Value Return' Return Primitive Object Class Array Var Parameter Method}] - ["[0]" reflection]]]] - [tool - [compiler - [arity {"+" Arity}] - ["[0]" phase] - [language - [lux - ["[0]" synthesis] - ["[0]" generation]]] - [meta - [archive {"+" Output} - ["[0]" artifact] - ["[0]" registry {"+" Registry}] - ["[0]" unit]]]]]]] - [luxc - [lang - [host - ["$" jvm {"+" Label Inst Def Operation} - ["$d" def] - ["_" inst]]]]] - ["[0]" // {"+" ByteCode}]) - -(def: $Text (type.class "java.lang.String" (list))) -(def: .public $Lefts type.int) -(def: .public $Right? (type.class "java.lang.Object" (list))) -(def: .public $Value (type.class "java.lang.Object" (list))) -(def: .public $Index type.int) -(def: .public $Stack (type.array $Value)) -(def: $Throwable (type.class "java.lang.Throwable" (list))) - -(def: nullary_init_methodT - (type.method [(list) (list) type.void (list)])) - -(def: throw_methodT - (type.method [(list) (list) type.void (list)])) - -(def: .public logI - Inst - (let [PrintStream (type.class "java.io.PrintStream" (list)) - outI (_.GETSTATIC (type.class "java.lang.System" (list)) "out" PrintStream) - printI (function (_ method) - (_.INVOKEVIRTUAL PrintStream method (type.method [(list) (list $Value) type.void (list)])))] - (|>> outI (_.string "LOG: ") (printI "print") - outI _.SWAP (printI "println")))) - -(def: variant_method - (type.method [(list) (list $Lefts $Right? $Value) //.$Variant (list)])) - -(def: .public variantI - Inst - (_.INVOKESTATIC //.$Runtime "variant_make" variant_method)) - -(def: .public leftI - Inst - (|>> _.ICONST_0 - _.NULL - _.DUP2_X1 - _.POP2 - variantI)) - -(def: .public rightI - Inst - (|>> _.ICONST_0 - (_.string "") - _.DUP2_X1 - _.POP2 - variantI)) - -(def: .public someI Inst rightI) - -(def: .public noneI - Inst - (|>> _.ICONST_0 - _.NULL - (_.string synthesis.unit) - variantI)) - -(def: (tryI unsafeI) - (-> Inst Inst) - (<| _.with_label (function (_ @from)) - _.with_label (function (_ @to)) - _.with_label (function (_ @handler)) - (|>> (_.try @from @to @handler (type.class "java.lang.Exception" (list))) - (_.label @from) - unsafeI - someI - _.ARETURN - (_.label @to) - (_.label @handler) - noneI - _.ARETURN))) - -(def: .public partials_field Text "partials") -(def: .public apply_method Text "apply") -(def: .public num_apply_variants Nat 8) - -(def: .public (apply_signature arity) - (-> Arity (Type Method)) - (type.method [(list) (list.repeated arity $Value) $Value (list)])) - -(def: adt_methods - Def - (let [store_leftsI (|>> _.DUP _.ICONST_0 (_.ILOAD 0) (_.wrap type.int) _.AASTORE) - store_flagI (|>> _.DUP _.ICONST_1 (_.ALOAD 1) _.AASTORE) - store_valueI (|>> _.DUP _.ICONST_2 (_.ALOAD 2) _.AASTORE)] - (|>> ($d.method {$.#Public} $.staticM "variant_make" - (type.method [(list) (list $Lefts $Right? $Value) //.$Variant (list)]) - (|>> _.ICONST_3 - (_.ANEWARRAY $Value) - store_leftsI - store_flagI - store_valueI - _.ARETURN))))) - -(def: frac_methods - Def - (|>> ($d.method {$.#Public} $.staticM "decode_frac" (type.method [(list) (list $Text) //.$Variant (list)]) - (tryI - (|>> (_.ALOAD 0) - (_.INVOKESTATIC (type.class "java.lang.Double" (list)) "parseDouble" (type.method [(list) (list $Text) type.double (list)])) - (_.wrap type.double)))) - )) - -(def: (illegal_state_exception message) - (-> Text Inst) - (let [IllegalStateException (type.class "java.lang.IllegalStateException" (list))] - (|>> (_.NEW IllegalStateException) - _.DUP - (_.string message) - (_.INVOKESPECIAL IllegalStateException "<init>" (type.method [(list) (list $Text) type.void (list)]))))) - -(def: pm_methods - Def - (let [tuple_sizeI (|>> (_.ALOAD 0) - _.ARRAYLENGTH) - last_rightI (|>> tuple_sizeI - _.ICONST_1 - _.ISUB) - leftsI (_.ILOAD 1) - left_indexI leftsI - sub_leftsI (|>> leftsI - last_rightI - _.ISUB) - sub_tupleI (|>> (_.ALOAD 0) - last_rightI - _.AALOAD - (_.CHECKCAST //.$Tuple)) - recurI (is (-> Label Inst) - (function (_ @loop) - (|>> sub_leftsI (_.ISTORE 1) - sub_tupleI (_.ASTORE 0) - (_.GOTO @loop))))] - (|>> ($d.method {$.#Public} $.staticM "pm_fail" throw_methodT - (|>> (illegal_state_exception "Invalid expression for pattern-matching.") - _.ATHROW)) - ($d.method {$.#Public} $.staticM "apply_fail" throw_methodT - (|>> (illegal_state_exception "Error while applying function.") - _.ATHROW)) - ($d.method {$.#Public} $.staticM "pm_push" (type.method [(list) (list $Stack $Value) $Stack (list)]) - (|>> _.ICONST_2 - (_.ANEWARRAY $Value) - _.DUP - _.ICONST_1 - (_.ALOAD 0) - _.AASTORE - _.DUP - _.ICONST_0 - (_.ALOAD 1) - _.AASTORE - _.ARETURN)) - ($d.method {$.#Public} $.staticM "pm_variant" (type.method [(list) (list //.$Variant $Lefts $Right?) $Value (list)]) - (<| _.with_label (function (_ @loop)) - _.with_label (function (_ @perfect_match!)) - _.with_label (function (_ @lefts_match!)) - _.with_label (function (_ @maybe_nested)) - _.with_label (function (_ @mismatch!)) - (let [$variant (_.ALOAD 0) - $lefts (_.ILOAD 1) - $right? (_.ALOAD 2) - - variant_partI (is (-> Nat Inst) - (function (_ idx) - (|>> (_.int (.int idx)) _.AALOAD))) - ::lefts (is Inst - (|>> (variant_partI 0) - (_.unwrap type.int))) - ::right? (variant_partI 1) - ::value (variant_partI 2) - - not_found _.NULL - - super_nested_lefts (|>> _.SWAP ... variant::lefts, lefts - _.ISUB - (_.int +1) - _.ISUB) - super_nested (|>> super_nested_lefts ... super_lefts - $variant ::right? ... super_lefts, super_right? - $variant ::value ... super_lefts, super_right?, super_value - ..variantI) - - update_$variant (|>> $variant ::value - (_.CHECKCAST //.$Variant) - (_.ASTORE 0)) - update_$lefts (|>> _.ISUB - (_.int +1) - _.ISUB) - iterate! (is (-> Label Inst) - (function (_ @loop) - (|>> update_$variant - update_$lefts - (_.GOTO @loop))))]) - (|>> $lefts ... lefts - (_.label @loop) - $variant ::lefts ... lefts, variant::lefts - _.DUP2 (_.IF_ICMPEQ @lefts_match!) ... lefts, variant::lefts - _.DUP2 (_.IF_ICMPGT @maybe_nested) ... lefts, variant::lefts - $right? (_.IFNULL @mismatch!) ... lefts, variant::lefts - super_nested ... super_variant - _.ARETURN - ........................... - ...... @lefts_match! ...... - ........................... - (_.label @lefts_match!) ... lefts, variant::lefts - $right? ... lefts, variant::lefts, right? - $variant ::right? ... lefts, variant::lefts, right?, variant::right? - (_.IF_ACMPEQ @perfect_match!) ... lefts, variant::lefts - ........................ - ...... @mismatch! ...... - ........................ - (_.label @mismatch!) ... lefts, variant::lefts - ... _.POP2 - not_found - _.ARETURN - (_.label @maybe_nested) ... lefts, variant::lefts - $variant ::right? ... lefts, variant::lefts, variant::right? - (_.IFNULL @mismatch!) ... lefts, variant::lefts - (iterate! @loop) - ............................. - ...... @perfect_match! ...... - ............................. - (_.label @perfect_match!) ... lefts, variant::lefts - ... _.POP2 - $variant ::value - _.ARETURN))) - ($d.method {$.#Public} $.staticM "tuple_left" (type.method [(list) (list //.$Tuple $Index) $Value (list)]) - (<| _.with_label (function (_ @loop)) - _.with_label (function (_ @recursive)) - (let [left_accessI (|>> (_.ALOAD 0) left_indexI _.AALOAD)]) - (|>> (_.label @loop) - leftsI last_rightI (_.IF_ICMPGE @recursive) - left_accessI - _.ARETURN - (_.label @recursive) - ... Recursive - (recurI @loop)))) - ($d.method {$.#Public} $.staticM "tuple_right" (type.method [(list) (list //.$Tuple $Index) $Value (list)]) - (<| _.with_label (function (_ @loop)) - _.with_label (function (_ @not_tail)) - _.with_label (function (_ @slice)) - (let [right_indexI (|>> leftsI - _.ICONST_1 - _.IADD) - right_accessI (|>> (_.ALOAD 0) - _.SWAP - _.AALOAD) - sub_rightI (|>> (_.ALOAD 0) - right_indexI - tuple_sizeI - (_.INVOKESTATIC (type.class "java.util.Arrays" (list)) "copyOfRange" - (type.method [(list) - (list //.$Tuple $Index $Index) - //.$Tuple - (list)])))]) - (|>> (_.label @loop) - last_rightI right_indexI - _.DUP2 (_.IF_ICMPNE @not_tail) - ... _.POP - right_accessI - _.ARETURN - (_.label @not_tail) - (_.IF_ICMPGT @slice) - ... Must recurse - (recurI @loop) - (_.label @slice) - sub_rightI - _.ARETURN - ))) - ))) - -(def: .public try - (type.method [(list) (list //.$Function) //.$Variant (list)])) - -(def: io_methods - Def - (let [StringWriter (type.class "java.io.StringWriter" (list)) - PrintWriter (type.class "java.io.PrintWriter" (list)) - string_writerI (|>> (_.NEW StringWriter) - _.DUP - (_.INVOKESPECIAL StringWriter "<init>" nullary_init_methodT)) - print_writerI (|>> (_.NEW PrintWriter) - _.SWAP - _.DUP2 - _.POP - _.SWAP - (_.boolean true) - (_.INVOKESPECIAL PrintWriter "<init>" (type.method [(list) (list (type.class "java.io.Writer" (list)) type.boolean) type.void (list)])) - )] - (|>> ($d.method {$.#Public} $.staticM "try" ..try - (<| _.with_label (function (_ @from)) - _.with_label (function (_ @to)) - _.with_label (function (_ @handler)) - (|>> (_.try @from @to @handler $Throwable) - (_.label @from) - (_.ALOAD 0) - _.NULL - (_.INVOKEVIRTUAL //.$Function apply_method (apply_signature 1)) - rightI - _.ARETURN - (_.label @to) - (_.label @handler) - string_writerI ... TW - _.DUP2 ... TWTW - print_writerI ... TWTP - (_.INVOKEVIRTUAL $Throwable "printStackTrace" (type.method [(list) (list (type.class "java.io.PrintWriter" (list))) type.void (list)])) ... TW - (_.INVOKEVIRTUAL StringWriter "toString" (type.method [(list) (list) $Text (list)])) ... TS - _.SWAP _.POP leftI - _.ARETURN))) - ))) - -(def: reflection - (All (_ category) - (-> (Type (<| Return' Value' category)) Text)) - (|>> type.reflection reflection.reflection)) - -(def: runtime_id - 0) - -(def: translate_runtime - (Operation [artifact.ID (Maybe Text) Binary]) - (let [runtime_class (..reflection //.$Runtime) - bytecode ($d.class {$.#V1_6} {$.#Public} $.finalC runtime_class (list) (type.class "java.lang.Object" (list)) (list) - (|>> adt_methods - frac_methods - pm_methods - io_methods)) - directive [runtime_class bytecode]] - (do phase.monad - [_ (generation.execute! directive) - _ (generation.save! ..runtime_id {.#None} directive)] - (in [..runtime_id {.#None} bytecode])))) - -(def: function_id - 1) - -(def: translate_function - (Operation [artifact.ID (Maybe Text) Binary]) - (let [applyI (|> (enum.range n.enum 2 num_apply_variants) - (list@each (function (_ arity) - ($d.method {$.#Public} $.noneM apply_method (apply_signature arity) - (let [preI (|> (enum.range n.enum 0 (-- arity)) - (list@each _.ALOAD) - _.fuse)] - (|>> preI - (_.INVOKEVIRTUAL //.$Function apply_method (apply_signature (-- arity))) - (_.CHECKCAST //.$Function) - (_.ALOAD arity) - (_.INVOKEVIRTUAL //.$Function apply_method (apply_signature 1)) - _.ARETURN))))) - (list& ($d.abstract_method {$.#Public} $.noneM apply_method (apply_signature 1))) - $d.fuse) - $Object (type.class "java.lang.Object" (list)) - function_class (..reflection //.$Function) - bytecode ($d.abstract {$.#V1_6} {$.#Public} $.noneC function_class (list) $Object (list) - (|>> ($d.field {$.#Public} $.finalF partials_field type.int) - ($d.method {$.#Public} $.noneM "<init>" (type.method [(list) (list type.int) type.void (list)]) - (|>> (_.ALOAD 0) - (_.INVOKESPECIAL $Object "<init>" nullary_init_methodT) - (_.ALOAD 0) - (_.ILOAD 1) - (_.PUTFIELD //.$Function partials_field type.int) - _.RETURN)) - applyI)) - directive [function_class bytecode]] - (do phase.monad - [_ (generation.execute! directive) - _ (generation.save! ..function_id {.#None} directive)] - (in [..function_id {.#None} bytecode])))) - -(def: .public translate - (Operation [Registry Output]) - (do phase.monad - [runtime_payload ..translate_runtime - ... function_payload ..translate_function - ] - (in [(|> registry.empty - (registry.resource true unit.none) - product.right - ... (registry.resource true unit.none) - ... product.right - ) - (sequence.sequence runtime_payload - ... function_payload - )]))) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/structure.lux b/lux-jvm/source/luxc/lang/translation/jvm/structure.lux deleted file mode 100644 index 878658efe..000000000 --- a/lux-jvm/source/luxc/lang/translation/jvm/structure.lux +++ /dev/null @@ -1,118 +0,0 @@ -(.using - [library - [lux {"-" Type Primitive} - ["[0]" ffi {"+" import:}] - [abstract - ["[0]" monad {"+" do}]] - [control - ["[0]" exception {"+" exception:}]] - [data - [text - ["%" format {"+" format}]] - [collection - ["[0]" list]]] - [math - [number - ["n" nat] - ["i" int]]] - [target - [jvm - ["[0]" type {"+" Type} - ["[0]" category {"+" Void Value Return Primitive Object Class Array Var Parameter Method}] - ["[0]" descriptor {"+" Descriptor}] - ["[0]" signature {"+" Signature}]]]] - [tool - [compiler - ["[0]" phase] - [meta - [archive {"+" Archive}]] - [language - [lux - [synthesis {"+" Synthesis}]]]]]]] - [luxc - [lang - [host - [jvm {"+" Inst Operation Phase Generator} - ["_" inst]]]]] - ["[0]" // - ["[1][0]" runtime]]) - -(exception: .public (not_a_tuple [size Nat]) - (exception.report - "Expected size" ">= 2" - "Actual size" (%.nat size))) - -(def: .public (tuple generate archive members) - (Generator (List Synthesis)) - (do [@ phase.monad] - [.let [size (list.size members)] - _ (phase.assertion ..not_a_tuple size - (n.>= 2 size)) - membersI (|> members - list.enumeration - (monad.each @ (function (_ [idx member]) - (do @ - [memberI (generate archive member)] - (in (|>> _.DUP - (_.int (.int idx)) - memberI - _.AASTORE))))) - (# @ each _.fuse))] - (in (|>> (_.int (.int size)) - (_.array //runtime.$Value) - membersI)))) - -(import: java/lang/Byte - "[1]::[0]" - ("static" MAX_VALUE byte) - ("static" MIN_VALUE byte)) - -(import: java/lang/Short - "[1]::[0]" - ("static" MAX_VALUE short) - ("static" MIN_VALUE short)) - -(def: .public (tagI lefts right?) - (-> Nat Bit Inst) - (case lefts - 0 _.ICONST_0 - 1 _.ICONST_1 - 2 _.ICONST_2 - 3 _.ICONST_3 - 4 _.ICONST_4 - 5 _.ICONST_5 - tag (let [tag (.int tag)] - (cond (and (i.>= (java/lang/Byte::MIN_VALUE) tag) - (i.<= (java/lang/Byte::MAX_VALUE) tag)) - (_.BIPUSH tag) - - (and (i.>= (java/lang/Short::MIN_VALUE) tag) - (i.<= (java/lang/Short::MAX_VALUE) tag)) - (_.SIPUSH tag) - - ... else - (_.int tag))))) - -(def: .public leftI _.NULL) -(def: .public rightI (_.string "")) - -(def: .public (flagI right?) - (-> Bit Inst) - (if right? - ..rightI - ..leftI)) - -(def: .public (variant generate archive [lefts right? member]) - (Generator [Nat Bit Synthesis]) - (do phase.monad - [memberI (generate archive member) - .let [tagI (..tagI lefts right?)]] - (in (|>> tagI - (flagI right?) - memberI - (_.INVOKESTATIC //.$Runtime - "variant_make" - (type.method [(list) - (list //runtime.$Lefts //runtime.$Right? //runtime.$Value) - //.$Variant - (list)])))))) |