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.lux288
-rw-r--r--new-luxc/source/luxc/host/jvm/inst.lux383
-rw-r--r--new-luxc/source/luxc/host/jvm/type.lux138
-rw-r--r--new-luxc/source/luxc/host/macro.lux37
5 files changed, 0 insertions, 976 deletions
diff --git a/new-luxc/source/luxc/host/jvm.lux b/new-luxc/source/luxc/host/jvm.lux
deleted file mode 100644
index 24d4a9ea9..000000000
--- a/new-luxc/source/luxc/host/jvm.lux
+++ /dev/null
@@ -1,130 +0,0 @@
-(;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
deleted file mode 100644
index 60009fb5c..000000000
--- a/new-luxc/source/luxc/host/jvm/def.lux
+++ /dev/null
@@ -1,288 +0,0 @@
-(;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
deleted file mode 100644
index 37ab75020..000000000
--- a/new-luxc/source/luxc/host/jvm/inst.lux
+++ /dev/null
@@ -1,383 +0,0 @@
-(;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
deleted file mode 100644
index 3825d443b..000000000
--- a/new-luxc/source/luxc/host/jvm/type.lux
+++ /dev/null
@@ -1,138 +0,0 @@
-(;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 ""))))
diff --git a/new-luxc/source/luxc/host/macro.lux b/new-luxc/source/luxc/host/macro.lux
deleted file mode 100644
index 1a3152222..000000000
--- a/new-luxc/source/luxc/host/macro.lux
+++ /dev/null
@@ -1,37 +0,0 @@
-(;module:
- lux
- (lux (control [monad #+ do])
- (data ["e" error])
- [meta]
- [host])
- (luxc [";L" host]
- (lang (translation [";T" common]))))
-
-(for {"JVM" (as-is (host;import java.lang.reflect.Method
- (invoke [Object (Array Object)] #try Object))
- (host;import (java.lang.Class c)
- (getMethod [String (Array (Class Object))] #try Method))
- (host;import java.lang.Object
- (getClass [] (Class Object))
- (toString [] String))
- (def: _object-class (Class Object) (host;class-for Object))
- (def: _apply-args
- (Array (Class Object))
- (|> (host;array (Class Object) +2)
- (host;array-write +0 _object-class)
- (host;array-write +1 _object-class)))
- (def: #export (expand macro inputs)
- (-> Macro (List Code) (Meta (List Code)))
- (do meta;Monad<Meta>
- [class (commonT;load-class hostL;function-class)]
- (function [compiler]
- (do e;Monad<Error>
- [apply-method (Class.getMethod ["apply" _apply-args] class)
- output (Method.invoke [(:! Object macro)
- (|> (host;array Object +2)
- (host;array-write +0 (:! Object inputs))
- (host;array-write +1 (:! Object compiler)))]
- apply-method)]
- (:! (e;Error [Compiler (List Code)])
- output))))))
- })
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-27 03:08:35 +0000