aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/lang/host
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/lang/host')
-rw-r--r--new-luxc/source/luxc/lang/host/jvm/def.lux105
-rw-r--r--new-luxc/source/luxc/lang/host/jvm/inst.lux146
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)