diff options
author | Eduardo Julian | 2019-09-07 01:50:37 -0400 |
---|---|---|
committer | Eduardo Julian | 2019-09-07 01:50:37 -0400 |
commit | b63ac226cc2ea843f08f7c72b18d22602462c624 (patch) | |
tree | 7fb72562c39549108b7a48c1a6819c9bd3a64dab /new-luxc/source/luxc/lang | |
parent | 181f93f3e963c9738ed60f6f5e2d2a37253a0b1b (diff) |
Modified compiler's machinery to use the new abstractions for descriptors and signatures.
Diffstat (limited to 'new-luxc/source/luxc/lang')
-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 | ||||
-rw-r--r-- | new-luxc/source/luxc/lang/statement/jvm.lux | 52 | ||||
-rw-r--r-- | new-luxc/source/luxc/lang/translation/jvm.lux | 16 | ||||
-rw-r--r-- | new-luxc/source/luxc/lang/translation/jvm/case.lux | 34 | ||||
-rw-r--r-- | new-luxc/source/luxc/lang/translation/jvm/function.lux | 47 | ||||
-rw-r--r-- | new-luxc/source/luxc/lang/translation/jvm/primitive.lux | 9 | ||||
-rw-r--r-- | new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux | 109 | ||||
-rw-r--r-- | new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux | 675 | ||||
-rw-r--r-- | new-luxc/source/luxc/lang/translation/jvm/reference.lux | 7 | ||||
-rw-r--r-- | new-luxc/source/luxc/lang/translation/jvm/runtime.lux | 102 | ||||
-rw-r--r-- | new-luxc/source/luxc/lang/translation/jvm/structure.lux | 13 |
13 files changed, 626 insertions, 669 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) diff --git a/new-luxc/source/luxc/lang/statement/jvm.lux b/new-luxc/source/luxc/lang/statement/jvm.lux index bc0cd375e..20ba938d1 100644 --- a/new-luxc/source/luxc/lang/statement/jvm.lux +++ b/new-luxc/source/luxc/lang/statement/jvm.lux @@ -1,10 +1,11 @@ (.module: - [lux (#- Definition) + [lux (#- Type Definition) [abstract ["." monad (#+ do)]] [control ["<>" parser - ["<c>" code (#+ Parser)]]] + ["<c>" code (#+ Parser)] + ["<t>" text]]] [data ["." product] [text @@ -16,9 +17,12 @@ ["." check (#+ Check)]] [target [jvm - ["." type (#+ Var Parameter Class Argument Typed Return) + ["." type (#+ Type Constraint Argument Typed) + [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)] [".T" lux] - ["." descriptor (#+ Descriptor)]]]] + ["." signature] + ["." descriptor (#+ Descriptor)] + ["." parser]]]] [tool [compiler ["." statement (#+ Handler Bundle)] @@ -38,12 +42,14 @@ ["$" jvm (#+ Anchor Inst Definition Operation Phase) ["_." def]]]]]) +(def: signature (|>> type.signature signature.signature)) + (type: Declaration - [Text (List Text)]) + [Text (List (Type Var))]) (def: declaration (Parser Declaration) - (<c>.form (<>.and <c>.text (<>.some <c>.text)))) + (<c>.form (<>.and <c>.text (<>.some jvm.var)))) (type: Inheritance #FinalI @@ -75,14 +81,12 @@ (Parser Annotation) <c>.any) -(def: field-descriptor - (Parser (Descriptor descriptor.Field)) - (:: <>.monad map - (|>> (:coerce (Descriptor descriptor.Field))) - <c>.text)) +(def: field-type + (Parser (Type Value)) + (<t>.embed parser.value <c>.text)) (type: Constant - [Text (List Annotation) (Descriptor descriptor.Field) Code]) + [Text (List Annotation) (Type Value) Code]) (def: constant (Parser Constant) @@ -91,12 +95,12 @@ ($_ <>.and <c>.text (<c>.tuple (<>.some ..annotation)) - ..field-descriptor + ..field-type <c>.any ))) (type: Variable - [Text jvm.Visibility State (List Annotation) (Descriptor descriptor.Field)]) + [Text jvm.Visibility State (List Annotation) (Type Value)]) (def: variable (Parser Variable) @@ -107,7 +111,7 @@ jvm.visibility ..state (<c>.tuple (<>.some ..annotation)) - ..field-descriptor + ..field-type ))) (type: Field @@ -136,9 +140,11 @@ jvm.overriden-method-definition )) -(def: (parameter name) - (-> Text Parameter) - [name [type.object-class (list)] (list)]) +(def: (constraint name) + (-> Text Constraint) + {#type.name name + #type.super-class (type.class "java.lang.Object" (list)) + #type.super-interfaces (list)}) (def: jvm::class (Handler Anchor Inst Definition) @@ -165,7 +171,7 @@ (typeA.with-env (jvm.parameter-types parameters))) #let [mapping (list@fold (function (_ [parameterJ parameterT] mapping) - (dictionary.put parameterJ parameterT mapping)) + (dictionary.put (parser.name parameterJ) parameterT mapping)) luxT.fresh parameters) field-definitions (|> fields @@ -203,11 +209,11 @@ _def.fuse)] super-classT (statement.lift-analysis (typeA.with-env - (luxT.class mapping super-class))) + (luxT.check (luxT.class mapping) (..signature super-class)))) super-interfaceT+ (statement.lift-analysis (typeA.with-env (monad.map check.monad - (luxT.class mapping) + (|>> ..signature (luxT.check (luxT.class mapping))) super-interfaces))) #let [selfT (jvm.inheritance-relationship-type (#.Primitive name (list@map product.right parameters)) super-classT @@ -243,9 +249,9 @@ ## TODO: Handle abstract classes. #AbstractI (undefined) #DefaultI $.noneC) - name (list@map (|>> product.left ..parameter) parameters) + name (list@map (|>> product.left parser.name ..constraint) parameters) super-class super-interfaces - (|>> field-definitions))])) + field-definitions)])) #let [_ (log! (format "Class " name))]] (wrap statement.no-requirements)))])) diff --git a/new-luxc/source/luxc/lang/translation/jvm.lux b/new-luxc/source/luxc/lang/translation/jvm.lux index 7388e8c30..86d7f9b9a 100644 --- a/new-luxc/source/luxc/lang/translation/jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm.lux @@ -21,7 +21,7 @@ [target [jvm ["." loader (#+ Library)] - [type + ["." type ["." descriptor]]]] [tool [compiler @@ -49,7 +49,7 @@ (type: #export ByteCode Binary) (def: #export value-field Text "_value") -(def: #export $Value (descriptor.class "java.lang.Object")) +(def: #export $Value (type.class "java.lang.Object" (list))) (exception: #export (cannot-load {class Text} {error Text}) (exception.report @@ -93,15 +93,15 @@ bytecode (def.class #jvm.V1_6 #jvm.Public jvm.noneC bytecode-name - (list) ["java.lang.Object" (list)] + (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>" - (descriptor.method [(list) descriptor.void]) + (type.method [(list) type.void (list)]) (|>> valueI - (inst.PUTSTATIC (descriptor.class bytecode-name) ..value-field ..$Value) + (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) @@ -151,6 +151,6 @@ (def: #export runtime-class "LuxRuntime") (def: #export function-class "LuxFunction") -(def: #export $Variant (descriptor.array ..$Value)) -(def: #export $Tuple (descriptor.array ..$Value)) -(def: #export $Function (descriptor.class ..function-class)) +(def: #export $Variant (type.array ..$Value)) +(def: #export $Tuple (type.array ..$Value)) +(def: #export $Function (type.class ..function-class (list))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/case.lux b/new-luxc/source/luxc/lang/translation/jvm/case.lux index f57671f36..d676f2996 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/case.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/case.lux @@ -1,5 +1,5 @@ (.module: - [lux (#- if let case) + [lux (#- Type if let case) [abstract [monad (#+ do)]] [control @@ -10,8 +10,10 @@ ["n" nat]]] [target [jvm - [type - ["." descriptor]]]] + ["." type (#+ Type) + ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)] + ["." descriptor (#+ Descriptor)] + ["." signature (#+ Signature)]]]] [tool [compiler ["." synthesis (#+ Path Synthesis)] @@ -24,7 +26,7 @@ ["." // ["." runtime]]) -(def: $Runtime (descriptor.class //.runtime-class)) +(def: $Runtime (type.class //.runtime-class (list))) (def: (pop-altI stack-depth) (-> Nat Inst) @@ -43,7 +45,7 @@ (def: pushI Inst - (|>> (_.INVOKESTATIC $Runtime "pm_push" (descriptor.method [(list runtime.$Stack //.$Value) runtime.$Stack]) #0))) + (|>> (_.INVOKESTATIC $Runtime "pm_push" (type.method [(list runtime.$Stack //.$Value) runtime.$Stack (list)]) #0))) (def: (path' phase stack-depth @else @end path) (-> Phase Nat Label Label Path (Operation Inst)) @@ -58,19 +60,19 @@ (^ (synthesis.path/bit value)) (operation@wrap (.let [jumpI (.if value _.IFEQ _.IFNE)] (|>> peekI - (_.unwrap descriptor.boolean) + (_.unwrap type.boolean) (jumpI @else)))) (^ (synthesis.path/i64 value)) (operation@wrap (|>> peekI - (_.unwrap descriptor.long) + (_.unwrap type.long) (_.long (.int value)) _.LCMP (_.IFNE @else))) (^ (synthesis.path/f64 value)) (operation@wrap (|>> peekI - (_.unwrap descriptor.double) + (_.unwrap type.double) (_.double value) _.DCMPL (_.IFNE @else))) @@ -78,9 +80,9 @@ (^ (synthesis.path/text value)) (operation@wrap (|>> peekI (_.string value) - (_.INVOKEVIRTUAL (descriptor.class "java.lang.Object") + (_.INVOKEVIRTUAL (type.class "java.lang.Object" (list)) "equals" - (descriptor.method [(list //.$Value) descriptor.boolean]) + (type.method [(list //.$Value) type.boolean (list)]) #0) (_.IFEQ @else))) @@ -99,7 +101,7 @@ (_.CHECKCAST //.$Variant) (_.int (.int (<prepare> idx))) <flag> - (_.INVOKESTATIC $Runtime "pm_variant" (descriptor.method [(list //.$Variant runtime.$Tag runtime.$Flag) runtime.$Value]) #0) + (_.INVOKESTATIC $Runtime "pm_variant" (type.method [(list //.$Variant runtime.$Tag runtime.$Flag) runtime.$Value (list)]) #0) _.DUP (_.IFNULL @fail) (_.GOTO @success) @@ -117,7 +119,7 @@ _.AALOAD lefts - (_.INVOKESTATIC $Runtime "tuple_left" (descriptor.method [(list //.$Tuple runtime.$Index) //.$Value]) #0))] + (_.INVOKESTATIC $Runtime "tuple_left" (type.method [(list //.$Tuple runtime.$Index) //.$Value (list)]) #0))] (|>> peekI (_.CHECKCAST //.$Tuple) (_.int (.int lefts)) @@ -128,7 +130,7 @@ (operation@wrap (|>> peekI (_.CHECKCAST //.$Tuple) (_.int (.int lefts)) - (_.INVOKESTATIC $Runtime "tuple_right" (descriptor.method [(list //.$Tuple runtime.$Index) //.$Value]) #0) + (_.INVOKESTATIC $Runtime "tuple_right" (type.method [(list //.$Tuple runtime.$Index) //.$Value (list)]) #0) pushI)) ## Extra optimization @@ -154,7 +156,7 @@ (wrap (|>> peekI (_.CHECKCAST //.$Tuple) (_.int (.int lefts)) - (_.INVOKESTATIC $Runtime <getter> (descriptor.method [(list //.$Tuple runtime.$Index) //.$Value]) #0) + (_.INVOKESTATIC $Runtime <getter> (type.method [(list //.$Tuple runtime.$Index) //.$Value (list)]) #0) (_.ASTORE register) then!)))) ([synthesis.member/left "tuple_left"] @@ -187,7 +189,7 @@ (wrap (|>> pathI (_.label @else) _.POP - (_.INVOKESTATIC $Runtime "pm_fail" (descriptor.method [(list) descriptor.void]) #0) + (_.INVOKESTATIC $Runtime "pm_fail" (type.method [(list) type.void (list)]) #0) _.NULL (_.GOTO @end))))) @@ -200,7 +202,7 @@ (wrap (<| _.with-label (function (_ @else)) _.with-label (function (_ @end)) (|>> testI - (_.unwrap descriptor.boolean) + (_.unwrap type.boolean) (_.IFEQ @else) thenI (_.GOTO @end) diff --git a/new-luxc/source/luxc/lang/translation/jvm/function.lux b/new-luxc/source/luxc/lang/translation/jvm/function.lux index dca622efa..9592510ab 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/function.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/function.lux @@ -13,8 +13,10 @@ ["." list ("#@." functor monoid)]]] [target [jvm - [type - ["." descriptor (#+ Descriptor Class Method Value)]]]] + ["." type (#+ Type) + ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)] + ["." descriptor (#+ Descriptor)] + ["." signature (#+ Signature)]]]] [tool [compiler [arity (#+ Arity)] @@ -39,33 +41,34 @@ (-> Arity Bit) (n.> 1 arity)) -(def: reset-method - (-> (Descriptor Class) (Descriptor Method)) - (|>> [(list)] descriptor.method)) +(def: (reset-method return) + (-> (Type Class) [(Signature Method) (Descriptor Method)]) + (type.method [(list) return (list)])) (def: (captured-args env) - (-> Environment (List (Descriptor Value))) + (-> Environment (List (Type Value))) (list.repeat (list.size env) //.$Value)) (def: (init-method env arity) - (-> Environment Arity (Descriptor Method)) + (-> Environment Arity [(Signature Method) (Descriptor Method)]) (if (poly-arg? arity) - (descriptor.method [(list.concat (list (captured-args env) - (list descriptor.int) - (list.repeat (dec arity) //.$Value))) - descriptor.void]) - (descriptor.method [(captured-args env) descriptor.void]))) + (type.method [(list.concat (list (captured-args env) + (list type.int) + (list.repeat (dec arity) //.$Value))) + type.void + (list)]) + (type.method [(captured-args env) type.void (list)]))) (def: (implementation-method arity) - (descriptor.method [(list.repeat arity //.$Value) //.$Value])) + (type.method [(list.repeat arity //.$Value) //.$Value (list)])) (def: get-amount-of-partialsI Inst (|>> (_.ALOAD 0) - (_.GETFIELD //.$Function runtime.partials-field descriptor.int))) + (_.GETFIELD //.$Function runtime.partials-field type.int))) (def: (load-fieldI class field) - (-> (Descriptor Class) Text Inst) + (-> (Type Class) Text Inst) (|>> (_.ALOAD 0) (_.GETFIELD class field //.$Value))) @@ -114,7 +117,7 @@ function.identity)) (def: (instance class arity env) - (-> (Descriptor Class) Arity Environment (Operation Inst)) + (-> (Type Class) Arity Environment (Operation Inst)) (do phase.monad [captureI+ (monad.map @ reference.variable env) #let [argsI (if (poly-arg? arity) @@ -129,7 +132,7 @@ (_.INVOKESPECIAL class "<init>" (init-method env arity) #0))))) (def: (with-reset class arity env) - (-> (Descriptor Class) Arity Environment Def) + (-> (Type Class) Arity Environment Def) (def.method #$.Public $.noneM "reset" (reset-method class) (if (poly-arg? arity) (let [env-size (list.size env) @@ -160,7 +163,7 @@ _.ARETURN))) (def: function-init-method - (descriptor.method [(list descriptor.int) descriptor.void])) + (type.method [(list type.int) type.void (list)])) (def: (function-init arity env-size) (-> Arity Nat Inst) @@ -171,7 +174,7 @@ (_.INVOKESPECIAL //.$Function "<init>" function-init-method #0)))) (def: (with-init class env arity) - (-> (Descriptor Class) Environment Arity Def) + (-> (Type Class) Environment Arity Def) (let [env-size (list.size env) offset-partial (: (-> Nat Nat) (|>> inc (n.+ env-size))) @@ -200,7 +203,7 @@ _.RETURN)))) (def: (with-apply class env function-arity @begin bodyI apply-arity) - (-> (Descriptor Class) Environment Arity Label Inst Arity + (-> (Type Class) Environment Arity Label Inst Arity Def) (let [num-partials (dec function-arity) @default ($.new-label []) @@ -261,7 +264,7 @@ (_.TABLESWITCH +0 (|> num-partials dec .int) @default @labels) casesI - (_.INVOKESTATIC runtime.$Runtime "apply_fail" (descriptor.method [(list) descriptor.void]) #0) + (_.INVOKESTATIC runtime.$Runtime "apply_fail" (type.method [(list) type.void (list)]) #0) _.NULL _.ARETURN )))) @@ -269,7 +272,7 @@ (def: #export (with-function @begin class env arity bodyI) (-> Label Text Environment Arity Inst (Operation [Def Inst])) - (let [classD (descriptor.class class) + (let [classD (type.class class (list)) env-size (list.size env) applyD (: Def (if (poly-arg? arity) diff --git a/new-luxc/source/luxc/lang/translation/jvm/primitive.lux b/new-luxc/source/luxc/lang/translation/jvm/primitive.lux index d5f8d56cb..873c363bd 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/primitive.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/primitive.lux @@ -2,8 +2,7 @@ [lux (#- i64) [target [jvm - [type - ["." descriptor]]]] + ["." type]]] [tool [compiler [phase ("operation@." monad)]]]] @@ -15,7 +14,7 @@ (def: #export bit (-> Bit (Operation Inst)) - (let [Boolean (descriptor.class "java.lang.Boolean")] + (let [Boolean (type.class "java.lang.Boolean" (list))] (function (_ value) (operation@wrap (_.GETSTATIC Boolean (if value "TRUE" "FALSE") Boolean))))) @@ -25,7 +24,7 @@ (let [loadI (|> value <load>)] (operation@wrap (|>> loadI <wrap>))))] - [i64 (I64 Any) (<| _.long .int) (_.wrap descriptor.long)] - [f64 Frac _.double (_.wrap descriptor.double)] + [i64 (I64 Any) (<| _.long .int) (_.wrap type.long)] + [f64 Frac _.double (_.wrap type.double)] [text Text _.string (<|)] ) diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux index 6e7891460..06ae2ba26 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux @@ -16,8 +16,7 @@ ["." dictionary]]] [target [jvm - [type - ["." descriptor]]]] + ["." type]]] [tool [compiler ["." synthesis (#+ Synthesis %synthesis)] @@ -53,19 +52,19 @@ (#static MIN_VALUE Double) (#static MAX_VALUE Double)) -(def: $String (descriptor.class "java.lang.String")) -(def: $CharSequence (descriptor.class "java.lang.CharSequence")) -(def: $System (descriptor.class "java.lang.System")) -(def: $Object (descriptor.class "java.lang.Object")) +(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 descriptor.long))) -(def: jvm-intI Inst (|>> (_.unwrap descriptor.long) _.L2I)) +(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 (descriptor.class "java.lang.Boolean")] + (let [$Boolean (type.class "java.lang.Boolean" (list))] (<| _.with-label (function (_ @then)) _.with-label (function (_ @end)) (|>> (tester @then) @@ -111,7 +110,7 @@ conditionalsG (|> conditionalsG+ (list@map product.right) _.fuse)]] - (wrap (|>> inputG (_.unwrap descriptor.long) _.L2I + (wrap (|>> inputG (_.unwrap type.long) _.L2I (_.LOOKUPSWITCH @else table) conditionalsG (_.label @else) @@ -130,15 +129,15 @@ (|>> riskyI (_.CHECKCAST ///.$Function) (_.INVOKESTATIC runtime.$Runtime "try" - (descriptor.method [(list ///.$Function) ///.$Variant]) + (type.method [(list ///.$Function) ///.$Variant (list)]) #0))) (template [<name> <op>] [(def: (<name> [maskI inputI]) (Binary Inst) - (|>> inputI (_.unwrap descriptor.long) - maskI (_.unwrap descriptor.long) - <op> (_.wrap descriptor.long)))] + (|>> inputI (_.unwrap type.long) + maskI (_.unwrap type.long) + <op> (_.wrap type.long)))] [i64::and _.LAND] [i64::or _.LOR] @@ -148,10 +147,10 @@ (template [<name> <op>] [(def: (<name> [shiftI inputI]) (Binary Inst) - (|>> inputI (_.unwrap descriptor.long) + (|>> inputI (_.unwrap type.long) shiftI jvm-intI <op> - (_.wrap descriptor.long)))] + (_.wrap type.long)))] [i64::left-shift _.LSHL] [i64::arithmetic-right-shift _.LSHR] @@ -163,9 +162,9 @@ (Nullary Inst) (|>> <const> (_.wrap <type>)))] - [f64::smallest (_.double (Double::MIN_VALUE)) descriptor.double] - [f64::min (_.double (f.* -1.0 (Double::MAX_VALUE))) descriptor.double] - [f64::max (_.double (Double::MAX_VALUE)) descriptor.double] + [f64::smallest (_.double (Double::MIN_VALUE)) type.double] + [f64::min (_.double (f.* -1.0 (Double::MAX_VALUE))) type.double] + [f64::max (_.double (Double::MAX_VALUE)) type.double] ) (template [<name> <type> <op>] @@ -176,25 +175,25 @@ <op> (_.wrap <type>)))] - [i64::+ descriptor.long _.LADD] - [i64::- descriptor.long _.LSUB] - [i64::* descriptor.long _.LMUL] - [i64::/ descriptor.long _.LDIV] - [i64::% descriptor.long _.LREM] + [i64::+ type.long _.LADD] + [i64::- type.long _.LSUB] + [i64::* type.long _.LMUL] + [i64::/ type.long _.LDIV] + [i64::% type.long _.LREM] - [f64::+ descriptor.double _.DADD] - [f64::- descriptor.double _.DSUB] - [f64::* descriptor.double _.DMUL] - [f64::/ descriptor.double _.DDIV] - [f64::% descriptor.double _.DREM] + [f64::+ type.double _.DADD] + [f64::- type.double _.DSUB] + [f64::* type.double _.DMUL] + [f64::/ type.double _.DDIV] + [f64::% type.double _.DREM] ) -(template [<eq> <lt> <descriptor> <cmp>] +(template [<eq> <lt> <type> <cmp>] [(template [<name> <reference>] [(def: (<name> [paramI subjectI]) (Binary Inst) - (|>> subjectI (_.unwrap <descriptor>) - paramI (_.unwrap <descriptor>) + (|>> subjectI (_.unwrap <type>) + paramI (_.unwrap <type>) <cmp> (_.int <reference>) (predicateI _.IF_ICMPEQ)))] @@ -202,8 +201,8 @@ [<eq> +0] [<lt> -1])] - [i64::= i64::< descriptor.long _.LCMP] - [f64::= f64::< descriptor.double _.DCMPG] + [i64::= i64::< type.long _.LCMP] + [f64::= f64::< type.double _.DCMPG] ) (template [<name> <prepare> <transform>] @@ -211,22 +210,22 @@ (Unary Inst) (|>> inputI <prepare> <transform>))] - [i64::f64 (_.unwrap descriptor.long) (<| (_.wrap descriptor.double) _.L2D)] - [i64::char (_.unwrap descriptor.long) - ((|>> _.L2I _.I2C (_.INVOKESTATIC (descriptor.class "java.lang.Character") "toString" (descriptor.method [(list descriptor.char) $String]) #0)))] + [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 type.char) $String (list)]) #0)))] - [f64::i64 (_.unwrap descriptor.double) (<| (_.wrap descriptor.long) _.D2L)] - [f64::encode (_.unwrap descriptor.double) - (_.INVOKESTATIC (descriptor.class "java.lang.Double") "toString" (descriptor.method [(list descriptor.double) $String]) #0)] + [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 type.double) $String (list)]) #0)] [f64::decode ..check-stringI - (_.INVOKESTATIC runtime.$Runtime "decode_frac" (descriptor.method [(list $String) ///.$Variant]) #0)] + (_.INVOKESTATIC runtime.$Runtime "decode_frac" (type.method [(list $String) ///.$Variant (list)]) #0)] ) (def: (text::size inputI) (Unary Inst) (|>> inputI ..check-stringI - (_.INVOKEVIRTUAL $String "length" (descriptor.method [(list) descriptor.int]) #0) + (_.INVOKEVIRTUAL $String "length" (type.method [(list) type.int (list)]) #0) lux-intI)) (template [<name> <pre-subject> <pre-param> <op> <post>] @@ -237,13 +236,13 @@ <op> <post>))] [text::= (<|) (<|) - (_.INVOKEVIRTUAL $Object "equals" (descriptor.method [(list $Object) descriptor.boolean]) #0) - (_.wrap descriptor.boolean)] + (_.INVOKEVIRTUAL $Object "equals" (type.method [(list $Object) type.boolean (list)]) #0) + (_.wrap type.boolean)] [text::< ..check-stringI ..check-stringI - (_.INVOKEVIRTUAL $String "compareTo" (descriptor.method [(list $String) descriptor.int]) #0) + (_.INVOKEVIRTUAL $String "compareTo" (type.method [(list $String) type.int (list)]) #0) (predicateI _.IFLT)] [text::char ..check-stringI jvm-intI - (_.INVOKEVIRTUAL $String "charAt" (descriptor.method [(list descriptor.int) descriptor.char]) #0) + (_.INVOKEVIRTUAL $String "charAt" (type.method [(list type.int) type.char (list)]) #0) lux-intI] ) @@ -251,16 +250,16 @@ (Binary Inst) (|>> leftI ..check-stringI rightI ..check-stringI - (_.INVOKEVIRTUAL $String "concat" (descriptor.method [(list $String) $String]) #0))) + (_.INVOKEVIRTUAL $String "concat" (type.method [(list $String) $String (list)]) #0))) (def: (text::clip [startI endI subjectI]) (Trinary Inst) (|>> subjectI ..check-stringI startI jvm-intI endI jvm-intI - (_.INVOKEVIRTUAL $String "substring" (descriptor.method [(list descriptor.int descriptor.int) $String]) #0))) + (_.INVOKEVIRTUAL $String "substring" (type.method [(list type.int type.int) $String (list)]) #0))) -(def: index-method (descriptor.method [(list $String descriptor.int) descriptor.int])) +(def: index-method (type.method [(list $String type.int) type.int (list)])) (def: (text::index [startI partI textI]) (Trinary Inst) (<| _.with-label (function (_ @not-found)) @@ -280,10 +279,10 @@ runtime.noneI (_.label @end)))) -(def: string-method (descriptor.method [(list $String) descriptor.void])) +(def: string-method (type.method [(list $String) type.void (list)])) (def: (io::log messageI) (Unary Inst) - (let [$PrintStream (descriptor.class "java.io.PrintStream")] + (let [$PrintStream (type.class "java.io.PrintStream" (list))] (|>> (_.GETSTATIC $System "out" $PrintStream) messageI ..check-stringI @@ -292,7 +291,7 @@ (def: (io::error messageI) (Unary Inst) - (let [$Error (descriptor.class "java.lang.Error")] + (let [$Error (type.class "java.lang.Error" (list))] (|>> (_.NEW $Error) _.DUP messageI @@ -303,13 +302,13 @@ (def: (io::exit codeI) (Unary Inst) (|>> codeI jvm-intI - (_.INVOKESTATIC $System "exit" (descriptor.method [(list descriptor.int) descriptor.void]) #0) + (_.INVOKESTATIC $System "exit" (type.method [(list type.int) type.void (list)]) #0) _.NULL)) (def: (io::current-time _) (Nullary Inst) - (|>> (_.INVOKESTATIC $System "currentTimeMillis" (descriptor.method [(list) descriptor.long]) #0) - (_.wrap descriptor.long))) + (|>> (_.INVOKESTATIC $System "currentTimeMillis" (type.method [(list) type.long (list)]) #0) + (_.wrap type.long))) (def: bundle::lux Bundle diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux index a51d1715b..58643797b 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux @@ -1,5 +1,5 @@ (.module: - [lux (#- primitive int char) + [lux (#- Type primitive int char type) [abstract ["." monad (#+ do)]] [control @@ -13,17 +13,20 @@ ["." maybe] [number ["." nat]] - ["." text] + ["." text ("#@." equivalence)] [collection ["." list ("#@." monad)] ["." dictionary (#+ Dictionary)] ["." set]]] [target - ["." jvm #_ - ["#" type (#+ Bound Generic Class Var Typed Argument Return) + [jvm + ["." type (#+ Type Typed Argument) + ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)] ["." box] ["." reflection] - ["." descriptor (#+ Descriptor Value Primitive Object Method)]]]] + ["." descriptor (#+ Descriptor)] + ["." signature (#+ Signature)] + ["." parser]]]] [tool [compiler [analysis (#+ Environment)] @@ -52,8 +55,6 @@ ["#." reference] ["#." function]]]) -(exception: #export invalid-syntax-for-argument-generation) - (template [<name> <inst>] [(def: <name> Inst @@ -172,7 +173,7 @@ [double::% _.DREM] ) -(def: $Boolean (descriptor.class box.boolean)) +(def: $Boolean (type.class box.boolean (list))) (def: falseI (_.GETSTATIC $Boolean "FALSE" $Boolean)) (def: trueI (_.GETSTATIC $Boolean "TRUE" $Boolean)) @@ -225,7 +226,7 @@ (def: int Bundle - (<| (bundle.prefix reflection.int) + (<| (bundle.prefix (reflection.reflection reflection.int)) (|> (: Bundle bundle.empty) (bundle.install "+" (binary int::+)) (bundle.install "-" (binary int::-)) @@ -244,7 +245,7 @@ (def: long Bundle - (<| (bundle.prefix reflection.long) + (<| (bundle.prefix (reflection.reflection reflection.long)) (|> (: Bundle bundle.empty) (bundle.install "+" (binary long::+)) (bundle.install "-" (binary long::-)) @@ -263,7 +264,7 @@ (def: float Bundle - (<| (bundle.prefix reflection.float) + (<| (bundle.prefix (reflection.reflection reflection.float)) (|> (: Bundle bundle.empty) (bundle.install "+" (binary float::+)) (bundle.install "-" (binary float::-)) @@ -276,7 +277,7 @@ (def: double Bundle - (<| (bundle.prefix reflection.double) + (<| (bundle.prefix (reflection.reflection reflection.double)) (|> (: Bundle bundle.empty) (bundle.install "+" (binary double::+)) (bundle.install "-" (binary double::-)) @@ -289,36 +290,42 @@ (def: char Bundle - (<| (bundle.prefix reflection.char) + (<| (bundle.prefix (reflection.reflection reflection.char)) (|> (: Bundle bundle.empty) (bundle.install "=" (binary char::=)) (bundle.install "<" (binary char::<)) ))) (def: (array-java-type nesting elem-class) - (-> Nat Text (Descriptor Object)) - (descriptor.array (case nesting - 1 (case elem-class - (^ (static reflection.boolean)) descriptor.boolean - (^ (static reflection.byte)) descriptor.byte - (^ (static reflection.short)) descriptor.short - (^ (static reflection.int)) descriptor.int - (^ (static reflection.long)) descriptor.long - (^ (static reflection.float)) descriptor.float - (^ (static reflection.double)) descriptor.double - (^ (static reflection.char)) descriptor.char - _ (descriptor.class elem-class)) - _ (array-java-type (dec nesting) elem-class)))) + (-> Nat Text (Type Object)) + (type.array (case nesting + 0 (undefined) + 1 (`` (cond (~~ (template [<type>] + [(text@= (reflection.reflection (type.reflection <type>)) + elem-class) + <type>] + + [type.boolean] + [type.byte] + [type.short] + [type.int] + [type.long] + [type.float] + [type.double] + [type.char])) + ## else + (type.class elem-class (list)))) + _ (array-java-type (dec nesting) elem-class)))) (def: (primitive-array-length-handler jvm-primitive) - (-> (Descriptor Primitive) Handler) + (-> (Type Primitive) Handler) (..custom [<s>.any (function (_ extension-name generate arrayS) (do phase.monad [arrayI (generate arrayS)] (wrap (|>> arrayI - (_.CHECKCAST (descriptor.array jvm-primitive)) + (_.CHECKCAST (type.array jvm-primitive)) _.ARRAYLENGTH))))])) (def: (array::length::object extension-name generate inputs) @@ -337,7 +344,7 @@ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) (def: (new-primitive-array-handler jvm-primitive) - (-> (Descriptor Primitive) Handler) + (-> (Type Primitive) Handler) (function (_ extension-name generate inputs) (case inputs (^ (list lengthS)) @@ -364,7 +371,7 @@ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) (def: (read-primitive-array-handler jvm-primitive loadI) - (-> (Descriptor Primitive) Inst Handler) + (-> (Type Primitive) Inst Handler) (function (_ extension-name generate inputs) (case inputs (^ (list idxS arrayS)) @@ -372,7 +379,7 @@ [arrayI (generate arrayS) idxI (generate idxS)] (wrap (|>> arrayI - (_.CHECKCAST (descriptor.array jvm-primitive)) + (_.CHECKCAST (type.array jvm-primitive)) idxI loadI))) @@ -398,7 +405,7 @@ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) (def: (write-primitive-array-handler jvm-primitive storeI) - (-> (Descriptor Primitive) Inst Handler) + (-> (Type Primitive) Inst Handler) (function (_ extension-name generate inputs) (case inputs (^ (list idxS valueS arrayS)) @@ -407,7 +414,7 @@ idxI (generate idxS) valueI (generate valueS)] (wrap (|>> arrayI - (_.CHECKCAST (descriptor.array jvm-primitive)) + (_.CHECKCAST (type.array jvm-primitive)) _.DUP idxI valueI @@ -444,47 +451,47 @@ (|> bundle.empty (dictionary.merge (<| (bundle.prefix "length") (|> bundle.empty - (bundle.install reflection.boolean (primitive-array-length-handler descriptor.boolean)) - (bundle.install reflection.byte (primitive-array-length-handler descriptor.byte)) - (bundle.install reflection.short (primitive-array-length-handler descriptor.short)) - (bundle.install reflection.int (primitive-array-length-handler descriptor.int)) - (bundle.install reflection.long (primitive-array-length-handler descriptor.long)) - (bundle.install reflection.float (primitive-array-length-handler descriptor.float)) - (bundle.install reflection.double (primitive-array-length-handler descriptor.double)) - (bundle.install reflection.char (primitive-array-length-handler descriptor.char)) + (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.merge (<| (bundle.prefix "new") (|> bundle.empty - (bundle.install reflection.boolean (new-primitive-array-handler descriptor.boolean)) - (bundle.install reflection.byte (new-primitive-array-handler descriptor.byte)) - (bundle.install reflection.short (new-primitive-array-handler descriptor.short)) - (bundle.install reflection.int (new-primitive-array-handler descriptor.int)) - (bundle.install reflection.long (new-primitive-array-handler descriptor.long)) - (bundle.install reflection.float (new-primitive-array-handler descriptor.float)) - (bundle.install reflection.double (new-primitive-array-handler descriptor.double)) - (bundle.install reflection.char (new-primitive-array-handler descriptor.char)) + (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.merge (<| (bundle.prefix "read") (|> bundle.empty - (bundle.install reflection.boolean (read-primitive-array-handler descriptor.boolean _.BALOAD)) - (bundle.install reflection.byte (read-primitive-array-handler descriptor.byte _.BALOAD)) - (bundle.install reflection.short (read-primitive-array-handler descriptor.short _.SALOAD)) - (bundle.install reflection.int (read-primitive-array-handler descriptor.int _.IALOAD)) - (bundle.install reflection.long (read-primitive-array-handler descriptor.long _.LALOAD)) - (bundle.install reflection.float (read-primitive-array-handler descriptor.float _.FALOAD)) - (bundle.install reflection.double (read-primitive-array-handler descriptor.double _.DALOAD)) - (bundle.install reflection.char (read-primitive-array-handler descriptor.char _.CALOAD)) + (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.merge (<| (bundle.prefix "write") (|> bundle.empty - (bundle.install reflection.boolean (write-primitive-array-handler descriptor.boolean _.BASTORE)) - (bundle.install reflection.byte (write-primitive-array-handler descriptor.byte _.BASTORE)) - (bundle.install reflection.short (write-primitive-array-handler descriptor.short _.SASTORE)) - (bundle.install reflection.int (write-primitive-array-handler descriptor.int _.IASTORE)) - (bundle.install reflection.long (write-primitive-array-handler descriptor.long _.LASTORE)) - (bundle.install reflection.float (write-primitive-array-handler descriptor.float _.FASTORE)) - (bundle.install reflection.double (write-primitive-array-handler descriptor.double _.DASTORE)) - (bundle.install reflection.char (write-primitive-array-handler descriptor.char _.CASTORE)) + (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)))) ))) @@ -518,7 +525,7 @@ (|>> exceptionI _.ATHROW)) -(def: $Class (descriptor.class "java.lang.Class")) +(def: $Class (type.class "java.lang.Class" (list))) (def: (object::class extension-name generate inputs) Handler @@ -528,8 +535,9 @@ [] (wrap (|>> (_.string class) (_.INVOKESTATIC $Class "forName" - (descriptor.method [(list (descriptor.class "java.lang.String")) - $Class]) + (type.method [(list (type.class "java.lang.String" (list))) + $Class + (list)]) false)))) _ @@ -543,8 +551,8 @@ (do phase.monad [objectI (generate objectS)] (wrap (|>> objectI - (_.INSTANCEOF (descriptor.class class)) - (_.wrap descriptor.boolean)))))])) + (_.INSTANCEOF (type.class class (list))) + (_.wrap type.boolean)))))])) (def: (object::cast extension-name generate inputs) Handler @@ -552,25 +560,29 @@ (^ (list (synthesis.text from) (synthesis.text to) valueS)) (do phase.monad [valueI (generate valueS)] - (case [from to] - ## Wrap - (^template [<primitive> <object> <type>] - (^ [(static <primitive>) (static <object>)]) - (wrap (|>> valueI (_.wrap <type>))) - - (^ [(static <object>) (static <primitive>)]) - (wrap (|>> valueI (_.unwrap <type>)))) - ([reflection.boolean box.boolean descriptor.boolean] - [reflection.byte box.byte descriptor.byte] - [reflection.short box.short descriptor.short] - [reflection.int box.int descriptor.int] - [reflection.long box.long descriptor.long] - [reflection.float box.float descriptor.float] - [reflection.double box.double descriptor.double] - [reflection.char box.char descriptor.char]) - - _ - (wrap valueI))) + (`` (cond (~~ (template [<object> <type>] + [(and (text@= (reflection.reflection (type.reflection <type>)) + from) + (text@= <object> + to)) + (wrap (|>> valueI (_.wrap <type>))) + + (and (text@= <object> + from) + (text@= (reflection.reflection (type.reflection <type>)) + to)) + (wrap (|>> valueI (_.unwrap <type>)))] + + [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 + (wrap valueI)))) _ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) @@ -589,211 +601,187 @@ ))) (def: primitives - (Dictionary Text (Descriptor Primitive)) - (|> (list [reflection.boolean descriptor.boolean] - [reflection.byte descriptor.byte] - [reflection.short descriptor.short] - [reflection.int descriptor.int] - [reflection.long descriptor.long] - [reflection.float descriptor.float] - [reflection.double descriptor.double] - [reflection.char descriptor.char]) + (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.from-list text.hash))) -(def: (static::get extension-name generate inputs) +(def: static::get Handler - (case inputs - (^ (list (synthesis.text class) - (synthesis.text field) - (synthesis.text unboxed))) - (do phase.monad - [] - (case (dictionary.get unboxed ..primitives) - (#.Some primitive) - (wrap (_.GETSTATIC (descriptor.class class) field primitive)) - - #.None - (wrap (_.GETSTATIC (descriptor.class class) field (descriptor.class unboxed))))) - - _ - (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) - -(def: (static::put extension-name generate inputs) + (..custom + [($_ <>.and <s>.text <s>.text <s>.text) + (function (_ extension-name generate [class field unboxed]) + (do phase.monad + [] + (case (dictionary.get unboxed ..primitives) + (#.Some primitive) + (wrap (_.GETSTATIC (type.class class (list)) field primitive)) + + #.None + (wrap (_.GETSTATIC (type.class class (list)) field (type.class unboxed (list)))))))])) + +(def: static::put Handler - (case inputs - (^ (list (synthesis.text class) - (synthesis.text field) - (synthesis.text unboxed) - valueS)) - (do phase.monad - [valueI (generate valueS) - #let [$class (descriptor.class class)]] - (case (dictionary.get unboxed ..primitives) - (#.Some primitive) - (wrap (|>> valueI - (_.PUTSTATIC $class field primitive) - (_.string synthesis.unit))) - - #.None - (wrap (|>> valueI - (_.CHECKCAST $class) - (_.PUTSTATIC $class field $class) - (_.string synthesis.unit))))) - - _ - (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) - -(def: (virtual::get extension-name generate inputs) + (..custom + [($_ <>.and <s>.text <s>.text <s>.text <s>.any) + (function (_ extension-name generate [class field unboxed valueS]) + (do phase.monad + [valueI (generate valueS) + #let [$class (type.class class (list))]] + (case (dictionary.get unboxed ..primitives) + (#.Some primitive) + (wrap (|>> valueI + (_.PUTSTATIC $class field primitive) + (_.string synthesis.unit))) + + #.None + (wrap (|>> valueI + (_.CHECKCAST $class) + (_.PUTSTATIC $class field $class) + (_.string synthesis.unit))))))])) + +(def: virtual::get Handler - (case inputs - (^ (list (synthesis.text class) - (synthesis.text field) - (synthesis.text unboxed) - objectS)) - (do phase.monad - [objectI (generate objectS) - #let [$class (descriptor.class class) - getI (case (dictionary.get unboxed ..primitives) - (#.Some primitive) - (_.GETFIELD $class field primitive) - - #.None - (_.GETFIELD $class field (descriptor.class unboxed)))]] - (wrap (|>> objectI - (_.CHECKCAST $class) - getI))) - - _ - (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) + (..custom + [($_ <>.and <s>.text <s>.text <s>.text <s>.any) + (function (_ extension-name generate [class field unboxed objectS]) + (do phase.monad + [objectI (generate objectS) + #let [$class (type.class class (list)) + getI (case (dictionary.get unboxed ..primitives) + (#.Some primitive) + (_.GETFIELD $class field primitive) + + #.None + (_.GETFIELD $class field (type.class unboxed (list))))]] + (wrap (|>> objectI + (_.CHECKCAST $class) + getI))))])) -(def: (virtual::put extension-name generate inputs) +(def: virtual::put Handler - (case inputs - (^ (list (synthesis.text class) - (synthesis.text field) - (synthesis.text unboxed) - valueS - objectS)) - (do phase.monad - [valueI (generate valueS) - objectI (generate objectS) - #let [$class (descriptor.class class) - putI (case (dictionary.get unboxed ..primitives) - (#.Some primitive) - (_.PUTFIELD $class field primitive) - - #.None - (let [$unboxed (descriptor.class unboxed)] - (|>> (_.CHECKCAST $unboxed) - (_.PUTFIELD $class field $unboxed))))]] - (wrap (|>> objectI - (_.CHECKCAST $class) - _.DUP - valueI - putI))) + (..custom + [($_ <>.and <s>.text <s>.text <s>.text <s>.any <s>.any) + (function (_ extension-name generate [class field unboxed valueS objectS]) + (do phase.monad + [valueI (generate valueS) + objectI (generate objectS) + #let [$class (type.class class (list)) + putI (case (dictionary.get unboxed ..primitives) + (#.Some primitive) + (_.PUTFIELD $class field primitive) + + #.None + (let [$unboxed (type.class unboxed (list))] + (|>> (_.CHECKCAST $unboxed) + (_.PUTFIELD $class field $unboxed))))]] + (wrap (|>> objectI + (_.CHECKCAST $class) + _.DUP + valueI + putI))))])) - _ - (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) +(template [<name> <category> <parser>] + [(def: #export <name> + (Parser (Type <category>)) + (<t>.embed <parser> <s>.text))] -(def: (generate-arg generate argS) - (-> (-> Synthesis (Operation Inst)) Synthesis - (Operation [Type Inst])) - (case argS - (^ (synthesis.tuple (list (synthesis.text argD) argS))) - (do phase.monad - [argT (phase.lift (<t>.run jvm.parse-signature argD)) - argI (generate argS)] - (wrap [argT argI])) + [var Var parser.var] + [class Class parser.class] + [value Value parser.value] + [return Return parser.return] + ) - _ - (phase.throw invalid-syntax-for-argument-generation []))) +(type: Input (Typed Synthesis)) -(def: (method-return-type description) - (-> Text (Operation Return)) - (case description - (^ (static descriptor.void)) - (phase@wrap #.None) +(def: input + (Parser Input) + (<s>.tuple (<>.and ..value <s>.any))) - _ - (|> description - (<t>.run jvm.parse-signature) - phase.lift - (phase@map (|>> #.Some))))) - -(def: (prepare-argI [type argI]) - (-> [Type Inst] Inst) - (case (jvm.class-name type) - (#.Some class-name) - (|>> argI - (_.CHECKCAST class-name)) - - #.None - argI)) - -(def: (prepare-returnI return) - (-> Return Inst) - (case return - (#.Some _) - function.identity - - #.None - (_.string synthesis.unit))) +(def: (generate-input generate [valueT valueS]) + (-> (-> Synthesis (Operation Inst)) Input + (Operation (Typed Inst))) + (do phase.monad + [valueI (generate valueS)] + (case (type.primitive? valueT) + (#.Right valueT) + (wrap [valueT valueI]) + + (#.Left valueT) + (wrap [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 <s>.text <s>.text <s>.text (<>.some <s>.any)) - (function (_ extension-name generate [class method unboxed argsS]) + [($_ <>.and ..class <s>.text ..return (<>.some ..input)) + (function (_ extension-name generate [class method outputT inputsTS]) (do phase.monad - [argsTI (monad.map @ (generate-arg generate) argsS) - returnT (method-return-type unboxed)] - (wrap (|>> (_.fuse (list@map ..prepare-argI argsTI)) + [inputsTI (monad.map @ (generate-input generate) inputsTS)] + (wrap (|>> (_.fuse (list@map product.right inputsTI)) (_.INVOKESTATIC class method - (descriptor.method [(list@map product.left argsTI) - returnT]) + (type.method [(list@map product.left inputsTI) + outputT + (list)]) false) - (prepare-returnI returnT)))))])) + (prepare-output outputT)))))])) (template [<name> <invoke> <interface?>] [(def: <name> Handler (..custom - [($_ <>.and <s>.text <s>.text <s>.text <s>.any (<>.some <s>.any)) - (function (_ extension-name generate [class method unboxed objectS argsS]) + [($_ <>.and ..class <s>.text ..return <s>.any (<>.some ..input)) + (function (_ extension-name generate [class method outputT objectS inputsTS]) (do phase.monad [objectI (generate objectS) - argsTI (monad.map @ (generate-arg generate) argsS) - returnT (method-return-type unboxed)] + inputsTI (monad.map @ (generate-input generate) inputsTS)] (wrap (|>> objectI (_.CHECKCAST class) - (_.fuse (list@map ..prepare-argI argsTI)) + (_.fuse (list@map product.right inputsTI)) (<invoke> class method - (descriptor.method [(list@map product.left argsTI) - returnT]) + (type.method [(list@map product.left inputsTI) + outputT + (list)]) <interface?>) - (prepare-returnI returnT)))))]))] + (prepare-output outputT)))))]))] [invoke::virtual _.INVOKEVIRTUAL false] [invoke::special _.INVOKESPECIAL false] [invoke::interface _.INVOKEINTERFACE true] ) -(def: (invoke::constructor extension-name generate inputs) +(def: invoke::constructor Handler - (case inputs - (^ (list& (synthesis.text class) argsS)) - (do phase.monad - [argsTI (monad.map @ (generate-arg generate) argsS)] - (wrap (|>> (_.NEW class) - _.DUP - (_.fuse (list@map ..prepare-argI argsTI)) - (_.INVOKESPECIAL class "<init>" - (descriptor.method [(list@map product.left argsTI) - descriptor.void]) - false)))) - - _ - (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) + (..custom + [($_ <>.and ..class (<>.some ..input)) + (function (_ extension-name generate [class inputsTS]) + (do phase.monad + [inputsTI (monad.map @ (generate-input generate) inputsTS)] + (wrap (|>> (_.NEW class) + _.DUP + (_.fuse (list@map product.right inputsTI)) + (_.INVOKESPECIAL class "<init>" + (type.method [(list@map product.left inputsTI) + type.void + (list)]) + false)))))])) (def: member Bundle @@ -816,68 +804,6 @@ (bundle.install "constructor" invoke::constructor)))) ))) -(def: var - (Parser Var) - <s>.text) - -(def: bound - (Parser Bound) - (<>.or (<s>.constant! ["" ">"]) - (<s>.constant! ["" "<"]))) - -(def: (class' generic) - (-> (Parser Generic) (Parser Class)) - (<s>.tuple (<>.and <s>.text (<>.some generic)))) - -(def: generic - (Parser Generic) - (<>.rec - (function (_ generic) - (let [wildcard (<>.or (<s>.constant! ["" "?"]) - (<s>.tuple (<>.and ..bound generic)))] - ($_ <>.or - ..var - wildcard - (class' generic)))))) - -(def: class - (Parser Class) - (class' ..generic)) - -(def: primitive - (Parser (Descriptor Primitive)) - ($_ <>.or - (<>.after (<s>.constant! ["" reflection.boolean]) - (<>@wrap descriptor.boolean)) - (<>.after (<s>.constant! ["" reflection.byte]) - (<>@wrap descriptor.byte)) - (<>.after (<s>.constant! ["" reflection.short]) - (<>@wrap descriptor.short)) - (<>.after (<s>.constant! ["" reflection.int]) - (<>@wrap descriptor.int)) - (<>.after (<s>.constant! ["" reflection.long]) - (<>@wrap descriptor.long)) - (<>.after (<s>.constant! ["" reflection.float]) - (<>@wrap descriptor.float)) - (<>.after (<s>.constant! ["" reflection.double]) - (<>@wrap descriptor.double)) - (<>.after (<s>.constant! ["" reflection.char]) - (<>@wrap descriptor.char)) - )) - -(def: jvm-type - (Parser Type) - (<>.rec - (function (_ jvm-type) - ($_ <>.or - ..primitive - ..generic - (<s>.tuple jvm-type))))) - -(def: constructor-arg - (Parser (Typed Synthesis)) - (<s>.tuple (<>.and ..jvm-type <s>.any))) - (def: annotation-parameter (Parser (/.Annotation-Parameter Synthesis)) (<s>.tuple (<>.and <s>.text <s>.any))) @@ -888,12 +814,7 @@ (def: argument (Parser Argument) - (<s>.tuple (<>.and <s>.text ..jvm-type))) - -(def: return - (Parser Return) - (<>.or (<s>.constant! ["" (descriptor.descriptor descriptor.void)]) - ..jvm-type)) + (<s>.tuple (<>.and <s>.text ..value))) (def: overriden-method-definition (Parser [Environment (/.Overriden-Method Synthesis)]) @@ -989,15 +910,16 @@ (#synthesis.Extension [name inputsS+]) (#synthesis.Extension [name (list@map recur inputsS+)])))) -(def: $Object (descriptor.class "java.lang.Object")) +(def: $Object (type.class "java.lang.Object" (list))) (def: (anonymous-init-method env) - (-> Environment (Descriptor Method)) - (descriptor.method [(list.repeat (list.size env) $Object) - descriptor.void])) + (-> Environment [(Signature Method) (Descriptor Method)]) + (type.method [(list.repeat (list.size env) $Object) + type.void + (list)])) -(def: (with-anonymous-init class env super-class constructor-argsI) - (-> Text Environment Class (List (Typed Inst)) Def) +(def: (with-anonymous-init class env super-class inputsTI) + (-> (Type Class) Environment (Type Class) (List (Typed Inst)) Def) (let [store-capturedI (|> env list.size list.indices @@ -1008,17 +930,18 @@ _.fuse)] (_def.method #$.Public $.noneM "<init>" (anonymous-init-method env) (|>> (_.ALOAD 0) - ((_.fuse (list@map product.right constructor-argsI))) - (_.INVOKESPECIAL (product.left super-class) + ((_.fuse (list@map product.right inputsTI))) + (_.INVOKESPECIAL super-class "<init>" - (descriptor.method [(list@map product.left constructor-argsI) - descriptor.void]) + (type.method [(list@map product.left inputsTI) + type.void + (list)]) #0) store-capturedI _.RETURN)))) (def: (anonymous-instance class env) - (-> Text Environment (Operation Inst)) + (-> (Type Class) Environment (Operation Inst)) (do phase.monad [captureI+ (monad.map @ ///reference.variable env)] (wrap (|>> (_.NEW class) @@ -1026,6 +949,34 @@ (_.fuse captureI+) (_.INVOKESPECIAL class "<init>" (anonymous-init-method env) #0))))) +(def: (returnI returnT) + (-> (Type Return) Inst) + (case (type.void? returnT) + (#.Right returnT) + _.RETURN + + (#.Left returnT) + (case (type.primitive? returnT) + (#.Left returnT) + _.ARETURN + + (#.Right returnT) + (cond (or (:: type.equivalence = type.boolean returnT) + (:: type.equivalence = type.byte returnT) + (:: type.equivalence = type.short returnT) + (:: type.equivalence = type.int returnT) + (:: type.equivalence = type.char returnT)) + _.IRETURN + + (:: type.equivalence = type.long returnT) + _.LRETURN + + (:: type.equivalence = type.float returnT) + _.FRETURN + + ## (:: type.equivalence = type.double returnT) + _.DRETURN)))) + (def: class::anonymous Handler (..custom @@ -1033,14 +984,15 @@ <s>.text ..class (<s>.tuple (<>.some ..class)) - (<s>.tuple (<>.some ..constructor-arg)) + (<s>.tuple (<>.some ..input)) (<s>.tuple (<>.some ..overriden-method-definition))) (function (_ extension-name generate [class-name super-class super-interfaces - constructor-args + inputsTS overriden-methods]) (do phase.monad - [#let [total-environment (|> overriden-methods + [#let [class (type.class class-name (list)) + total-environment (|> overriden-methods ## Get all the environments. (list@map product.left) ## Combine them. @@ -1072,12 +1024,7 @@ self-name arguments returnT exceptionsT (normalize-method-body local-mapping body)])) overriden-methods)] - constructor-argsI (monad.map @ - (function (_ [argJT argS]) - (do @ - [argG (generate argS)] - (wrap [argJT argG]))) - constructor-args) + inputsTI (monad.map @ (generate-input generate) inputsTS) method-definitions (|> normalized-methods (monad.map @ (function (_ [ownerT name strict-fp? annotations vars @@ -1090,36 +1037,10 @@ ($_ $.++M $.finalM $.strictM) $.finalM) name - (descriptor.method [(list@map product.right arguments) - returnT] - ## (list@map (|>> #jvm.Class) - ## exceptionsT) - ) - (let [returnI (case returnT - (#.Some returnT) - (case returnT - (#jvm.Primitive returnT) - (case returnT - (^or #jvm.Boolean - #jvm.Byte #jvm.Short #jvm.Int - #jvm.Char) - _.IRETURN - - #jvm.Long - _.LRETURN - - #jvm.Float - _.FRETURN - - #jvm.Double - _.DRETURN) - - _ - _.ARETURN) - - #.None - _.RETURN)] - (|>> bodyG returnI))))))) + (type.method [(list@map product.right arguments) + returnT + exceptionsT]) + (|>> bodyG (returnI returnT))))))) (:: @ map _def.fuse)) _ (generation.save! true ["" class-name] [class-name @@ -1127,9 +1048,9 @@ class-name (list) super-class super-interfaces (|>> (///function.with-environment total-environment) - (..with-anonymous-init class-name total-environment super-class constructor-argsI) + (..with-anonymous-init class total-environment super-class inputsTI) method-definitions))])] - (anonymous-instance class-name total-environment)))])) + (anonymous-instance class total-environment)))])) (def: bundle::class Bundle diff --git a/new-luxc/source/luxc/lang/translation/jvm/reference.lux b/new-luxc/source/luxc/lang/translation/jvm/reference.lux index 1995fcd74..77e98b73b 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/reference.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/reference.lux @@ -7,8 +7,7 @@ ["%" format (#+ format)]]] [target [jvm - [type - ["." descriptor]]]] + ["." type]]] [tool [compiler ["." name] @@ -36,7 +35,7 @@ (do phase.monad [function-class generation.context] (wrap (|>> (_.ALOAD 0) - (_.GETFIELD (descriptor.class function-class) + (_.GETFIELD (type.class function-class (list)) (|> variable .nat foreign-name) //.$Value))))) @@ -57,4 +56,4 @@ (-> Name (Operation Inst)) (do phase.monad [bytecode-name (generation.remember name)] - (wrap (_.GETSTATIC (descriptor.class bytecode-name) //.value-field //.$Value)))) + (wrap (_.GETSTATIC (type.class bytecode-name (list)) //.value-field //.$Value)))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/runtime.lux b/new-luxc/source/luxc/lang/translation/jvm/runtime.lux index 0f3a89faf..594964be0 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/runtime.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/runtime.lux @@ -1,5 +1,5 @@ (.module: - [lux #* + [lux (#- Type) [abstract [monad (#+ do)]] [data @@ -8,8 +8,10 @@ ["." math] [target [jvm - [type - ["." descriptor (#+ Descriptor)]]]] + ["." type (#+ Type) + ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)] + ["." descriptor (#+ Descriptor)] + ["." signature (#+ Signature)]]]] [tool [compiler [arity (#+ Arity)] @@ -24,36 +26,36 @@ ["_" inst]]]]] ["." // (#+ ByteCode)]) -(def: $Text (descriptor.class "java.lang.String")) -(def: #export $Tag descriptor.int) -(def: #export $Flag (descriptor.class "java.lang.Object")) -(def: #export $Value (descriptor.class "java.lang.Object")) -(def: #export $Index descriptor.int) -(def: #export $Stack (descriptor.array $Value)) -(def: $Throwable (descriptor.class "java.lang.Throwable")) -(def: #export $Runtime (descriptor.class "java.lang.Runtime")) +(def: $Text (type.class "java.lang.String" (list))) +(def: #export $Tag type.int) +(def: #export $Flag (type.class "java.lang.Object" (list))) +(def: #export $Value (type.class "java.lang.Object" (list))) +(def: #export $Index type.int) +(def: #export $Stack (type.array $Value)) +(def: $Throwable (type.class "java.lang.Throwable" (list))) +(def: #export $Runtime (type.class "java.lang.Runtime" (list))) (def: nullary-init-methodT - (descriptor.method [(list) descriptor.void])) + (type.method [(list) type.void (list)])) (def: throw-methodT - (descriptor.method [(list) descriptor.void])) + (type.method [(list) type.void (list)])) (def: #export logI Inst - (let [PrintStream (descriptor.class "java.io.PrintStream") - outI (_.GETSTATIC (descriptor.class "java.lang.System") "out" PrintStream) + (let [PrintStream (type.class "java.io.PrintStream" (list)) + outI (_.GETSTATIC (type.class "java.lang.System" (list)) "out" PrintStream) printI (function (_ method) - (_.INVOKEVIRTUAL PrintStream method (descriptor.method [(list $Value) descriptor.void]) #0))] + (_.INVOKEVIRTUAL PrintStream method (type.method [(list $Value) type.void (list)]) #0))] (|>> outI (_.string "LOG: ") (printI "print") outI _.SWAP (printI "println")))) (def: variant-method - (descriptor.method [(list $Tag $Flag $Value) //.$Variant])) + (type.method [(list $Tag $Flag $Value) //.$Variant (list)])) (def: #export variantI Inst - (_.INVOKESTATIC (descriptor.class //.runtime-class) "variant_make" variant-method #0)) + (_.INVOKESTATIC (type.class //.runtime-class (list)) "variant_make" variant-method #0)) (def: #export leftI Inst @@ -85,7 +87,7 @@ (<| _.with-label (function (_ @from)) _.with-label (function (_ @to)) _.with-label (function (_ @handler)) - (|>> (_.try @from @to @handler (descriptor.class "java.lang.Exception")) + (|>> (_.try @from @to @handler (type.class "java.lang.Exception" (list))) (_.label @from) unsafeI someI @@ -97,23 +99,23 @@ (def: #export string-concatI Inst - (_.INVOKEVIRTUAL $Text "concat" (descriptor.method [(list $Text) $Text]) #0)) + (_.INVOKEVIRTUAL $Text "concat" (type.method [(list $Text) $Text (list)]) #0)) (def: #export partials-field Text "partials") (def: #export apply-method Text "apply") (def: #export num-apply-variants Nat 8) (def: #export (apply-signature arity) - (-> Arity (Descriptor descriptor.Method)) - (descriptor.method [(list.repeat arity $Value) $Value])) + (-> Arity [(Signature Method) (Descriptor Method)]) + (type.method [(list.repeat arity $Value) $Value (list)])) (def: adt-methods Def - (let [store-tagI (|>> _.DUP (_.int +0) (_.ILOAD 0) (_.wrap descriptor.int) _.AASTORE) + (let [store-tagI (|>> _.DUP (_.int +0) (_.ILOAD 0) (_.wrap type.int) _.AASTORE) store-flagI (|>> _.DUP (_.int +1) (_.ALOAD 1) _.AASTORE) store-valueI (|>> _.DUP (_.int +2) (_.ALOAD 2) _.AASTORE)] (|>> ($d.method #$.Public $.staticM "variant_make" - (descriptor.method [(list $Tag $Flag $Value) //.$Variant]) + (type.method [(list $Tag $Flag $Value) //.$Variant (list)]) (|>> (_.int +3) (_.array //.$Variant) store-tagI @@ -125,11 +127,11 @@ (def: frac-methods Def - (|>> ($d.method #$.Public $.staticM "decode_frac" (descriptor.method [(list $Text) //.$Variant]) + (|>> ($d.method #$.Public $.staticM "decode_frac" (type.method [(list $Text) //.$Variant (list)]) (try-methodI (|>> (_.ALOAD 0) - (_.INVOKESTATIC (descriptor.class "java.lang.Double") "parseDouble" (descriptor.method [(list $Text) descriptor.double]) #0) - (_.wrap descriptor.double)))) + (_.INVOKESTATIC (type.class "java.lang.Double" (list)) "parseDouble" (type.method [(list $Text) type.double (list)]) #0) + (_.wrap type.double)))) )) (def: #export popI @@ -143,11 +145,11 @@ (def: (illegal-state-exception message) (-> Text Inst) - (let [IllegalStateException (descriptor.class "java.lang.IllegalStateException")] + (let [IllegalStateException (type.class "java.lang.IllegalStateException" (list))] (|>> (_.NEW IllegalStateException) _.DUP (_.string message) - (_.INVOKESPECIAL IllegalStateException "<init>" (descriptor.method [(list $Text) descriptor.void]) #0)))) + (_.INVOKESPECIAL IllegalStateException "<init>" (type.method [(list $Text) type.void (list)]) #0)))) (def: pm-methods Def @@ -170,7 +172,7 @@ ($d.method #$.Public $.staticM "apply_fail" throw-methodT (|>> (illegal-state-exception "Error while applying function.") _.ATHROW)) - ($d.method #$.Public $.staticM "pm_push" (descriptor.method [(list $Stack $Value) $Stack]) + ($d.method #$.Public $.staticM "pm_push" (type.method [(list $Stack $Value) $Stack (list)]) (|>> (_.int +2) (_.ANEWARRAY $Stack) _.DUP @@ -182,7 +184,7 @@ (_.ALOAD 1) _.AASTORE _.ARETURN)) - ($d.method #$.Public $.staticM "pm_variant" (descriptor.method [(list //.$Variant $Tag $Flag) $Value]) + ($d.method #$.Public $.staticM "pm_variant" (type.method [(list //.$Variant $Tag $Flag) $Value (list)]) (<| _.with-label (function (_ @loop)) _.with-label (function (_ @just-return)) _.with-label (function (_ @then)) @@ -193,7 +195,7 @@ (function (_ idx) (|>> (_.int (.int idx)) _.AALOAD))) tagI (: Inst - (|>> (variant-partI 0) (_.unwrap descriptor.int))) + (|>> (variant-partI 0) (_.unwrap type.int))) flagI (variant-partI 1) datumI (variant-partI 2) shortenI (|>> (_.ALOAD 0) tagI ## Get tag @@ -234,7 +236,7 @@ (_.label @wrong) ## tag, sumT ## _.POP2 failureI))) - ($d.method #$.Public $.staticM "tuple_left" (descriptor.method [(list //.$Tuple $Index) $Value]) + ($d.method #$.Public $.staticM "tuple_left" (type.method [(list //.$Tuple $Index) $Value (list)]) (<| _.with-label (function (_ @loop)) _.with-label (function (_ @recursive)) (let [left-accessI (|>> (_.ALOAD 0) left-indexI _.AALOAD)]) @@ -245,7 +247,7 @@ (_.label @recursive) ## Recursive (recurI @loop)))) - ($d.method #$.Public $.staticM "tuple_right" (descriptor.method [(list //.$Tuple $Index) $Value]) + ($d.method #$.Public $.staticM "tuple_right" (type.method [(list //.$Tuple $Index) $Value (list)]) (<| _.with-label (function (_ @loop)) _.with-label (function (_ @not-tail)) _.with-label (function (_ @slice)) @@ -258,9 +260,10 @@ sub-rightI (|>> (_.ALOAD 0) right-indexI tuple-sizeI - (_.INVOKESTATIC (descriptor.class "java.util.Arrays") "copyOfRange" - (descriptor.method [(list //.$Tuple $Index $Index) - //.$Tuple]) + (_.INVOKESTATIC (type.class "java.util.Arrays" (list)) "copyOfRange" + (type.method [(list //.$Tuple $Index $Index) + //.$Tuple + (list)]) #0))]) (|>> (_.label @loop) last-rightI right-indexI @@ -280,8 +283,8 @@ (def: io-methods Def - (let [StringWriter (descriptor.class "java.io.StringWriter") - PrintWriter (descriptor.class "java.io.PrintWriter") + (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 #0)) @@ -291,9 +294,9 @@ _.POP _.SWAP (_.boolean true) - (_.INVOKESPECIAL PrintWriter "<init>" (descriptor.method [(list (descriptor.class "java.io.Writer") descriptor.boolean) descriptor.void]) #0) + (_.INVOKESPECIAL PrintWriter "<init>" (type.method [(list (type.class "java.io.Writer" (list)) type.boolean) type.void (list)]) #0) )] - (|>> ($d.method #$.Public $.staticM "try" (descriptor.method [(list //.$Function) //.$Variant]) + (|>> ($d.method #$.Public $.staticM "try" (type.method [(list //.$Function) //.$Variant (list)]) (<| _.with-label (function (_ @from)) _.with-label (function (_ @to)) _.with-label (function (_ @handler)) @@ -309,15 +312,15 @@ string-writerI ## TW _.DUP2 ## TWTW print-writerI ## TWTP - (_.INVOKEVIRTUAL $Throwable "printStackTrace" (descriptor.method [(list (descriptor.class "java.io.PrintWriter")) descriptor.void]) #0) ## TW - (_.INVOKEVIRTUAL StringWriter "toString" (descriptor.method [(list) $Text]) #0) ## TS + (_.INVOKEVIRTUAL $Throwable "printStackTrace" (type.method [(list (type.class "java.io.PrintWriter" (list))) type.void (list)]) #0) ## TW + (_.INVOKEVIRTUAL StringWriter "toString" (type.method [(list) $Text (list)]) #0) ## TS _.SWAP _.POP leftI _.ARETURN))) ))) (def: translate-runtime (Operation ByteCode) - (let [bytecode ($d.class #$.V1_6 #$.Public $.finalC //.runtime-class (list) ["java.lang.Object" (list)] (list) + (let [bytecode ($d.class #$.V1_6 #$.Public $.finalC //.runtime-class (list) (type.class "java.lang.Object" (list)) (list) (|>> adt-methods frac-methods pm-methods @@ -342,14 +345,15 @@ _.ARETURN))))) (list& ($d.abstract-method #$.Public $.noneM apply-method (apply-signature 1))) $d.fuse) - bytecode ($d.abstract #$.V1_6 #$.Public $.noneC //.function-class (list) ["java.lang.Object" (list)] (list) - (|>> ($d.field #$.Public $.finalF partials-field descriptor.int) - ($d.method #$.Public $.noneM "<init>" (descriptor.method [(list descriptor.int) descriptor.void]) + $Object (type.class "java.lang.Object" (list)) + 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 type.int) type.void (list)]) (|>> (_.ALOAD 0) - (_.INVOKESPECIAL (descriptor.class "java.lang.Object") "<init>" nullary-init-methodT #0) + (_.INVOKESPECIAL $Object "<init>" nullary-init-methodT #0) (_.ALOAD 0) (_.ILOAD 1) - (_.PUTFIELD //.$Function partials-field descriptor.int) + (_.PUTFIELD //.$Function partials-field type.int) _.RETURN)) applyI))] (do phase.monad diff --git a/new-luxc/source/luxc/lang/translation/jvm/structure.lux b/new-luxc/source/luxc/lang/translation/jvm/structure.lux index e224f1f2f..81730e6bf 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/structure.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/structure.lux @@ -13,8 +13,10 @@ ["." list]]] [target [jvm - [type - ["." descriptor]]]] + ["." type (#+ Type) + ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)] + ["." descriptor (#+ Descriptor)] + ["." signature (#+ Signature)]]]] [tool [compiler [synthesis (#+ Synthesis)] @@ -66,8 +68,9 @@ lefts))) (flagI right?) memberI - (_.INVOKESTATIC (descriptor.class //.runtime-class) + (_.INVOKESTATIC (type.class //.runtime-class (list)) "variant_make" - (descriptor.method [(list //runtime.$Tag //runtime.$Flag //runtime.$Value) - //.$Variant]) + (type.method [(list //runtime.$Tag //runtime.$Flag //runtime.$Value) + //.$Variant + (list)]) #0))))) |