Split new-luxc into lux-jvm and lux-r.

1 files changed, 0 insertions, 538 deletions

diff --git a/new-luxc/source/luxc/lang/directive/jvm.lux b/new-luxc/source/luxc/lang/directive/jvm.lux
deleted file mode 100644
index 27b1c8688..000000000
--- a/new-luxc/source/luxc/lang/directive/jvm.lux
+++ /dev/null
@@ -1,538 +0,0 @@
-(.module:
-  [lux #*
-   [host (#+ import:)]
-   [type (#+ :share)]
-   [abstract
-    ["." monad (#+ do)]]
-   [control
-    ["." try (#+ Try)]]
-   [target
-    ["/" jvm]]
-   [data
-    [identity (#+ Identity)]
-    ["." product]
-    [number
-     ["." nat]]
-    [text
-     ["%" format (#+ format)]]
-    [collection
-     ["." list ("#@." fold)]
-     ["." dictionary (#+ Dictionary)]
-     ["." row (#+ Row) ("#@." functor fold)]]]
-   [tool
-    [compiler
-     ["." phase]
-     [language
-      [lux
-       [synthesis (#+ Synthesis)]
-       ["." generation]
-       ["." directive]
-       [phase
-        ["." extension
-         ["." bundle]
-         [directive
-          ["./" lux]]]]]]]]]
-  [///
-   [host
-    ["." jvm (#+ Inst)
-     ["_" inst]]]])
-
-(import: #long org/objectweb/asm/Label
-  (new []))
-
-(def: (literal literal)
-  (-> /.Literal Inst)
-  (case literal
-    (#/.Boolean value) (_.boolean value)
-    (#/.Int value) (_.int value)
-    (#/.Long value) (_.long value)
-    (#/.Double value) (_.double value)
-    (#/.Char value) (_.char value)
-    (#/.String value) (_.string value)))
-
-(def: (constant instruction)
-  (-> /.Constant Inst)
-  (case instruction
-    (#/.BIPUSH constant) (_.BIPUSH constant)
-    
-    (#/.SIPUSH constant) (_.SIPUSH constant)
-
-    #/.ICONST_M1 _.ICONST_M1
-    #/.ICONST_0 _.ICONST_0
-    #/.ICONST_1 _.ICONST_1
-    #/.ICONST_2 _.ICONST_2
-    #/.ICONST_3 _.ICONST_3
-    #/.ICONST_4 _.ICONST_4
-    #/.ICONST_5 _.ICONST_5
-
-    #/.LCONST_0 _.LCONST_0
-    #/.LCONST_1 _.LCONST_1
-    
-    #/.FCONST_0 _.FCONST_0
-    #/.FCONST_1 _.FCONST_1
-    #/.FCONST_2 _.FCONST_2
-    
-    #/.DCONST_0 _.DCONST_0
-    #/.DCONST_1 _.DCONST_1
-    
-    #/.ACONST_NULL _.NULL
-
-    (#/.LDC literal)
-    (..literal literal)
-    ))
-
-(def: (int-arithmetic instruction)
-  (-> /.Int-Arithmetic Inst)
-  (case instruction
-    #/.IADD _.IADD
-    #/.ISUB _.ISUB
-    #/.IMUL _.IMUL
-    #/.IDIV _.IDIV
-    #/.IREM _.IREM
-    #/.INEG _.INEG))
-
-(def: (long-arithmetic instruction)
-  (-> /.Long-Arithmetic Inst)
-  (case instruction
-    #/.LADD _.LADD
-    #/.LSUB _.LSUB
-    #/.LMUL _.LMUL
-    #/.LDIV _.LDIV
-    #/.LREM _.LREM
-    #/.LNEG _.LNEG))
-
-(def: (float-arithmetic instruction)
-  (-> /.Float-Arithmetic Inst)
-  (case instruction
-    #/.FADD _.FADD
-    #/.FSUB _.FSUB
-    #/.FMUL _.FMUL
-    #/.FDIV _.FDIV
-    #/.FREM _.FREM
-    #/.FNEG _.FNEG))
-
-(def: (double-arithmetic instruction)
-  (-> /.Double-Arithmetic Inst)
-  (case instruction
-    #/.DADD _.DADD
-    #/.DSUB _.DSUB
-    #/.DMUL _.DMUL
-    #/.DDIV _.DDIV
-    #/.DREM _.DREM
-    #/.DNEG _.DNEG))
-
-(def: (arithmetic instruction)
-  (-> /.Arithmetic Inst)
-  (case instruction
-    (#/.Int-Arithmetic int-arithmetic)
-    (..int-arithmetic int-arithmetic)
-    
-    (#/.Long-Arithmetic long-arithmetic)
-    (..long-arithmetic long-arithmetic)
-    
-    (#/.Float-Arithmetic float-arithmetic)
-    (..float-arithmetic float-arithmetic)
-    
-    (#/.Double-Arithmetic double-arithmetic)
-    (..double-arithmetic double-arithmetic)))
-
-(def: (int-bitwise instruction)
-  (-> /.Int-Bitwise Inst)
-  (case instruction
-    #/.IOR _.IOR
-    #/.IXOR _.IXOR
-    #/.IAND _.IAND
-    #/.ISHL _.ISHL
-    #/.ISHR _.ISHR
-    #/.IUSHR _.IUSHR))
-
-(def: (long-bitwise instruction)
-  (-> /.Long-Bitwise Inst)
-  (case instruction
-    #/.LOR _.LOR
-    #/.LXOR _.LXOR
-    #/.LAND _.LAND
-    #/.LSHL _.LSHL
-    #/.LSHR _.LSHR
-    #/.LUSHR _.LUSHR))
-
-(def: (bitwise instruction)
-  (-> /.Bitwise Inst)
-  (case instruction
-    (#/.Int-Bitwise int-bitwise)
-    (..int-bitwise int-bitwise)
-    
-    (#/.Long-Bitwise long-bitwise)
-    (..long-bitwise long-bitwise)))
-
-(def: (conversion instruction)
-  (-> /.Conversion Inst)
-  (case instruction
-    #/.I2B _.I2B
-    #/.I2S _.I2S
-    #/.I2L _.I2L
-    #/.I2F _.I2F
-    #/.I2D _.I2D
-    #/.I2C _.I2C
-
-    #/.L2I _.L2I
-    #/.L2F _.L2F
-    #/.L2D _.L2D
-
-    #/.F2I _.F2I
-    #/.F2L _.F2L
-    #/.F2D _.F2D
-    
-    #/.D2I _.D2I
-    #/.D2L _.D2L
-    #/.D2F _.D2F))
-
-(def: (array instruction)
-  (-> /.Array Inst)
-  (case instruction
-    #/.ARRAYLENGTH _.ARRAYLENGTH
-
-    (#/.NEWARRAY type) (_.NEWARRAY type)
-    (#/.ANEWARRAY type) (_.ANEWARRAY type)
-
-    #/.BALOAD _.BALOAD
-    #/.BASTORE _.BASTORE
-
-    #/.SALOAD _.SALOAD
-    #/.SASTORE _.SASTORE
-
-    #/.IALOAD _.IALOAD
-    #/.IASTORE _.IASTORE
-
-    #/.LALOAD _.LALOAD
-    #/.LASTORE _.LASTORE
-
-    #/.FALOAD _.FALOAD
-    #/.FASTORE _.FASTORE
-
-    #/.DALOAD _.DALOAD
-    #/.DASTORE _.DASTORE
-    
-    #/.CALOAD _.CALOAD
-    #/.CASTORE _.CASTORE
-
-    #/.AALOAD _.AALOAD
-    #/.AASTORE _.AASTORE))
-
-(def: (object instruction)
-  (-> /.Object Inst)
-  (case instruction
-    (^template [<tag> <inst>]
-      (<tag> class field-name field-type)
-      (<inst> class field-name field-type))
-    ([#/.GETSTATIC _.GETSTATIC]
-     [#/.PUTSTATIC _.PUTSTATIC]
-     [#/.GETFIELD _.GETFIELD]
-     [#/.PUTFIELD _.PUTFIELD])
-    
-    (#/.NEW type) (_.NEW type)
-    
-    (#/.INSTANCEOF type) (_.INSTANCEOF type)
-    (#/.CHECKCAST type) (_.CHECKCAST type)
-
-    (^template [<tag> <inst>]
-      (<tag> class method-name method-type)
-      (<inst> class method-name method-type))
-    ([#/.INVOKEINTERFACE _.INVOKEINTERFACE]
-     [#/.INVOKESPECIAL _.INVOKESPECIAL]
-     [#/.INVOKESTATIC _.INVOKESTATIC]
-     [#/.INVOKEVIRTUAL _.INVOKEVIRTUAL])
-    ))
-
-(def: (local-int instruction)
-  (-> /.Local-Int Inst)
-  (case instruction
-    (#/.ILOAD register) (_.ILOAD register)
-    (#/.ISTORE register) (_.ISTORE register)))
-
-(def: (local-long instruction)
-  (-> /.Local-Long Inst)
-  (case instruction
-    (#/.LLOAD register) (_.LLOAD register)
-    (#/.LSTORE register) (_.LSTORE register)))
-
-(def: (local-float instruction)
-  (-> /.Local-Float Inst)
-  (case instruction
-    (#/.FLOAD register) (_.FLOAD register)
-    (#/.FSTORE register) (_.FSTORE register)))
-
-(def: (local-double instruction)
-  (-> /.Local-Double Inst)
-  (case instruction
-    (#/.DLOAD register) (_.DLOAD register)
-    (#/.DSTORE register) (_.DSTORE register)))
-
-(def: (local-object instruction)
-  (-> /.Local-Object Inst)
-  (case instruction
-    (#/.ALOAD register) (_.ALOAD register)
-    (#/.ASTORE register) (_.ASTORE register)))
-
-(def: (local instruction)
-  (-> /.Local Inst)
-  (case instruction
-    (#/.Local-Int instruction) (..local-int instruction)
-    (#/.IINC register) (_.IINC register)
-    (#/.Local-Long instruction) (..local-long instruction)
-    (#/.Local-Float instruction) (..local-float instruction)
-    (#/.Local-Double instruction) (..local-double instruction)
-    (#/.Local-Object instruction) (..local-object instruction)))
-
-(def: (stack instruction)
-  (-> /.Stack Inst)
-  (case instruction
-    #/.DUP _.DUP
-    #/.DUP_X1 _.DUP_X1
-    #/.DUP_X2 _.DUP_X2
-    #/.DUP2 _.DUP2
-    #/.DUP2_X1 _.DUP2_X1
-    #/.DUP2_X2 _.DUP2_X2
-    #/.SWAP _.SWAP
-    #/.POP _.POP
-    #/.POP2 _.POP2))
-
-(def: (comparison instruction)
-  (-> /.Comparison Inst)
-  (case instruction
-    #/.LCMP _.LCMP
-    
-    #/.FCMPG _.FCMPG
-    #/.FCMPL _.FCMPL
-
-    #/.DCMPG _.DCMPG
-    #/.DCMPL _.DCMPL))
-
-(def: (branching instruction)
-  (-> (/.Branching org/objectweb/asm/Label) Inst)
-  (case instruction
-    (#/.IF_ICMPEQ label) (_.IF_ICMPEQ label)
-    (#/.IF_ICMPGE label) (_.IF_ICMPGE label)
-    (#/.IF_ICMPGT label) (_.IF_ICMPGT label)
-    (#/.IF_ICMPLE label) (_.IF_ICMPLE label)
-    (#/.IF_ICMPLT label) (_.IF_ICMPLT label)
-    (#/.IF_ICMPNE label) (_.IF_ICMPNE label)
-    (#/.IFEQ label) (_.IFEQ label)
-    (#/.IFGE label) (_.IFGE label)
-    (#/.IFGT label) (_.IFGT label)
-    (#/.IFLE label) (_.IFLE label)
-    (#/.IFLT label) (_.IFLT label)
-    (#/.IFNE label) (_.IFNE label)
-
-    (#/.TABLESWITCH min max default labels)
-    (_.TABLESWITCH min max default labels)
-    
-    (#/.LOOKUPSWITCH default keys+labels)
-    (_.LOOKUPSWITCH default keys+labels)
-
-    (#/.IF_ACMPEQ label) (_.IF_ACMPEQ label)
-    (#/.IF_ACMPNE label) (_.IF_ACMPNE label)
-    (#/.IFNONNULL label) (_.IFNONNULL label)
-    (#/.IFNULL label) (_.IFNULL label)))
-
-(def: (exception instruction)
-  (-> (/.Exception org/objectweb/asm/Label) Inst)
-  (case instruction
-    (#/.Try start end handler exception) (_.try start end handler exception)
-    #/.ATHROW _.ATHROW))
-
-(def: (concurrency instruction)
-  (-> /.Concurrency Inst)
-  (case instruction
-    #/.MONITORENTER _.MONITORENTER
-    #/.MONITOREXIT _.MONITOREXIT))
-
-(def: (return instruction)
-  (-> /.Return Inst)
-  (case instruction
-    #/.RETURN _.RETURN
-    #/.IRETURN _.IRETURN
-    #/.LRETURN _.LRETURN
-    #/.FRETURN _.FRETURN
-    #/.DRETURN _.DRETURN
-    #/.ARETURN _.ARETURN))
-
-(def: (control instruction)
-  (-> (/.Control org/objectweb/asm/Label) Inst)
-  (case instruction
-    (#/.GOTO label) (_.GOTO label)
-    (#/.Branching instruction) (..branching instruction)
-    (#/.Exception instruction) (..exception instruction)
-    (#/.Concurrency instruction) (..concurrency instruction)
-    (#/.Return instruction) (..return instruction)))
-
-(def: (instruction instruction)
-  (-> (/.Instruction org/objectweb/asm/Label) Inst)
-  (case instruction
-    #/.NOP _.NOP
-    (#/.Constant instruction) (..constant instruction)
-    (#/.Arithmetic instruction) (..arithmetic instruction)
-    (#/.Bitwise instruction) (..bitwise instruction)
-    (#/.Conversion instruction) (..conversion instruction)
-    (#/.Array instruction) (..array instruction)
-    (#/.Object instruction) (..object instruction)
-    (#/.Local instruction) (..local instruction)
-    (#/.Stack instruction) (..stack instruction)
-    (#/.Comparison instruction) (..comparison instruction)
-    (#/.Control instruction) (..control instruction)))
-
-(type: Mapping
-  (Dictionary /.Label org/objectweb/asm/Label))
-
-(type: (Re-labeler context)
-  (-> [Mapping (context /.Label)]
-      [Mapping (context org/objectweb/asm/Label)]))
-
-(def: (relabel [mapping label])
-  (Re-labeler Identity)
-  (case (dictionary.get label mapping)
-    (#.Some label)
-    [mapping label]
-
-    #.None
-    (let [label' (org/objectweb/asm/Label::new)]
-      [(dictionary.put label label' mapping) label'])))
-
-(def: (relabel-branching [mapping instruction])
-  (Re-labeler /.Branching)
-  (case instruction
-    (^template [<tag>]
-      (<tag> label)
-      (let [[mapping label] (..relabel [mapping label])]
-        [mapping (<tag> label)]))
-    ([#/.IF_ICMPEQ] [#/.IF_ICMPGE] [#/.IF_ICMPGT] [#/.IF_ICMPLE] [#/.IF_ICMPLT] [#/.IF_ICMPNE]
-     [#/.IFEQ] [#/.IFNE] [#/.IFGE] [#/.IFGT] [#/.IFLE] [#/.IFLT]
-
-     [#/.IF_ACMPEQ] [#/.IF_ACMPNE] [#/.IFNONNULL] [#/.IFNULL])
-
-    (#/.TABLESWITCH min max default labels)
-    (let [[mapping default] (..relabel [mapping default])
-          [mapping labels] (list@fold (function (_ input [mapping output])
-                                        (let [[mapping input] (..relabel [mapping input])]
-                                          [mapping (list& input output)]))
-                                      [mapping (list)] labels)]
-      [mapping (#/.TABLESWITCH min max default (list.reverse labels))])
-    
-    (#/.LOOKUPSWITCH default keys+labels)
-    (let [[mapping default] (..relabel [mapping default])
-          [mapping keys+labels] (list@fold (function (_ [expected input] [mapping output])
-                                             (let [[mapping input] (..relabel [mapping input])]
-                                               [mapping (list& [expected input] output)]))
-                                           [mapping (list)] keys+labels)]
-      [mapping (#/.LOOKUPSWITCH default (list.reverse keys+labels))])
-    ))
-
-(def: (relabel-exception [mapping instruction])
-  (Re-labeler /.Exception)
-  (case instruction
-    (#/.Try start end handler exception)
-    (let [[mapping start] (..relabel [mapping start])
-          [mapping end] (..relabel [mapping end])
-          [mapping handler] (..relabel [mapping handler])]
-      [mapping (#/.Try start end handler exception)])
-    
-    #/.ATHROW
-    [mapping #/.ATHROW]
-    ))
-
-(def: (relabel-control [mapping instruction])
-  (Re-labeler /.Control)
-  (case instruction
-    (^template [<tag> <relabel>]
-      (<tag> instruction)
-      (let [[mapping instruction] (<relabel> [mapping instruction])]
-        [mapping (<tag> instruction)]))
-    ([#/.GOTO ..relabel]
-     [#/.Branching ..relabel-branching]
-     [#/.Exception ..relabel-exception])
-
-    (^template [<tag>]
-      (<tag> instruction)
-      [mapping (<tag> instruction)])
-    ([#/.Concurrency] [#/.Return])
-    ))
-
-(def: (relabel-instruction [mapping instruction])
-  (Re-labeler /.Instruction)
-  (case instruction
-    #/.NOP [mapping #/.NOP]
-
-    (^template [<tag>]
-      (<tag> instruction)
-      [mapping (<tag> instruction)])
-    ([#/.Constant]
-     [#/.Arithmetic]
-     [#/.Bitwise]
-     [#/.Conversion]
-     [#/.Array]
-     [#/.Object]
-     [#/.Local]
-     [#/.Stack]
-     [#/.Comparison])
-    
-    (#/.Control instruction)
-    (let [[mapping instruction] (..relabel-control [mapping instruction])]
-      [mapping (#/.Control instruction)])))
-
-(def: (relabel-bytecode [mapping bytecode])
-  (Re-labeler /.Bytecode)
-  (row@fold (function (_ input [mapping output])
-              (let [[mapping input] (..relabel-instruction [mapping input])]
-                [mapping (row.add input output)]))
-            [mapping (row.row)]
-            bytecode))
-
-(def: fresh
-  Mapping
-  (dictionary.new nat.hash))
-
-(def: bytecode
-  (-> (/.Bytecode /.Label) Inst)
-  (|>> [..fresh]
-       ..relabel-bytecode
-       product.right
-       (row@map ..instruction)
-       row.to-list
-       _.fuse))
-
-(type: Pseudo-Handler
-  (-> Text (List Synthesis) (Try (/.Bytecode /.Label))))
-
-(def: (true-handler pseudo)
-  (-> Pseudo-Handler jvm.Handler)
-  (function (_ extension-name phase archive inputs)
-    (|> (pseudo extension-name inputs)
-        (:: try.monad map ..bytecode)
-        phase.lift)))
-
-(def: (def::generation extender)
-  (-> jvm.Extender
-      (directive.Handler jvm.Anchor jvm.Inst jvm.Definition))
-  (function (handler extension-name phase archive inputsC+)
-    (case inputsC+
-      (^ (list nameC valueC))
-      (do phase.monad
-        [[_ _ name] (lux/.evaluate! archive Text nameC)
-         [_ _ pseudo-handlerV] (lux/.evaluate! archive ..Pseudo-Handler valueC)
-         _ (|> pseudo-handlerV
-               (:coerce ..Pseudo-Handler)
-               ..true-handler
-               (extension.install extender (:coerce Text name))
-               directive.lift-generation)
-         _ (directive.lift-generation
-            (generation.log! (format "Generation " (%.text (:coerce Text name)))))]
-        (wrap directive.no-requirements))
-
-      _
-      (phase.throw extension.invalid-syntax [extension-name %.code inputsC+]))))
-
-(def: #export (bundle extender)
-  (-> jvm.Extender
-      (directive.Bundle jvm.Anchor jvm.Inst jvm.Definition))
-  (|> bundle.empty
-      (dictionary.put "lux def generation" (..def::generation extender))))