diff options
Diffstat (limited to 'new-luxc/source/luxc/lang/host')
| -rw-r--r-- | new-luxc/source/luxc/lang/host/jvm/def.lux | 105 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/host/jvm/inst.lux | 146 |
2 files changed, 109 insertions, 142 deletions
diff --git a/new-luxc/source/luxc/lang/host/jvm/def.lux b/new-luxc/source/luxc/lang/host/jvm/def.lux index 138098929..9abf0db35 100644 --- a/new-luxc/source/luxc/lang/host/jvm/def.lux +++ b/new-luxc/source/luxc/lang/host/jvm/def.lux @@ -14,6 +14,9 @@ ["." list ("#/." functor)]]] [target [jvm + ["." descriptor (#+ Descriptor)] + [encoding + ["." name]] ["$t" type (#+ Method Class Type Parameter) ["." reflection]]]]] ["." //]) @@ -74,38 +77,6 @@ (list.enumerate values)) output))) -(def: (exception-class-name type) - (-> Type Text) - (case type - (#$t.Primitive prim) - (case prim - #$t.Boolean reflection.boolean - #$t.Byte reflection.byte - #$t.Short reflection.short - #$t.Int reflection.int - #$t.Long reflection.long - #$t.Float reflection.float - #$t.Double reflection.double - #$t.Char reflection.char) - - (#$t.Array sub) - (format $t.array-prefix (exception-class-name sub)) - - (#$t.Generic generic) - (case generic - (#$t.Class class params) - ($t.binary-name class) - - (^or (#$t.Var _) (#$t.Wildcard _)) - ($t.binary-name $t.object-class)) - )) - -(def: exceptions-array - (-> Method (Array Text)) - (|>> (get@ #$t.exceptions) - (list/map (|>> #$t.Generic ..exception-class-name)) - string-array)) - (def: (version-flag version) (-> //.Version Int) (case version @@ -186,6 +157,8 @@ ## (ClassWriter::COMPUTE_FRAMES) )) +(def: binary-name (|>> name.internal name.read)) + (template [<name> <flag>] [(def: #export (<name> version visibility config name parameters super interfaces definitions) @@ -198,18 +171,18 @@ <flag> (visibility-flag visibility) (class-flags config)) - ($t.binary-name name) + (..binary-name name) (parameters-signature parameters super interfaces) - (|> super product.left $t.binary-name) + (|> super product.left ..binary-name) (|> interfaces - (list/map (|>> product.left $t.binary-name)) + (list/map (|>> product.left ..binary-name)) string-array))) definitions) _ (ClassWriter::visitEnd writer)] (ClassWriter::toByteArray writer)))] - [class +0] - [abstract (Opcodes::ACC_ABSTRACT)] + [class +0] + [abstract (Opcodes::ACC_ABSTRACT)] ) (def: $Object Class ["java.lang.Object" (list)]) @@ -225,27 +198,27 @@ (Opcodes::ACC_INTERFACE) (visibility-flag visibility) (class-flags config)) - ($t.binary-name name) + (..binary-name name) (parameters-signature parameters $Object interfaces) - (|> $Object product.left $t.binary-name) + (|> $Object product.left ..binary-name) (|> interfaces - (list/map (|>> product.left $t.binary-name)) + (list/map (|>> product.left ..binary-name)) string-array))) definitions) _ (ClassWriter::visitEnd writer)] (ClassWriter::toByteArray writer))) (def: #export (method visibility config name type then) - (-> //.Visibility //.Method-Config Text Method //.Inst + (-> //.Visibility //.Method-Config Text (Descriptor descriptor.Method) //.Inst //.Def) (function (_ writer) (let [=method (ClassWriter::visitMethod ($_ i.+ (visibility-flag visibility) (method-flags config)) - ($t.binary-name name) - ($t.method-descriptor type) - ($t.method-signature type) - (exceptions-array type) + (..binary-name name) + (descriptor.descriptor type) + (host.null) + (string-array (list)) writer) _ (MethodVisitor::visitCode =method) _ (then =method) @@ -254,30 +227,30 @@ writer))) (def: #export (abstract-method visibility config name type) - (-> //.Visibility //.Method-Config Text Method + (-> //.Visibility //.Method-Config Text (Descriptor descriptor.Method) //.Def) (function (_ writer) (let [=method (ClassWriter::visitMethod ($_ i.+ (visibility-flag visibility) (method-flags config) (Opcodes::ACC_ABSTRACT)) - ($t.binary-name name) - ($t.method-descriptor type) - ($t.method-signature type) - (exceptions-array type) + (..binary-name name) + (descriptor.descriptor type) + (host.null) + (string-array (list)) writer) _ (MethodVisitor::visitEnd =method)] writer))) (def: #export (field visibility config name type) - (-> //.Visibility //.Field-Config Text Type //.Def) + (-> //.Visibility //.Field-Config Text (Descriptor descriptor.Field) //.Def) (function (_ writer) (let [=field (do-to (ClassWriter::visitField ($_ i.+ (visibility-flag visibility) (field-flags config)) - ($t.binary-name name) - ($t.descriptor type) - ($t.signature type) + (..binary-name name) + (descriptor.descriptor type) + (host.null) (host.null) writer) (FieldVisitor::visitEnd))] @@ -290,23 +263,23 @@ (let [=field (do-to (ClassWriter::visitField ($_ i.+ (visibility-flag visibility) (field-flags config)) - ($t.binary-name name) - ($t.descriptor <jvm-type>) - ($t.signature <jvm-type>) + (..binary-name name) + (descriptor.descriptor <jvm-type>) + (host.null) (<prepare> value) writer) (FieldVisitor::visitEnd))] writer)))] - [boolean-field Bit $t.boolean function.identity] - [byte-field Int $t.byte host.long-to-byte] - [short-field Int $t.short host.long-to-short] - [int-field Int $t.int host.long-to-int] - [long-field Int $t.long function.identity] - [float-field Frac $t.float host.double-to-float] - [double-field Frac $t.double function.identity] - [char-field Nat $t.char (|>> .int host.long-to-int host.int-to-char)] - [string-field Text ($t.class "java.lang.String" (list)) function.identity] + [boolean-field Bit descriptor.boolean function.identity] + [byte-field Int descriptor.byte host.long-to-byte] + [short-field Int descriptor.short host.long-to-short] + [int-field Int descriptor.int host.long-to-int] + [long-field Int descriptor.long function.identity] + [float-field Frac descriptor.float host.double-to-float] + [double-field Frac descriptor.double function.identity] + [char-field Nat descriptor.char (|>> .int host.long-to-int host.int-to-char)] + [string-field Text (descriptor.class "java.lang.String") function.identity] ) (def: #export (fuse defs) diff --git a/new-luxc/source/luxc/lang/host/jvm/inst.lux b/new-luxc/source/luxc/lang/host/jvm/inst.lux index fcf28d4a7..a54367a72 100644 --- a/new-luxc/source/luxc/lang/host/jvm/inst.lux +++ b/new-luxc/source/luxc/lang/host/jvm/inst.lux @@ -1,16 +1,16 @@ (.module: - [lux (#- Type int char) + [lux (#- int char) ["." host (#+ import: do-to)] [abstract [monad (#+ do)]] [control ["." function] + ["." try] ["p" parser ["s" code]]] [data ["." product] ["." maybe] - ["." error] [number ["n" nat] ["i" int]] @@ -22,7 +22,11 @@ [syntax (#+ syntax:)]] [target [jvm - ["." type (#+ Primitive Method Type)]]] + ["." descriptor (#+ Descriptor Primitive) ("#@." equivalence)] + [encoding + ["." name]] + [type + ["." box]]]] [tool [compiler [phase (#+ Operation)]]]] @@ -131,7 +135,7 @@ (def: #export make-label (All [s] (Operation s org/objectweb/asm/Label)) (function (_ state) - (#error.Success [state (org/objectweb/asm/Label::new)]))) + (#try.Success [state (org/objectweb/asm/Label::new)]))) (def: #export (with-label action) (All [a] (-> (-> org/objectweb/asm/Label a) a)) @@ -235,10 +239,10 @@ (template [<name> <inst>] [(def: #export (<name> class field type) - (-> Text Text Type Inst) + (-> (Descriptor descriptor.Class) Text (Descriptor descriptor.Field) Inst) (function (_ visitor) (do-to visitor - (org/objectweb/asm/MethodVisitor::visitFieldInsn (<inst>) (type.binary-name class) field (type.descriptor type)))))] + (org/objectweb/asm/MethodVisitor::visitFieldInsn (<inst>) (descriptor.class-name class) field (descriptor.descriptor type)))))] [GETSTATIC org/objectweb/asm/Opcodes::GETSTATIC] [PUTSTATIC org/objectweb/asm/Opcodes::PUTSTATIC] @@ -249,10 +253,10 @@ (template [<name> <inst>] [(def: #export (<name> class) - (-> Text Inst) + (-> (Descriptor descriptor.Object) Inst) (function (_ visitor) (do-to visitor - (org/objectweb/asm/MethodVisitor::visitTypeInsn (<inst>) (type.binary-name class)))))] + (org/objectweb/asm/MethodVisitor::visitTypeInsn (<inst>) (descriptor.class-name class)))))] [CHECKCAST org/objectweb/asm/Opcodes::CHECKCAST] [NEW org/objectweb/asm/Opcodes::NEW] @@ -261,26 +265,30 @@ ) (def: #export (NEWARRAY type) - (-> Primitive Inst) + (-> (Descriptor Primitive) Inst) (function (_ visitor) (do-to visitor (org/objectweb/asm/MethodVisitor::visitIntInsn (org/objectweb/asm/Opcodes::NEWARRAY) - (case type - #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)))))) + (`` (cond (~~ (template [<descriptor> <opcode>] + [(descriptor@= <descriptor> type) (<opcode>)] + + [descriptor.boolean org/objectweb/asm/Opcodes::T_BOOLEAN] + [descriptor.byte org/objectweb/asm/Opcodes::T_BYTE] + [descriptor.short org/objectweb/asm/Opcodes::T_SHORT] + [descriptor.int org/objectweb/asm/Opcodes::T_INT] + [descriptor.long org/objectweb/asm/Opcodes::T_LONG] + [descriptor.float org/objectweb/asm/Opcodes::T_FLOAT] + [descriptor.double org/objectweb/asm/Opcodes::T_DOUBLE] + [descriptor.char org/objectweb/asm/Opcodes::T_CHAR])) + ## else + (undefined))))))) (template [<name> <inst>] - [(def: #export (<name> class method-name method-signature interface?) - (-> Text Text Method Bit Inst) + [(def: #export (<name> class method-name type interface?) + (-> (Descriptor descriptor.Class) Text (Descriptor descriptor.Method) Bit Inst) (function (_ visitor) (do-to visitor - (org/objectweb/asm/MethodVisitor::visitMethodInsn (<inst>) (type.binary-name class) method-name (type.method-descriptor method-signature) interface?))))] + (org/objectweb/asm/MethodVisitor::visitMethodInsn (<inst>) (descriptor.class-name class) method-name (descriptor.descriptor type) interface?))))] [INVOKESTATIC org/objectweb/asm/Opcodes::INVOKESTATIC] [INVOKEVIRTUAL org/objectweb/asm/Opcodes::INVOKEVIRTUAL] @@ -338,10 +346,10 @@ (org/objectweb/asm/MethodVisitor::visitTableSwitchInsn min max default labels-array))))) (def: #export (try @from @to @handler exception) - (-> //.Label //.Label //.Label Text Inst) + (-> //.Label //.Label //.Label (Descriptor descriptor.Class) Inst) (function (_ visitor) (do-to visitor - (org/objectweb/asm/MethodVisitor::visitTryCatchBlock @from @to @handler (type.binary-name exception))))) + (org/objectweb/asm/MethodVisitor::visitTryCatchBlock @from @to @handler (descriptor.class-name exception))))) (def: #export (label @label) (-> //.Label Inst) @@ -350,63 +358,49 @@ (org/objectweb/asm/MethodVisitor::visitLabel @label)))) (def: #export (array type) - (-> Type Inst) - (case type - (#type.Primitive prim) - (NEWARRAY prim) - - (#type.Generic generic) - (let [elem-class (case generic - (#type.Class class params) - (type.binary-name class) - - _ - (type.binary-name "java.lang.Object"))] - (ANEWARRAY elem-class)) - - _ - (ANEWARRAY (type.descriptor type)))) - -(def: (primitive-wrapper type) - (-> Primitive Text) - (case type - #type.Boolean "java.lang.Boolean" - #type.Byte "java.lang.Byte" - #type.Short "java.lang.Short" - #type.Int "java.lang.Integer" - #type.Long "java.lang.Long" - #type.Float "java.lang.Float" - #type.Double "java.lang.Double" - #type.Char "java.lang.Character")) - -(def: (primitive-unwrap type) - (-> Primitive Text) - (case type - #type.Boolean "booleanValue" - #type.Byte "byteValue" - #type.Short "shortValue" - #type.Int "intValue" - #type.Long "longValue" - #type.Float "floatValue" - #type.Double "doubleValue" - #type.Char "charValue")) + (-> (Descriptor descriptor.Value) Inst) + (case (descriptor.primitive? type) + (#.Left object) + (ANEWARRAY object) + + (#.Right primitive) + (NEWARRAY primitive))) + +(template [<name> <boolean> <byte> <short> <int> <long> <float> <double> <char>] + [(def: (<name> type) + (-> (Descriptor Primitive) Text) + (`` (cond (~~ (template [<descriptor> <output>] + [(descriptor@= <descriptor> type) <output>] + + [descriptor.boolean <boolean>] + [descriptor.byte <byte>] + [descriptor.short <short>] + [descriptor.int <int>] + [descriptor.long <long>] + [descriptor.float <float>] + [descriptor.double <double>] + [descriptor.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: #export (wrap type) - (-> Primitive Inst) - (let [class (primitive-wrapper type)] - (|>> (INVOKESTATIC class "valueOf" - (type.method (list (#type.Primitive type)) - (#.Some (type.class class (list))) - (list)) - #0)))) + (-> (Descriptor Primitive) Inst) + (let [wrapper (descriptor.class (primitive-wrapper type))] + (INVOKESTATIC wrapper "valueOf" (descriptor.method [(list type) wrapper]) #0))) (def: #export (unwrap type) - (-> Primitive Inst) - (let [class (primitive-wrapper type)] - (|>> (CHECKCAST class) - (INVOKEVIRTUAL class (primitive-unwrap type) - (type.method (list) (#.Some (#type.Primitive type)) (list)) - #0)))) + (-> (Descriptor Primitive) Inst) + (let [wrapper (descriptor.class (primitive-wrapper type))] + (|>> (CHECKCAST wrapper) + (INVOKEVIRTUAL wrapper (primitive-unwrap type) (descriptor.method [(list) type]) #0)))) (def: #export (fuse insts) (-> (List Inst) Inst) |