diff options
Diffstat (limited to 'new-luxc/source/luxc/lang/host')
| -rw-r--r-- | new-luxc/source/luxc/lang/host/jvm.lux | 9 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/host/jvm/def.lux | 107 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/host/jvm/inst.lux | 115 |
3 files changed, 126 insertions, 105 deletions
diff --git a/new-luxc/source/luxc/lang/host/jvm.lux b/new-luxc/source/luxc/lang/host/jvm.lux index 7216a1708..d3ead1095 100644 --- a/new-luxc/source/luxc/lang/host/jvm.lux +++ b/new-luxc/source/luxc/lang/host/jvm.lux @@ -1,5 +1,5 @@ (.module: - [lux (#- Definition) + [lux (#- Definition Type) [host (#+ import:)] [abstract monad] @@ -15,7 +15,8 @@ [syntax (#+ syntax:)]] [target [jvm - [type (#+ Class)]]] + ["." type (#+ Type) + [category (#+ Class)]]]] [tool [compiler [reference (#+ Register)] @@ -119,5 +120,5 @@ (org/objectweb/asm/Label::new))) (def: #export (simple-class name) - (-> Text Class) - [name (list)]) + (-> Text (Type Class)) + (type.class name (list))) diff --git a/new-luxc/source/luxc/lang/host/jvm/def.lux b/new-luxc/source/luxc/lang/host/jvm/def.lux index b663b9b31..08fccc640 100644 --- a/new-luxc/source/luxc/lang/host/jvm/def.lux +++ b/new-luxc/source/luxc/lang/host/jvm/def.lux @@ -11,16 +11,21 @@ ["%" format (#+ format)]] [collection ["." array (#+ Array)] - ["." list ("#/." functor)]]] + ["." list ("#@." functor)]]] [target [jvm [encoding ["." name]] - ["$t" type (#+ Method Class Type Parameter) - ["." reflection] + ["." type (#+ Type Constraint) + [category (#+ Class Value Method)] + ["." signature (#+ Signature)] ["." descriptor (#+ Descriptor)]]]]] ["." //]) +(def: signature (|>> type.signature signature.signature)) +(def: descriptor (|>> type.descriptor descriptor.descriptor)) +(def: class-name (|>> type.descriptor descriptor.class-name name.read)) + (import: #long java/lang/Object) (import: #long java/lang/String) @@ -72,7 +77,7 @@ (def: (string-array values) (-> (List Text) (Array Text)) (let [output (host.array String (list.size values))] - (exec (list/map (function (_ [idx value]) + (exec (list@map (function (_ [idx value]) (host.array-write idx value output)) (list.enumerate values)) output))) @@ -118,36 +123,32 @@ (if (get@ #//.transientF config) (Opcodes::ACC_TRANSIENT) +0) (if (get@ #//.volatileF config) (Opcodes::ACC_VOLATILE) +0))) -(def: class-to-type - (-> Class Type) - (|>> #$t.Class #$t.Generic)) - (def: param-signature - (-> Class Text) - (|>> class-to-type $t.signature (format ":"))) + (-> (Type Class) Text) + (|>> ..signature (format ":"))) (def: (formal-param [name super interfaces]) - (-> Parameter Text) + (-> Constraint Text) (format name (param-signature super) (|> interfaces - (list/map param-signature) + (list@map param-signature) (text.join-with "")))) -(def: (parameters-signature parameters super interfaces) - (-> (List Parameter) Class (List Class) +(def: (constraints-signature constraints super interfaces) + (-> (List Constraint) (Type Class) (List (Type Class)) Text) - (let [formal-params (if (list.empty? parameters) + (let [formal-params (if (list.empty? constraints) "" (format "<" - (|> parameters - (list/map formal-param) + (|> constraints + (list@map formal-param) (text.join-with "")) ">"))] (format formal-params - (|> super class-to-type $t.signature) + (..signature super) (|> interfaces - (list/map (|>> class-to-type $t.signature)) + (list@map ..signature) (text.join-with ""))))) (def: class-computes @@ -160,9 +161,9 @@ (def: binary-name (|>> name.internal name.read)) (template [<name> <flag>] - [(def: #export (<name> version visibility config name parameters super interfaces + [(def: #export (<name> version visibility config name constraints super interfaces definitions) - (-> //.Version //.Visibility //.Class-Config Text (List Parameter) Class (List Class) //.Def + (-> //.Version //.Visibility //.Class-Config Text (List Constraint) (Type Class) (List (Type Class)) //.Def (host.type [byte])) (let [writer (|> (do-to (ClassWriter::new class-computes) (ClassWriter::visit (version-flag version) @@ -172,10 +173,10 @@ (visibility-flag visibility) (class-flags config)) (..binary-name name) - (parameters-signature parameters super interfaces) - (|> super product.left ..binary-name) + (constraints-signature constraints super interfaces) + (..class-name super) (|> interfaces - (list/map (|>> product.left ..binary-name)) + (list@map ..class-name) string-array))) definitions) _ (ClassWriter::visitEnd writer)] @@ -185,11 +186,13 @@ [abstract (Opcodes::ACC_ABSTRACT)] ) -(def: $Object Class ["java.lang.Object" (list)]) +(def: $Object + (Type Class) + (type.class "java.lang.Object" (list))) -(def: #export (interface version visibility config name parameters interfaces +(def: #export (interface version visibility config name constraints interfaces definitions) - (-> //.Version //.Visibility //.Class-Config Text (List Parameter) (List Class) //.Def + (-> //.Version //.Visibility //.Class-Config Text (List Constraint) (List (Type Class)) //.Def (host.type [byte])) (let [writer (|> (do-to (ClassWriter::new class-computes) (ClassWriter::visit (version-flag version) @@ -199,25 +202,25 @@ (visibility-flag visibility) (class-flags config)) (..binary-name name) - (parameters-signature parameters $Object interfaces) - (|> $Object product.left ..binary-name) + (constraints-signature constraints $Object interfaces) + (..class-name $Object) (|> interfaces - (list/map (|>> product.left ..binary-name)) + (list@map ..class-name) string-array))) definitions) _ (ClassWriter::visitEnd writer)] (ClassWriter::toByteArray writer))) -(def: #export (method visibility config name type then) - (-> //.Visibility //.Method-Config Text (Descriptor descriptor.Method) //.Inst +(def: #export (method visibility config name [signature descriptor] then) + (-> //.Visibility //.Method-Config Text [(Signature Method) (Descriptor Method)] //.Inst //.Def) (function (_ writer) (let [=method (ClassWriter::visitMethod ($_ i.+ (visibility-flag visibility) (method-flags config)) (..binary-name name) - (descriptor.descriptor type) - (host.null) + (descriptor.descriptor descriptor) + (signature.signature signature) (string-array (list)) writer) _ (MethodVisitor::visitCode =method) @@ -226,8 +229,8 @@ _ (MethodVisitor::visitEnd =method)] writer))) -(def: #export (abstract-method visibility config name type) - (-> //.Visibility //.Method-Config Text (Descriptor descriptor.Method) +(def: #export (abstract-method visibility config name [signature descriptor]) + (-> //.Visibility //.Method-Config Text [(Signature Method) (Descriptor Method)] //.Def) (function (_ writer) (let [=method (ClassWriter::visitMethod ($_ i.+ @@ -235,22 +238,22 @@ (method-flags config) (Opcodes::ACC_ABSTRACT)) (..binary-name name) - (descriptor.descriptor type) - (host.null) + (descriptor.descriptor descriptor) + (signature.signature signature) (string-array (list)) writer) _ (MethodVisitor::visitEnd =method)] writer))) (def: #export (field visibility config name type) - (-> //.Visibility //.Field-Config Text (Descriptor descriptor.Field) //.Def) + (-> //.Visibility //.Field-Config Text (Type Value) //.Def) (function (_ writer) (let [=field (do-to (ClassWriter::visitField ($_ i.+ (visibility-flag visibility) (field-flags config)) (..binary-name name) - (descriptor.descriptor type) - (host.null) + (..descriptor type) + (..signature type) (host.null) writer) (FieldVisitor::visitEnd))] @@ -264,22 +267,22 @@ (visibility-flag visibility) (field-flags config)) (..binary-name name) - (descriptor.descriptor <jvm-type>) - (host.null) + (..descriptor <jvm-type>) + (..signature <jvm-type>) (<prepare> value) writer) (FieldVisitor::visitEnd))] writer)))] - [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] + [boolean-field Bit type.boolean function.identity] + [byte-field Int type.byte host.long-to-byte] + [short-field Int type.short host.long-to-short] + [int-field Int type.int host.long-to-int] + [long-field Int type.long function.identity] + [float-field Frac type.float host.double-to-float] + [double-field Frac type.double function.identity] + [char-field Nat type.char (|>> .int host.long-to-int host.int-to-char)] + [string-field Text (type.class "java.lang.String" (list)) 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 8d5bd3b6e..72d7e58ca 100644 --- a/new-luxc/source/luxc/lang/host/jvm/inst.lux +++ b/new-luxc/source/luxc/lang/host/jvm/inst.lux @@ -1,5 +1,5 @@ (.module: - [lux (#- int char) + [lux (#- Type int char) ["." host (#+ import: do-to)] [abstract [monad (#+ do)]] @@ -23,15 +23,22 @@ [target [jvm [encoding - ["." name]] - [type + ["." name (#+ External)]] + ["." type (#+ Type) ("#@." equivalence) + [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)] ["." box] - ["." descriptor (#+ Descriptor Primitive) ("#@." equivalence)]]]] + ["." signature (#+ Signature)] + ["." descriptor (#+ Descriptor)] + ["." reflection]]]] [tool [compiler [phase (#+ Operation)]]]] ["." // (#+ 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: #long java/lang/Object) (import: #long java/lang/String) @@ -239,10 +246,10 @@ (template [<name> <inst>] [(def: #export (<name> class field type) - (-> (Descriptor descriptor.Class) Text (Descriptor descriptor.Field) Inst) + (-> (Type Class) Text (Type Value) Inst) (function (_ visitor) (do-to visitor - (org/objectweb/asm/MethodVisitor::visitFieldInsn (<inst>) (descriptor.class-name class) field (descriptor.descriptor type)))))] + (org/objectweb/asm/MethodVisitor::visitFieldInsn (<inst>) (..class-name class) field (..descriptor type)))))] [GETSTATIC org/objectweb/asm/Opcodes::GETSTATIC] [PUTSTATIC org/objectweb/asm/Opcodes::PUTSTATIC] @@ -251,44 +258,54 @@ [GETFIELD org/objectweb/asm/Opcodes::GETFIELD] ) -(template [<name> <inst>] - [(def: #export (<name> class) - (-> (Descriptor descriptor.Object) Inst) - (function (_ visitor) - (do-to visitor - (org/objectweb/asm/MethodVisitor::visitTypeInsn (<inst>) (descriptor.class-name class)))))] +(template [<category> <instructions>+] + [(`` (template [<name> <inst>] + [(def: #export (<name> class) + (-> (Type <category>) Inst) + (function (_ visitor) + (do-to visitor + (org/objectweb/asm/MethodVisitor::visitTypeInsn (<inst>) (..class-name class)))))] + + (~~ (template.splice <instructions>+))))] + + [Object + [[CHECKCAST org/objectweb/asm/Opcodes::CHECKCAST] + [ANEWARRAY org/objectweb/asm/Opcodes::ANEWARRAY]]] - [CHECKCAST org/objectweb/asm/Opcodes::CHECKCAST] - [NEW org/objectweb/asm/Opcodes::NEW] - [INSTANCEOF org/objectweb/asm/Opcodes::INSTANCEOF] - [ANEWARRAY org/objectweb/asm/Opcodes::ANEWARRAY] + [Class + [[NEW org/objectweb/asm/Opcodes::NEW] + [INSTANCEOF org/objectweb/asm/Opcodes::INSTANCEOF]]] ) (def: #export (NEWARRAY type) - (-> (Descriptor Primitive) Inst) + (-> (Type Primitive) Inst) (function (_ visitor) (do-to visitor (org/objectweb/asm/MethodVisitor::visitIntInsn (org/objectweb/asm/Opcodes::NEWARRAY) (`` (cond (~~ (template [<descriptor> <opcode>] - [(descriptor@= <descriptor> type) (<opcode>)] + [(type@= <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])) + [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>] - [(def: #export (<name> class method-name type interface?) - (-> (Descriptor descriptor.Class) Text (Descriptor descriptor.Method) Bit Inst) + [(def: #export (<name> class method-name [method-signature method-descriptor] interface?) + (-> (Type Class) Text [(Signature Method) (Descriptor Method)] Bit Inst) (function (_ visitor) (do-to visitor - (org/objectweb/asm/MethodVisitor::visitMethodInsn (<inst>) (descriptor.class-name class) method-name (descriptor.descriptor type) interface?))))] + (org/objectweb/asm/MethodVisitor::visitMethodInsn (<inst>) + (..class-name class) + method-name + (descriptor.descriptor method-descriptor) + interface?))))] [INVOKESTATIC org/objectweb/asm/Opcodes::INVOKESTATIC] [INVOKEVIRTUAL org/objectweb/asm/Opcodes::INVOKEVIRTUAL] @@ -346,10 +363,10 @@ (org/objectweb/asm/MethodVisitor::visitTableSwitchInsn min max default labels-array))))) (def: #export (try @from @to @handler exception) - (-> //.Label //.Label //.Label (Descriptor descriptor.Class) Inst) + (-> //.Label //.Label //.Label (Type Class) Inst) (function (_ visitor) (do-to visitor - (org/objectweb/asm/MethodVisitor::visitTryCatchBlock @from @to @handler (descriptor.class-name exception))))) + (org/objectweb/asm/MethodVisitor::visitTryCatchBlock @from @to @handler (..class-name exception))))) (def: #export (label @label) (-> //.Label Inst) @@ -358,8 +375,8 @@ (org/objectweb/asm/MethodVisitor::visitLabel @label)))) (def: #export (array type) - (-> (Descriptor descriptor.Value) Inst) - (case (descriptor.primitive? type) + (-> (Type Value) Inst) + (case (type.primitive? type) (#.Left object) (ANEWARRAY object) @@ -368,18 +385,18 @@ (template [<name> <boolean> <byte> <short> <int> <long> <float> <double> <char>] [(def: (<name> type) - (-> (Descriptor Primitive) Text) + (-> (Type Primitive) Text) (`` (cond (~~ (template [<descriptor> <output>] - [(descriptor@= <descriptor> type) <output>] + [(type@= <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>])) + [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))))] @@ -392,15 +409,15 @@ ) (def: #export (wrap type) - (-> (Descriptor Primitive) Inst) - (let [wrapper (descriptor.class (primitive-wrapper type))] - (INVOKESTATIC wrapper "valueOf" (descriptor.method [(list type) wrapper]) #0))) + (-> (Type Primitive) Inst) + (let [wrapper (type.class (primitive-wrapper type) (list))] + (INVOKESTATIC wrapper "valueOf" (type.method [(list type) wrapper (list)]) #0))) (def: #export (unwrap type) - (-> (Descriptor Primitive) Inst) - (let [wrapper (descriptor.class (primitive-wrapper type))] + (-> (Type Primitive) Inst) + (let [wrapper (type.class (primitive-wrapper type) (list))] (|>> (CHECKCAST wrapper) - (INVOKEVIRTUAL wrapper (primitive-unwrap type) (descriptor.method [(list) type]) #0)))) + (INVOKEVIRTUAL wrapper (primitive-unwrap type) (type.method [(list) type (list)]) #0)))) (def: #export (fuse insts) (-> (List Inst) Inst) |