aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/host
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/host')
-rw-r--r--new-luxc/source/luxc/host/jvm.lux130
-rw-r--r--new-luxc/source/luxc/host/jvm/def.lux287
-rw-r--r--new-luxc/source/luxc/host/jvm/inst.lux383
-rw-r--r--new-luxc/source/luxc/host/jvm/type.lux138
4 files changed, 938 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/host/jvm.lux b/new-luxc/source/luxc/host/jvm.lux
new file mode 100644
index 000000000..24d4a9ea9
--- /dev/null
+++ b/new-luxc/source/luxc/host/jvm.lux
@@ -0,0 +1,130 @@
+(;module:
+ [lux #- Type Def]
+ (lux (control monad
+ ["p" parser])
+ (data (coll [list "list/" Functor<List>]))
+ [meta]
+ (meta [code]
+ ["s" syntax #+ syntax:])
+ [host]))
+
+## [Host]
+(host;import org.objectweb.asm.MethodVisitor)
+
+(host;import org.objectweb.asm.ClassWriter)
+
+(host;import #long org.objectweb.asm.Label
+ (new []))
+
+## [Type]
+(type: #export Bound
+ #Upper
+ #Lower)
+
+(type: #export Primitive
+ #Boolean
+ #Byte
+ #Short
+ #Int
+ #Long
+ #Float
+ #Double
+ #Char)
+
+(type: #export #rec Generic
+ (#Var Text)
+ (#Wildcard (Maybe [Bound Generic]))
+ (#Class Text (List Generic)))
+
+(type: #export Class
+ [Text (List Generic)])
+
+(type: #export Parameter
+ [Text Class (List Class)])
+
+(type: #export #rec Type
+ (#Primitive Primitive)
+ (#Generic Generic)
+ (#Array Type))
+
+(type: #export Method
+ {#args (List Type)
+ #return (Maybe Type)
+ #exceptions (List Generic)})
+
+(type: #export Def
+ (-> ClassWriter ClassWriter))
+
+(type: #export Inst
+ (-> MethodVisitor MethodVisitor))
+
+(type: #export Label
+ org.objectweb.asm.Label)
+
+(type: #export Register Nat)
+
+(type: #export Visibility
+ #Public
+ #Protected
+ #Private
+ #Default)
+
+(type: #export Version
+ #V1.1
+ #V1.2
+ #V1.3
+ #V1.4
+ #V1.5
+ #V1.6
+ #V1.7
+ #V1.8)
+
+## [Values]
+(syntax: (config: [type s;local-symbol]
+ [none s;local-symbol]
+ [++ s;local-symbol]
+ [options (s;tuple (p;many s;local-symbol))])
+ (let [g!type (code;local-symbol type)
+ g!none (code;local-symbol none)
+ g!tags+ (list/map code;local-tag options)
+ g!_left (code;local-symbol "_left")
+ g!_right (code;local-symbol "_right")
+ g!options+ (list/map (function [option]
+ (` (def: (~' #export) (~ (code;local-symbol option))
+ (~ g!type)
+ (|> (~ g!none)
+ (set@ (~ (code;local-tag option)) true)))))
+ options)]
+ (wrap (list& (` (type: (~' #export) (~ g!type)
+ (~ (code;record (list/map (function [tag]
+ [tag (` ;Bool)])
+ g!tags+)))))
+
+ (` (def: (~' #export) (~ g!none)
+ (~ g!type)
+ (~ (code;record (list/map (function [tag]
+ [tag (` false)])
+ g!tags+)))))
+
+ (` (def: (~' #export) ((~ (code;local-symbol ++)) (~ g!_left) (~ g!_right))
+ (-> (~ g!type) (~ g!type) (~ g!type))
+ (~ (code;record (list/map (function [tag]
+ [tag (` (or (get@ (~ tag) (~ g!_left))
+ (get@ (~ tag) (~ g!_right))))])
+ g!tags+)))))
+
+ g!options+))))
+
+## Configs
+(config: Class-Config noneC ++C [finalC])
+(config: Method-Config noneM ++M [finalM staticM synchronizedM strictM])
+(config: Field-Config noneF ++F [finalF staticF transientF volatileF])
+
+## Labels
+(def: #export new-label
+ (-> Unit Label)
+ org.objectweb.asm.Label.new)
+
+(def: #export (simple-class name)
+ (-> Text Class)
+ [name (list)])
diff --git a/new-luxc/source/luxc/host/jvm/def.lux b/new-luxc/source/luxc/host/jvm/def.lux
new file mode 100644
index 000000000..1d50ba9f6
--- /dev/null
+++ b/new-luxc/source/luxc/host/jvm/def.lux
@@ -0,0 +1,287 @@
+(;module:
+ lux
+ (lux (data [text]
+ text/format
+ [product]
+ (coll ["a" array]
+ [list "list/" Functor<List>]))
+ [host #+ do-to])
+ ["$" ..]
+ (.. ["$t" type]))
+
+## [Host]
+(host;import #long java.lang.Object)
+(host;import #long java.lang.String)
+
+(host;import org.objectweb.asm.Opcodes
+ (#static ACC_PUBLIC int)
+ (#static ACC_PROTECTED int)
+ (#static ACC_PRIVATE int)
+
+ (#static ACC_TRANSIENT int)
+ (#static ACC_VOLATILE int)
+
+ (#static ACC_ABSTRACT int)
+ (#static ACC_FINAL int)
+ (#static ACC_STATIC int)
+ (#static ACC_SYNCHRONIZED int)
+ (#static ACC_STRICT int)
+
+ (#static ACC_SUPER int)
+ (#static ACC_INTERFACE int)
+
+ (#static V1_1 int)
+ (#static V1_2 int)
+ (#static V1_3 int)
+ (#static V1_4 int)
+ (#static V1_5 int)
+ (#static V1_6 int)
+ (#static V1_7 int)
+ (#static V1_8 int)
+ )
+
+(host;import org.objectweb.asm.FieldVisitor
+ (visitEnd [] void))
+
+(host;import org.objectweb.asm.MethodVisitor
+ (visitCode [] void)
+ (visitMaxs [int int] void)
+ (visitEnd [] void))
+
+(host;import org.objectweb.asm.ClassWriter
+ (#static COMPUTE_MAXS int)
+ (#static COMPUTE_FRAMES int)
+ (new [int])
+ (visit [int int String String String (Array String)] void)
+ (visitEnd [] void)
+ (visitField [int String String String Object] FieldVisitor)
+ (visitMethod [int String String String (Array String)] MethodVisitor)
+ (toByteArray [] (Array byte)))
+
+## [Defs]
+(def: (string-array values)
+ (-> (List Text) (Array Text))
+ (let [output (host;array String (list;size values))]
+ (exec (list/map (function [[idx value]]
+ (host;array-write idx value output))
+ (list;enumerate values))
+ output)))
+
+(def: exceptions-array
+ (-> $;Method (Array Text))
+ (|>. (get@ #$;exceptions)
+ (list/map (|>. #$;Generic $t;descriptor))
+ string-array))
+
+(def: (version-flag version)
+ (-> $;Version Int)
+ (case version
+ #$;V1.1 Opcodes.V1_1
+ #$;V1.2 Opcodes.V1_2
+ #$;V1.3 Opcodes.V1_3
+ #$;V1.4 Opcodes.V1_4
+ #$;V1.5 Opcodes.V1_5
+ #$;V1.6 Opcodes.V1_6
+ #$;V1.7 Opcodes.V1_7
+ #$;V1.8 Opcodes.V1_8))
+
+(def: (visibility-flag visibility)
+ (-> $;Visibility Int)
+ (case visibility
+ #$;Public Opcodes.ACC_PUBLIC
+ #$;Protected Opcodes.ACC_PROTECTED
+ #$;Private Opcodes.ACC_PRIVATE
+ #$;Default 0))
+
+(def: (class-flags config)
+ (-> $;Class-Config Int)
+ ($_ i.+
+ (if (get@ #$;finalC config) Opcodes.ACC_FINAL 0)))
+
+(def: (method-flags config)
+ (-> $;Method-Config Int)
+ ($_ i.+
+ (if (get@ #$;staticM config) Opcodes.ACC_STATIC 0)
+ (if (get@ #$;finalM config) Opcodes.ACC_FINAL 0)
+ (if (get@ #$;synchronizedM config) Opcodes.ACC_SYNCHRONIZED 0)
+ (if (get@ #$;strictM config) Opcodes.ACC_STRICT 0)))
+
+(def: (field-flags config)
+ (-> $;Field-Config Int)
+ ($_ i.+
+ (if (get@ #$;staticF config) Opcodes.ACC_STATIC 0)
+ (if (get@ #$;finalF config) Opcodes.ACC_FINAL 0)
+ (if (get@ #$;transientF config) Opcodes.ACC_TRANSIENT 0)
+ (if (get@ #$;volatileF config) Opcodes.ACC_VOLATILE 0)))
+
+(def: class-to-type
+ (-> $;Class $;Type)
+ (|>. #$;Class #$;Generic))
+
+(def: param-signature
+ (-> $;Class Text)
+ (|>. class-to-type $t;signature (format ":")))
+
+(def: (formal-param [name super interfaces])
+ (-> $;Parameter Text)
+ (format name
+ (param-signature super)
+ (|> interfaces
+ (list/map param-signature)
+ (text;join-with ""))))
+
+(def: (parameters-signature parameters super interfaces)
+ (-> (List $;Parameter) $;Class (List $;Class)
+ Text)
+ (let [formal-params (if (list;empty? parameters)
+ ""
+ (format "<"
+ (|> parameters
+ (list/map formal-param)
+ (text;join-with ""))
+ ">"))]
+ (format formal-params
+ (|> super class-to-type $t;signature)
+ (|> interfaces
+ (list/map (|>. class-to-type $t;signature))
+ (text;join-with "")))))
+
+(def: class-computes
+ Int
+ ($_ i.+
+ ClassWriter.COMPUTE_MAXS
+ ClassWriter.COMPUTE_FRAMES))
+
+(do-template [<name> <flag>]
+ [(def: #export (<name> version visibility config name parameters super interfaces
+ definitions)
+ (-> $;Version $;Visibility $;Class-Config Text (List $;Parameter) $;Class (List $;Class) $;Def
+ (host;type (Array byte)))
+ (let [writer (|> (do-to (ClassWriter.new class-computes)
+ (ClassWriter.visit [(version-flag version)
+ ($_ i.+
+ Opcodes.ACC_SUPER
+ <flag>
+ (visibility-flag visibility)
+ (class-flags config))
+ ($t;binary-name name)
+ (parameters-signature parameters super interfaces)
+ (|> super product;left $t;binary-name)
+ (|> interfaces
+ (list/map (|>. product;left $t;binary-name))
+ string-array)]))
+ definitions)
+ _ (ClassWriter.visitEnd [] writer)]
+ (ClassWriter.toByteArray [] writer)))]
+
+ [class 0]
+ [abstract Opcodes.ACC_ABSTRACT]
+ )
+
+(def: $Object $;Class ["java.lang.Object" (list)])
+
+(def: #export (interface version visibility config name parameters interfaces
+ definitions)
+ (-> $;Version $;Visibility $;Class-Config Text (List $;Parameter) (List $;Class) $;Def
+ (host;type (Array byte)))
+ (let [writer (|> (do-to (ClassWriter.new class-computes)
+ (ClassWriter.visit [(version-flag version)
+ ($_ i.+
+ Opcodes.ACC_SUPER
+ Opcodes.ACC_INTERFACE
+ (visibility-flag visibility)
+ (class-flags config))
+ ($t;binary-name name)
+ (parameters-signature parameters $Object interfaces)
+ (|> $Object product;left $t;binary-name)
+ (|> interfaces
+ (list/map (|>. product;left $t;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
+ $;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)]
+ writer)
+ _ (MethodVisitor.visitCode [] =method)
+ _ (then =method)
+ _ (MethodVisitor.visitMaxs [0 0] =method)
+ _ (MethodVisitor.visitEnd [] =method)]
+ writer)))
+
+(def: #export (abstract-method visibility config name type)
+ (-> $;Visibility $;Method-Config Text $;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)]
+ writer)
+ _ (MethodVisitor.visitEnd [] =method)]
+ writer)))
+
+(def: #export (field visibility config name type)
+ (-> $;Visibility $;Field-Config Text $;Type $;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)
+ (host;null)] writer)
+ (FieldVisitor.visitEnd []))]
+ writer)))
+
+(do-template [<name> <lux-type> <jvm-type> <prepare>]
+ [(def: #export (<name> visibility config name value)
+ (-> $;Visibility $;Field-Config Text <lux-type> $;Def)
+ (function [writer]
+ (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>)
+ (<prepare> value)]
+ writer)
+ (FieldVisitor.visitEnd []))]
+ writer)))]
+
+ [boolean-field Bool $t;boolean id]
+ [byte-field Int $t;byte host;l2b]
+ [short-field Int $t;short host;l2s]
+ [int-field Int $t;int host;l2i]
+ [long-field Int $t;long id]
+ [float-field Frac $t;float host;d2f]
+ [double-field Frac $t;double id]
+ [char-field Nat $t;char (|>. nat-to-int host;l2i host;i2c)]
+ [string-field Text ($t;class "java.lang.String" (list)) id]
+ )
+
+(def: #export (fuse defs)
+ (-> (List $;Def) $;Def)
+ (case defs
+ #;Nil
+ id
+
+ (#;Cons singleton #;Nil)
+ singleton
+
+ (#;Cons head tail)
+ (. (fuse tail) head)))
diff --git a/new-luxc/source/luxc/host/jvm/inst.lux b/new-luxc/source/luxc/host/jvm/inst.lux
new file mode 100644
index 000000000..37ab75020
--- /dev/null
+++ b/new-luxc/source/luxc/host/jvm/inst.lux
@@ -0,0 +1,383 @@
+(;module:
+ [lux #- char]
+ (lux (control monad
+ ["p" parser])
+ (data [maybe]
+ ["e" error]
+ text/format
+ (coll [list "L/" Functor<List>]))
+ [host #+ do-to]
+ [meta]
+ (meta [code]
+ ["s" syntax #+ syntax:]))
+ ["$" ..]
+ (.. ["$t" type]))
+
+## [Host]
+(host;import #long java.lang.Object)
+(host;import #long java.lang.String)
+
+(syntax: (declare [codes (p;many s;local-symbol)])
+ (|> codes
+ (L/map (function [code] (` ((~' #static) (~ (code;local-symbol code)) (~' int)))))
+ wrap))
+
+(`` (host;import org.objectweb.asm.Opcodes
+ (#static NOP int)
+
+ ## Conversion
+ (~~ (declare D2F D2I D2L
+ F2D F2I F2L
+ I2B I2C I2D I2F I2L I2S
+ L2D L2F L2I))
+
+ ## Primitive
+ (~~ (declare T_BOOLEAN T_CHAR T_FLOAT T_DOUBLE
+ T_BYTE T_SHORT T_INT T_LONG))
+
+ ## Class
+ (~~ (declare CHECKCAST NEW INSTANCEOF))
+
+ ## Stack
+ (~~ (declare DUP DUP_X1 DUP_X2
+ DUP2 DUP2_X1 DUP2_X2
+ POP POP2
+ SWAP))
+
+ ## Jump
+ (~~ (declare IF_ICMPEQ IF_ICMPGT IF_ICMPLT IF_ACMPEQ IFNULL
+ IFEQ IFNE IFLT IFLE IFGT IFGE
+ GOTO))
+
+ (#static ACONST_NULL int)
+
+ ## Var
+ (~~ (declare ILOAD LLOAD DLOAD ALOAD
+ ISTORE LSTORE ASTORE))
+
+ ## Arithmetic
+ (~~ (declare IADD ISUB IMUL IDIV IREM
+ LADD LSUB LMUL LDIV LREM LCMP
+ FADD FSUB FMUL FDIV FREM FCMPG FCMPL
+ DADD DSUB DMUL DDIV DREM DCMPG DCMPL))
+
+ ## Bit-wise
+ (~~ (declare IAND IOR IXOR ISHL ISHR IUSHR
+ LAND LOR LXOR LSHL LSHR LUSHR))
+
+ ## Array
+ (~~ (declare ARRAYLENGTH NEWARRAY ANEWARRAY
+ AALOAD AASTORE
+ BALOAD BASTORE
+ SALOAD SASTORE
+ IALOAD IASTORE
+ LALOAD LASTORE
+ FALOAD FASTORE
+ DALOAD DASTORE
+ CALOAD CASTORE))
+
+ ## Member
+ (~~ (declare GETSTATIC PUTSTATIC GETFIELD PUTFIELD
+ INVOKESTATIC INVOKESPECIAL INVOKEVIRTUAL INVOKEINTERFACE))
+
+ (#static ATHROW int)
+
+ ## Concurrency
+ (~~ (declare MONITORENTER MONITOREXIT))
+
+ ## Return
+ (~~ (declare RETURN IRETURN LRETURN DRETURN ARETURN))
+ ))
+
+(host;import org.objectweb.asm.FieldVisitor
+ (visitEnd [] void))
+
+(host;import org.objectweb.asm.Label
+ (new []))
+
+(host;import org.objectweb.asm.MethodVisitor
+ (visitCode [] void)
+ (visitMaxs [int int] void)
+ (visitEnd [] void)
+ (visitInsn [int] void)
+ (visitLdcInsn [Object] void)
+ (visitFieldInsn [int String String String] void)
+ (visitTypeInsn [int String] void)
+ (visitVarInsn [int int] void)
+ (visitIntInsn [int int] void)
+ (visitMethodInsn [int String String String boolean] void)
+ (visitLabel [Label] void)
+ (visitJumpInsn [int Label] void)
+ (visitTryCatchBlock [Label Label Label String] void)
+ (visitTableSwitchInsn [int int Label (Array Label)] void)
+ )
+
+## [Insts]
+(def: #export make-label
+ (Meta Label)
+ (function [compiler]
+ (#e;Success [compiler (Label.new [])])))
+
+(def: #export (with-label action)
+ (-> (-> Label $;Inst) $;Inst)
+ (action (Label.new [])))
+
+(do-template [<name> <type> <prepare>]
+ [(def: #export (<name> value)
+ (-> <type> $;Inst)
+ (function [visitor]
+ (do-to visitor
+ (MethodVisitor.visitLdcInsn [(<prepare> value)]))))]
+
+ [boolean Bool id]
+ [int Int host;l2i]
+ [long Int id]
+ [double Frac id]
+ [char Nat (|>. nat-to-int host;l2i host;i2c)]
+ [string Text id]
+ )
+
+(syntax: (prefix [base s;local-symbol])
+ (wrap (list (code;local-symbol (format "Opcodes." base)))))
+
+(def: #export NULL
+ $;Inst
+ (function [visitor]
+ (do-to visitor
+ (MethodVisitor.visitInsn [(prefix ACONST_NULL)]))))
+
+(do-template [<name>]
+ [(def: #export <name>
+ $;Inst
+ (function [visitor]
+ (do-to visitor
+ (MethodVisitor.visitInsn [(prefix <name>)]))))]
+
+ [NOP]
+
+ ## Stack
+ [DUP] [DUP_X1] [DUP_X2] [DUP2] [DUP2_X1] [DUP2_X2]
+ [POP] [POP2]
+ [SWAP]
+
+ ## Conversions
+ [D2F] [D2I] [D2L]
+ [F2D] [F2I] [F2L]
+ [I2B] [I2C] [I2D] [I2F] [I2L] [I2S]
+ [L2D] [L2F] [L2I]
+
+ ## Integer arithmetic
+ [IADD] [ISUB] [IMUL] [IDIV] [IREM]
+
+ ## Integer bitwise
+ [IAND] [IOR] [IXOR] [ISHL] [ISHR] [IUSHR]
+
+ ## Long arithmetic
+ [LADD] [LSUB] [LMUL] [LDIV] [LREM]
+ [LCMP]
+
+ ## Long bitwise
+ [LAND] [LOR] [LXOR] [LSHL] [LSHR] [LUSHR]
+
+ ## Float arithmetic
+ [FADD] [FSUB] [FMUL] [FDIV] [FREM] [FCMPG] [FCMPL]
+
+ ## Double arithmetic
+ [DADD] [DSUB] [DMUL] [DDIV] [DREM]
+ [DCMPG] [DCMPL]
+
+ ## Array
+ [ARRAYLENGTH]
+ [AALOAD] [AASTORE]
+ [BALOAD] [BASTORE]
+ [SALOAD] [SASTORE]
+ [IALOAD] [IASTORE]
+ [LALOAD] [LASTORE]
+ [FALOAD] [FASTORE]
+ [DALOAD] [DASTORE]
+ [CALOAD] [CASTORE]
+
+ ## Exceptions
+ [ATHROW]
+
+ ## Concurrency
+ [MONITORENTER] [MONITOREXIT]
+
+ ## Return
+ [RETURN] [IRETURN] [LRETURN] [DRETURN] [ARETURN]
+ )
+
+(do-template [<name>]
+ [(def: #export (<name> register)
+ (-> Nat $;Inst)
+ (function [visitor]
+ (do-to visitor
+ (MethodVisitor.visitVarInsn [(prefix <name>) (nat-to-int register)]))))]
+
+ [ILOAD] [LLOAD] [DLOAD] [ALOAD]
+ [ISTORE] [LSTORE] [ASTORE]
+ )
+
+(do-template [<name> <inst>]
+ [(def: #export (<name> class field type)
+ (-> Text Text $;Type $;Inst)
+ (function [visitor]
+ (do-to visitor
+ (MethodVisitor.visitFieldInsn [<inst> ($t;binary-name class) field ($t;descriptor type)]))))]
+
+ [GETSTATIC Opcodes.GETSTATIC]
+ [PUTSTATIC Opcodes.PUTSTATIC]
+
+ [PUTFIELD Opcodes.PUTFIELD]
+ [GETFIELD Opcodes.GETFIELD]
+ )
+
+(do-template [<name> <inst>]
+ [(def: #export (<name> class)
+ (-> Text $;Inst)
+ (function [visitor]
+ (do-to visitor
+ (MethodVisitor.visitTypeInsn [<inst> ($t;binary-name class)]))))]
+
+ [CHECKCAST Opcodes.CHECKCAST]
+ [NEW Opcodes.NEW]
+ [INSTANCEOF Opcodes.INSTANCEOF]
+ [ANEWARRAY Opcodes.ANEWARRAY]
+ )
+
+(def: #export (NEWARRAY type)
+ (-> $;Primitive $;Inst)
+ (function [visitor]
+ (do-to visitor
+ (MethodVisitor.visitIntInsn [Opcodes.NEWARRAY (case type
+ #$;Boolean Opcodes.T_BOOLEAN
+ #$;Byte Opcodes.T_BYTE
+ #$;Short Opcodes.T_SHORT
+ #$;Int Opcodes.T_INT
+ #$;Long Opcodes.T_LONG
+ #$;Float Opcodes.T_FLOAT
+ #$;Double Opcodes.T_DOUBLE
+ #$;Char Opcodes.T_CHAR)]))))
+
+(do-template [<name> <inst>]
+ [(def: #export (<name> class method-name method-signature interface?)
+ (-> Text Text $;Method Bool $;Inst)
+ (function [visitor]
+ (do-to visitor
+ (MethodVisitor.visitMethodInsn [<inst> ($t;binary-name class) method-name ($t;method-descriptor method-signature) interface?]))))]
+
+ [INVOKESTATIC Opcodes.INVOKESTATIC]
+ [INVOKEVIRTUAL Opcodes.INVOKEVIRTUAL]
+ [INVOKESPECIAL Opcodes.INVOKESPECIAL]
+ [INVOKEINTERFACE Opcodes.INVOKEINTERFACE]
+ )
+
+(do-template [<name>]
+ [(def: #export (<name> @where)
+ (-> $;Label $;Inst)
+ (function [visitor]
+ (do-to visitor
+ (MethodVisitor.visitJumpInsn [(prefix <name>) @where]))))]
+
+ [IF_ICMPEQ] [IF_ICMPGT] [IF_ICMPLT] [IF_ACMPEQ] [IFNULL]
+ [IFEQ] [IFNE] [IFLT] [IFLE] [IFGT] [IFGE]
+ [GOTO]
+ )
+
+(def: #export (TABLESWITCH min max default labels)
+ (-> Int Int $;Label (List $;Label) $;Inst)
+ (function [visitor]
+ (let [num-labels (list;size labels)
+ labels-array (host;array Label num-labels)
+ _ (loop [idx +0]
+ (if (n.< num-labels idx)
+ (exec (host;array-write idx
+ (maybe;assume (list;nth idx labels))
+ labels-array)
+ (recur (n.inc idx)))
+ []))]
+ (do-to visitor
+ (MethodVisitor.visitTableSwitchInsn [min max default labels-array])))))
+
+(def: #export (try @from @to @handler exception)
+ (-> $;Label $;Label $;Label Text $;Inst)
+ (function [visitor]
+ (do-to visitor
+ (MethodVisitor.visitTryCatchBlock [@from @to @handler ($t;binary-name exception)]))))
+
+(def: #export (label @label)
+ (-> $;Label $;Inst)
+ (function [visitor]
+ (do-to visitor
+ (MethodVisitor.visitLabel [@label]))))
+
+(def: #export (array type)
+ (-> $;Type $;Inst)
+ (case type
+ (#$;Primitive prim)
+ (NEWARRAY prim)
+
+ (#$;Generic generic)
+ (let [elem-class (case generic
+ (#$;Class class params)
+ ($t;binary-name class)
+
+ _
+ ($t;binary-name "java.lang.Object"))]
+ (ANEWARRAY elem-class))
+
+ _
+ (ANEWARRAY ($t;descriptor type))))
+
+(def: (primitive-wrapper type)
+ (-> $;Primitive Text)
+ (case type
+ #$;Boolean "java.lang.Boolean"
+ #$;Byte "java.lang.Byte"
+ #$;Short "java.lang.Short"
+ #$;Int "java.lang.Integer"
+ #$;Long "java.lang.Long"
+ #$;Float "java.lang.Float"
+ #$;Double "java.lang.Double"
+ #$;Char "java.lang.Character"))
+
+(def: (primitive-unwrap type)
+ (-> $;Primitive Text)
+ (case type
+ #$;Boolean "booleanValue"
+ #$;Byte "byteValue"
+ #$;Short "shortValue"
+ #$;Int "intValue"
+ #$;Long "longValue"
+ #$;Float "floatValue"
+ #$;Double "doubleValue"
+ #$;Char "charValue"))
+
+(def: #export (wrap type)
+ (-> $;Primitive $;Inst)
+ (let [class (primitive-wrapper type)]
+ (|>. (INVOKESTATIC class "valueOf"
+ ($t;method (list (#$;Primitive type))
+ (#;Some ($t;class class (list)))
+ (list))
+ false))))
+
+(def: #export (unwrap type)
+ (-> $;Primitive $;Inst)
+ (let [class (primitive-wrapper type)]
+ (|>. (CHECKCAST class)
+ (INVOKEVIRTUAL class (primitive-unwrap type)
+ ($t;method (list) (#;Some (#$;Primitive type)) (list))
+ false))))
+
+(def: #export (fuse insts)
+ (-> (List $;Inst) $;Inst)
+ (case insts
+ #;Nil
+ id
+
+ (#;Cons singleton #;Nil)
+ singleton
+
+ (#;Cons head tail)
+ (. (fuse tail) head)))
diff --git a/new-luxc/source/luxc/host/jvm/type.lux b/new-luxc/source/luxc/host/jvm/type.lux
new file mode 100644
index 000000000..3825d443b
--- /dev/null
+++ b/new-luxc/source/luxc/host/jvm/type.lux
@@ -0,0 +1,138 @@
+(;module:
+ [lux #- char]
+ (lux (data [text]
+ text/format
+ (coll [list "L/" Functor<List>])))
+ ["$" ..])
+
+## Types
+(do-template [<name> <primitive>]
+ [(def: #export <name> $;Type (#$;Primitive <primitive>))]
+
+ [boolean #$;Boolean]
+ [byte #$;Byte]
+ [short #$;Short]
+ [int #$;Int]
+ [long #$;Long]
+ [float #$;Float]
+ [double #$;Double]
+ [char #$;Char]
+ )
+
+(def: #export (class name params)
+ (-> Text (List $;Generic) $;Type)
+ (#$;Generic (#$;Class name params)))
+
+(def: #export (var name)
+ (-> Text $;Type)
+ (#$;Generic (#$;Var name)))
+
+(def: #export (wildcard bound)
+ (-> (Maybe [$;Bound $;Generic]) $;Type)
+ (#$;Generic (#$;Wildcard bound)))
+
+(def: #export (array depth elemT)
+ (-> Nat $;Type $;Type)
+ (case depth
+ +0 elemT
+ _ (#$;Array (array (n.dec depth) elemT))))
+
+(def: #export (binary-name class)
+ (-> Text Text)
+ (text;replace-all "." "/" class))
+
+(def: #export (descriptor type)
+ (-> $;Type Text)
+ (case type
+ (#$;Primitive prim)
+ (case prim
+ #$;Boolean "Z"
+ #$;Byte "B"
+ #$;Short "S"
+ #$;Int "I"
+ #$;Long "J"
+ #$;Float "F"
+ #$;Double "D"
+ #$;Char "C")
+
+ (#$;Array sub)
+ (format "[" (descriptor sub))
+
+ (#$;Generic generic)
+ (case generic
+ (#$;Class class params)
+ (format "L" (binary-name class) ";")
+
+ (^or (#$;Var name) (#$;Wildcard ?bound))
+ (descriptor (#$;Generic (#$;Class "java.lang.Object" (list)))))
+ ))
+
+(def: #export (signature type)
+ (-> $;Type Text)
+ (case type
+ (#$;Primitive prim)
+ (case prim
+ #$;Boolean "Z"
+ #$;Byte "B"
+ #$;Short "S"
+ #$;Int "I"
+ #$;Long "J"
+ #$;Float "F"
+ #$;Double "D"
+ #$;Char "C")
+
+ (#$;Array sub)
+ (format "[" (signature sub))
+
+ (#$;Generic generic)
+ (case generic
+ (#$;Class class params)
+ (let [=params (if (list;empty? params)
+ ""
+ (format "<"
+ (|> params
+ (L/map (|>. #$;Generic signature))
+ (text;join-with ""))
+ ">"))]
+ (format "L" (binary-name class) =params ";"))
+
+ (#$;Var name)
+ (format "T" name ";")
+
+ (#$;Wildcard #;None)
+ "*"
+
+ (^template [<tag> <prefix>]
+ (#$;Wildcard (#;Some [<tag> bound]))
+ (format <prefix> (signature (#$;Generic bound))))
+ ([#$;Upper "+"]
+ [#$;Lower "-"]))
+ ))
+
+## Methods
+(def: #export (method args return exceptions)
+ (-> (List $;Type) (Maybe $;Type) (List $;Generic) $;Method)
+ {#$;args args #$;return return #$;exceptions exceptions})
+
+(def: #export (method-descriptor method)
+ (-> $;Method Text)
+ (format "(" (text;join-with "" (L/map descriptor (get@ #$;args method))) ")"
+ (case (get@ #$;return method)
+ #;None
+ "V"
+
+ (#;Some return)
+ (descriptor return))))
+
+(def: #export (method-signature method)
+ (-> $;Method Text)
+ (format "(" (|> (get@ #$;args method) (L/map signature) (text;join-with "")) ")"
+ (case (get@ #$;return method)
+ #;None
+ "V"
+
+ (#;Some return)
+ (signature return))
+ (|> (get@ #$;exceptions method)
+ (L/map (|>. #$;Generic signature (format "^")))
+ (text;join-with ""))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-26 13:36:01 +0000