aboutsummaryrefslogtreecommitdiff
path: root/lux-jvm/source/luxc/lang
diff options
context:
space:
mode:
Diffstat (limited to 'lux-jvm/source/luxc/lang')
-rw-r--r--lux-jvm/source/luxc/lang/directive/jvm.lux538
-rw-r--r--lux-jvm/source/luxc/lang/host/jvm.lux131
-rw-r--r--lux-jvm/source/luxc/lang/host/jvm/def.lux298
-rw-r--r--lux-jvm/source/luxc/lang/host/jvm/inst.lux464
-rw-r--r--lux-jvm/source/luxc/lang/synthesis/variable.lux98
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm.lux182
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/case.lux239
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/common.lux72
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/expression.lux72
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/extension.lux16
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux388
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux1047
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/function.lux331
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/loop.lux81
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/primitive.lux30
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/program.lux82
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/reference.lux65
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/runtime.lux387
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/structure.lux79
19 files changed, 4600 insertions, 0 deletions
diff --git a/lux-jvm/source/luxc/lang/directive/jvm.lux b/lux-jvm/source/luxc/lang/directive/jvm.lux
new file mode 100644
index 000000000..27b1c8688
--- /dev/null
+++ b/lux-jvm/source/luxc/lang/directive/jvm.lux
@@ -0,0 +1,538 @@
+(.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))))
diff --git a/lux-jvm/source/luxc/lang/host/jvm.lux b/lux-jvm/source/luxc/lang/host/jvm.lux
new file mode 100644
index 000000000..d957bdb1d
--- /dev/null
+++ b/lux-jvm/source/luxc/lang/host/jvm.lux
@@ -0,0 +1,131 @@
+(.module:
+ [lux (#- Definition Type)
+ [host (#+ import:)]
+ [abstract
+ monad]
+ [control
+ ["p" parser
+ ["s" code]]]
+ [data
+ [binary (#+ Binary)]
+ [collection
+ ["." list ("#/." functor)]]]
+ [macro
+ ["." code]
+ [syntax (#+ syntax:)]]
+ [target
+ [jvm
+ ["." type (#+ Type)
+ [category (#+ Class)]]]]
+ [tool
+ [compiler
+ [reference (#+ Register)]
+ [language
+ [lux
+ ["." generation]]]
+ [meta
+ [archive (#+ Archive)]]]]])
+
+(import: org/objectweb/asm/MethodVisitor)
+
+(import: org/objectweb/asm/ClassWriter)
+
+(import: #long org/objectweb/asm/Label
+ (new []))
+
+(type: #export Def
+ (-> ClassWriter ClassWriter))
+
+(type: #export Inst
+ (-> MethodVisitor MethodVisitor))
+
+(type: #export Label
+ org/objectweb/asm/Label)
+
+(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)
+
+(type: #export ByteCode Binary)
+
+(type: #export Definition [Text ByteCode])
+
+(type: #export Anchor [Label Register])
+
+(type: #export Host
+ (generation.Host Inst Definition))
+
+(template [<name> <base>]
+ [(type: #export <name>
+ (<base> ..Anchor Inst Definition))]
+
+ [State generation.State]
+ [Operation generation.Operation]
+ [Phase generation.Phase]
+ [Handler generation.Handler]
+ [Bundle generation.Bundle]
+ [Extender generation.Extender]
+ )
+
+(type: #export (Generator i)
+ (-> Phase Archive i (Operation Inst)))
+
+(syntax: (config: {type s.local-identifier}
+ {none s.local-identifier}
+ {++ s.local-identifier}
+ {options (s.tuple (p.many s.local-identifier))})
+ (let [g!type (code.local-identifier type)
+ g!none (code.local-identifier none)
+ g!tags+ (list/map code.local-tag options)
+ g!_left (code.local-identifier "_left")
+ g!_right (code.local-identifier "_right")
+ g!options+ (list/map (function (_ option)
+ (` (def: (~' #export) (~ (code.local-identifier option))
+ (~ g!type)
+ (|> (~ g!none)
+ (set@ (~ (code.local-tag option)) #1)))))
+ options)]
+ (wrap (list& (` (type: (~' #export) (~ g!type)
+ (~ (code.record (list/map (function (_ tag)
+ [tag (` .Bit)])
+ g!tags+)))))
+
+ (` (def: (~' #export) (~ g!none)
+ (~ g!type)
+ (~ (code.record (list/map (function (_ tag)
+ [tag (` #0)])
+ g!tags+)))))
+
+ (` (def: (~' #export) ((~ (code.local-identifier ++)) (~ 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+))))
+
+(config: Class-Config noneC ++C [finalC])
+(config: Method-Config noneM ++M [finalM staticM synchronizedM strictM])
+(config: Field-Config noneF ++F [finalF staticF transientF volatileF])
+
+(def: #export new-label
+ (-> Any Label)
+ (function (_ _)
+ (org/objectweb/asm/Label::new)))
+
+(def: #export (simple-class name)
+ (-> Text (Type Class))
+ (type.class name (list)))
diff --git a/lux-jvm/source/luxc/lang/host/jvm/def.lux b/lux-jvm/source/luxc/lang/host/jvm/def.lux
new file mode 100644
index 000000000..f274da61f
--- /dev/null
+++ b/lux-jvm/source/luxc/lang/host/jvm/def.lux
@@ -0,0 +1,298 @@
+(.module:
+ [lux (#- Type)
+ ["." host (#+ import: do-to)]
+ [control
+ ["." function]]
+ [data
+ ["." product]
+ [number
+ ["i" int]]
+ ["." text
+ ["%" format (#+ format)]]
+ [collection
+ ["." array (#+ Array)]
+ ["." list ("#@." functor)]]]
+ [target
+ [jvm
+ [encoding
+ ["." name]]
+ ["." type (#+ Type Constraint)
+ [category (#+ Class Value Method)]
+ ["." signature]
+ ["." 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)
+
+(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)
+ )
+
+(import: org/objectweb/asm/FieldVisitor
+ (visitEnd [] void))
+
+(import: org/objectweb/asm/MethodVisitor
+ (visitCode [] void)
+ (visitMaxs [int int] void)
+ (visitEnd [] void))
+
+(import: org/objectweb/asm/ClassWriter
+ (#static COMPUTE_MAXS int)
+ (#static COMPUTE_FRAMES int)
+ (new [int])
+ (visit [int int String String String [String]] void)
+ (visitEnd [] void)
+ (visitField [int String String String Object] FieldVisitor)
+ (visitMethod [int String String String [String]] MethodVisitor)
+ (toByteArray [] [byte]))
+
+(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: (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: param-signature
+ (-> (Type Class) Text)
+ (|>> ..signature (format ":")))
+
+(def: (formal-param [name super interfaces])
+ (-> Constraint Text)
+ (format name
+ (param-signature super)
+ (|> interfaces
+ (list@map param-signature)
+ (text.join-with ""))))
+
+(def: (constraints-signature constraints super interfaces)
+ (-> (List Constraint) (Type Class) (List (Type Class))
+ Text)
+ (let [formal-params (if (list.empty? constraints)
+ ""
+ (format "<"
+ (|> constraints
+ (list@map formal-param)
+ (text.join-with ""))
+ ">"))]
+ (format formal-params
+ (..signature super)
+ (|> interfaces
+ (list@map ..signature)
+ (text.join-with "")))))
+
+(def: class-computes
+ Int
+ ($_ i.+
+ (ClassWriter::COMPUTE_MAXS)
+ ## (ClassWriter::COMPUTE_FRAMES)
+ ))
+
+(def: binary-name (|>> name.internal name.read))
+
+(template [<name> <flag>]
+ [(def: #export (<name> version visibility config name constraints super interfaces
+ definitions)
+ (-> //.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)
+ ($_ i.+
+ (Opcodes::ACC_SUPER)
+ <flag>
+ (visibility-flag visibility)
+ (class-flags config))
+ (..binary-name name)
+ (constraints-signature constraints super interfaces)
+ (..class-name super)
+ (|> interfaces
+ (list@map ..class-name)
+ string-array)))
+ definitions)
+ _ (ClassWriter::visitEnd writer)]
+ (ClassWriter::toByteArray writer)))]
+
+ [class +0]
+ [abstract (Opcodes::ACC_ABSTRACT)]
+ )
+
+(def: $Object
+ (Type Class)
+ (type.class "java.lang.Object" (list)))
+
+(def: #export (interface version visibility config name constraints interfaces
+ definitions)
+ (-> //.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)
+ ($_ i.+
+ (Opcodes::ACC_SUPER)
+ (Opcodes::ACC_INTERFACE)
+ (visibility-flag visibility)
+ (class-flags config))
+ (..binary-name name)
+ (constraints-signature constraints $Object interfaces)
+ (..class-name $Object)
+ (|> interfaces
+ (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 (Type Method) //.Inst
+ //.Def)
+ (function (_ writer)
+ (let [=method (ClassWriter::visitMethod ($_ i.+
+ (visibility-flag visibility)
+ (method-flags config))
+ (..binary-name name)
+ (..descriptor type)
+ (..signature type)
+ (string-array (list))
+ 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 (Type Method)
+ //.Def)
+ (function (_ writer)
+ (let [=method (ClassWriter::visitMethod ($_ i.+
+ (visibility-flag visibility)
+ (method-flags config)
+ (Opcodes::ACC_ABSTRACT))
+ (..binary-name name)
+ (..descriptor type)
+ (..signature type)
+ (string-array (list))
+ writer)
+ _ (MethodVisitor::visitEnd =method)]
+ writer)))
+
+(def: #export (field visibility config name type)
+ (-> //.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 type)
+ (..signature type)
+ (host.null)
+ writer)
+ (FieldVisitor::visitEnd))]
+ writer)))
+
+(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))
+ (..binary-name name)
+ (..descriptor <jvm-type>)
+ (..signature <jvm-type>)
+ (<prepare> value)
+ writer)
+ (FieldVisitor::visitEnd))]
+ writer)))]
+
+ [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)
+ (-> (List //.Def) //.Def)
+ (case defs
+ #.Nil
+ function.identity
+
+ (#.Cons singleton #.Nil)
+ singleton
+
+ (#.Cons head tail)
+ (function.compose (fuse tail) head)))
diff --git a/lux-jvm/source/luxc/lang/host/jvm/inst.lux b/lux-jvm/source/luxc/lang/host/jvm/inst.lux
new file mode 100644
index 000000000..b673c7d7e
--- /dev/null
+++ b/lux-jvm/source/luxc/lang/host/jvm/inst.lux
@@ -0,0 +1,464 @@
+(.module:
+ [lux (#- Type int char)
+ ["." host (#+ import: do-to)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." function]
+ ["." try]
+ ["p" parser
+ ["s" code]]]
+ [data
+ ["." product]
+ ["." maybe]
+ [number
+ ["n" nat]
+ ["i" int]]
+ [collection
+ ["." list ("#@." functor)]]]
+ [macro
+ ["." code]
+ ["." template]
+ [syntax (#+ syntax:)]]
+ [target
+ [jvm
+ [encoding
+ ["." name (#+ External)]]
+ ["." type (#+ Type) ("#@." equivalence)
+ [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)]
+ ["." box]
+ ["." 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)
+
+(syntax: (declare {codes (p.many s.local-identifier)})
+ (|> codes
+ (list@map (function (_ code) (` ((~' #static) (~ (code.local-identifier code)) (~' int)))))
+ wrap))
+
+(`` (import: #long 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_ICMPNE IF_ICMPGE IF_ICMPLE
+ IF_ACMPEQ IF_ACMPNE IFNULL IFNONNULL
+ IFEQ IFNE IFLT IFLE IFGT IFGE
+ GOTO))
+
+ (~~ (declare BIPUSH SIPUSH))
+ (~~ (declare ICONST_M1 ICONST_0 ICONST_1 ICONST_2 ICONST_3 ICONST_4 ICONST_5
+ LCONST_0 LCONST_1
+ FCONST_0 FCONST_1 FCONST_2
+ DCONST_0 DCONST_1))
+ (#static ACONST_NULL int)
+
+ ## Var
+ (~~ (declare IINC
+ ILOAD LLOAD FLOAD DLOAD ALOAD
+ ISTORE LSTORE FSTORE DSTORE ASTORE))
+
+ ## Arithmetic
+ (~~ (declare IADD ISUB IMUL IDIV IREM INEG
+ LADD LSUB LMUL LDIV LREM LNEG LCMP
+ FADD FSUB FMUL FDIV FREM FNEG FCMPG FCMPL
+ DADD DSUB DMUL DDIV DREM DNEG 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 FRETURN DRETURN ARETURN))
+ ))
+
+(import: #long org/objectweb/asm/Label
+ (new []))
+
+(import: #long org/objectweb/asm/MethodVisitor
+ (visitCode [] void)
+ (visitMaxs [int int] void)
+ (visitEnd [] void)
+ (visitInsn [int] void)
+ (visitLdcInsn [java/lang/Object] void)
+ (visitFieldInsn [int java/lang/String java/lang/String java/lang/String] void)
+ (visitTypeInsn [int java/lang/String] void)
+ (visitVarInsn [int int] void)
+ (visitIntInsn [int int] void)
+ (visitMethodInsn [int java/lang/String java/lang/String java/lang/String boolean] void)
+ (visitLabel [org/objectweb/asm/Label] void)
+ (visitJumpInsn [int org/objectweb/asm/Label] void)
+ (visitTryCatchBlock [org/objectweb/asm/Label org/objectweb/asm/Label org/objectweb/asm/Label java/lang/String] void)
+ (visitLookupSwitchInsn [org/objectweb/asm/Label [int] [org/objectweb/asm/Label]] void)
+ (visitTableSwitchInsn [int int org/objectweb/asm/Label [org/objectweb/asm/Label]] void)
+ )
+
+## [Insts]
+(def: #export make-label
+ (All [s] (Operation s org/objectweb/asm/Label))
+ (function (_ state)
+ (#try.Success [state (org/objectweb/asm/Label::new)])))
+
+(def: #export (with-label action)
+ (All [a] (-> (-> org/objectweb/asm/Label a) a))
+ (action (org/objectweb/asm/Label::new)))
+
+(template [<name> <type> <prepare>]
+ [(def: #export (<name> value)
+ (-> <type> Inst)
+ (function (_ visitor)
+ (do-to visitor
+ (org/objectweb/asm/MethodVisitor::visitLdcInsn (<prepare> value)))))]
+
+ [boolean Bit function.identity]
+ [int Int host.long-to-int]
+ [long Int function.identity]
+ [double Frac function.identity]
+ [char Nat (|>> .int host.long-to-int host.int-to-char)]
+ [string Text function.identity]
+ )
+
+(template: (!prefix short)
+ (`` ((~~ (template.identifier ["org/objectweb/asm/Opcodes::" short])))))
+
+(template [<constant>]
+ [(def: #export <constant>
+ Inst
+ (function (_ visitor)
+ (do-to visitor
+ (org/objectweb/asm/MethodVisitor::visitInsn (!prefix <constant>)))))]
+
+ [ICONST_M1] [ICONST_0] [ICONST_1] [ICONST_2] [ICONST_3] [ICONST_4] [ICONST_5]
+ [LCONST_0] [LCONST_1]
+ [FCONST_0] [FCONST_1] [FCONST_2]
+ [DCONST_0] [DCONST_1]
+ )
+
+(def: #export NULL
+ Inst
+ (function (_ visitor)
+ (do-to visitor
+ (org/objectweb/asm/MethodVisitor::visitInsn (!prefix ACONST_NULL)))))
+
+(template [<constant>]
+ [(def: #export (<constant> constant)
+ (-> Int Inst)
+ (function (_ visitor)
+ (do-to visitor
+ (org/objectweb/asm/MethodVisitor::visitIntInsn (!prefix <constant>) constant))))]
+
+ [BIPUSH]
+ [SIPUSH]
+ )
+
+(template [<name>]
+ [(def: #export <name>
+ Inst
+ (function (_ visitor)
+ (do-to visitor
+ (org/objectweb/asm/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] [INEG]
+
+ ## Integer bitwise
+ [IAND] [IOR] [IXOR] [ISHL] [ISHR] [IUSHR]
+
+ ## Long arithmetic
+ [LADD] [LSUB] [LMUL] [LDIV] [LREM] [LNEG]
+ [LCMP]
+
+ ## Long bitwise
+ [LAND] [LOR] [LXOR] [LSHL] [LSHR] [LUSHR]
+
+ ## Float arithmetic
+ [FADD] [FSUB] [FMUL] [FDIV] [FREM] [FNEG] [FCMPG] [FCMPL]
+
+ ## Double arithmetic
+ [DADD] [DSUB] [DMUL] [DDIV] [DREM] [DNEG]
+ [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] [FRETURN] [DRETURN] [ARETURN]
+ )
+
+(type: #export Register Nat)
+
+(template [<name>]
+ [(def: #export (<name> register)
+ (-> Register Inst)
+ (function (_ visitor)
+ (do-to visitor
+ (org/objectweb/asm/MethodVisitor::visitVarInsn (!prefix <name>) (.int register)))))]
+
+ [IINC]
+ [ILOAD] [LLOAD] [FLOAD] [DLOAD] [ALOAD]
+ [ISTORE] [LSTORE] [FSTORE] [DSTORE] [ASTORE]
+ )
+
+(template [<name> <inst>]
+ [(def: #export (<name> class field type)
+ (-> (Type Class) Text (Type Value) Inst)
+ (function (_ visitor)
+ (do-to visitor
+ (org/objectweb/asm/MethodVisitor::visitFieldInsn (<inst>) (..class-name class) field (..descriptor type)))))]
+
+ [GETSTATIC org/objectweb/asm/Opcodes::GETSTATIC]
+ [PUTSTATIC org/objectweb/asm/Opcodes::PUTSTATIC]
+
+ [PUTFIELD org/objectweb/asm/Opcodes::PUTFIELD]
+ [GETFIELD org/objectweb/asm/Opcodes::GETFIELD]
+ )
+
+(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]]]
+
+ [Class
+ [[NEW org/objectweb/asm/Opcodes::NEW]
+ [INSTANCEOF org/objectweb/asm/Opcodes::INSTANCEOF]]]
+ )
+
+(def: #export (NEWARRAY type)
+ (-> (Type Primitive) Inst)
+ (function (_ visitor)
+ (do-to visitor
+ (org/objectweb/asm/MethodVisitor::visitIntInsn (org/objectweb/asm/Opcodes::NEWARRAY)
+ (`` (cond (~~ (template [<descriptor> <opcode>]
+ [(type@= <descriptor> type) (<opcode>)]
+
+ [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> <interface?>]
+ [(def: #export (<name> class method-name method)
+ (-> (Type Class) Text (Type Method) Inst)
+ (function (_ visitor)
+ (do-to visitor
+ (org/objectweb/asm/MethodVisitor::visitMethodInsn (<inst>)
+ (..class-name class)
+ method-name
+ (|> method type.descriptor descriptor.descriptor)
+ <interface?>))))]
+
+ [INVOKESTATIC org/objectweb/asm/Opcodes::INVOKESTATIC false]
+ [INVOKEVIRTUAL org/objectweb/asm/Opcodes::INVOKEVIRTUAL false]
+ [INVOKESPECIAL org/objectweb/asm/Opcodes::INVOKESPECIAL false]
+ [INVOKEINTERFACE org/objectweb/asm/Opcodes::INVOKEINTERFACE true]
+ )
+
+(template [<name>]
+ [(def: #export (<name> @where)
+ (-> //.Label Inst)
+ (function (_ visitor)
+ (do-to visitor
+ (org/objectweb/asm/MethodVisitor::visitJumpInsn (!prefix <name>) @where))))]
+
+ [IF_ICMPEQ] [IF_ICMPGT] [IF_ICMPLT]
+ [IF_ICMPNE] [IF_ICMPGE] [IF_ICMPLE]
+ [IF_ACMPEQ] [IF_ACMPNE] [IFNULL] [IFNONNULL]
+ [IFEQ] [IFNE] [IFLT] [IFLE] [IFGT] [IFGE]
+ [GOTO]
+ )
+
+(def: #export (LOOKUPSWITCH default keys+labels)
+ (-> //.Label (List [Int //.Label]) Inst)
+ (function (_ visitor)
+ (let [keys+labels (list.sort (function (_ left right)
+ (i.< (product.left left) (product.left right)))
+ keys+labels)
+ array-size (list.size keys+labels)
+ keys-array (host.array int array-size)
+ labels-array (host.array org/objectweb/asm/Label array-size)
+ _ (loop [idx 0]
+ (if (n.< array-size idx)
+ (let [[key label] (maybe.assume (list.nth idx keys+labels))]
+ (exec
+ (host.array-write idx (host.long-to-int key) keys-array)
+ (host.array-write idx label labels-array)
+ (recur (inc idx))))
+ []))]
+ (do-to visitor
+ (org/objectweb/asm/MethodVisitor::visitLookupSwitchInsn default keys-array labels-array)))))
+
+(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 org/objectweb/asm/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 (inc idx)))
+ []))]
+ (do-to visitor
+ (org/objectweb/asm/MethodVisitor::visitTableSwitchInsn min max default labels-array)))))
+
+(def: #export (try @from @to @handler exception)
+ (-> //.Label //.Label //.Label (Type Class) Inst)
+ (function (_ visitor)
+ (do-to visitor
+ (org/objectweb/asm/MethodVisitor::visitTryCatchBlock @from @to @handler (..class-name exception)))))
+
+(def: #export (label @label)
+ (-> //.Label Inst)
+ (function (_ visitor)
+ (do-to visitor
+ (org/objectweb/asm/MethodVisitor::visitLabel @label))))
+
+(def: #export (array elementT)
+ (-> (Type Value) Inst)
+ (case (type.primitive? elementT)
+ (#.Left elementT)
+ (ANEWARRAY elementT)
+
+ (#.Right elementT)
+ (NEWARRAY elementT)))
+
+(template [<name> <boolean> <byte> <short> <int> <long> <float> <double> <char>]
+ [(def: (<name> type)
+ (-> (Type Primitive) Text)
+ (`` (cond (~~ (template [<descriptor> <output>]
+ [(type@= <descriptor> type) <output>]
+
+ [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))))]
+
+ [primitive-wrapper
+ box.boolean box.byte box.short box.int
+ box.long box.float box.double box.char]
+ [primitive-unwrap
+ "booleanValue" "byteValue" "shortValue" "intValue"
+ "longValue" "floatValue" "doubleValue" "charValue"]
+ )
+
+(def: #export (wrap type)
+ (-> (Type Primitive) Inst)
+ (let [wrapper (type.class (primitive-wrapper type) (list))]
+ (INVOKESTATIC wrapper "valueOf" (type.method [(list type) wrapper (list)]))))
+
+(def: #export (unwrap type)
+ (-> (Type Primitive) Inst)
+ (let [wrapper (type.class (primitive-wrapper type) (list))]
+ (|>> (CHECKCAST wrapper)
+ (INVOKEVIRTUAL wrapper (primitive-unwrap type) (type.method [(list) type (list)])))))
+
+(def: #export (fuse insts)
+ (-> (List Inst) Inst)
+ (case insts
+ #.Nil
+ function.identity
+
+ (#.Cons singleton #.Nil)
+ singleton
+
+ (#.Cons head tail)
+ (function.compose (fuse tail) head)))
diff --git a/lux-jvm/source/luxc/lang/synthesis/variable.lux b/lux-jvm/source/luxc/lang/synthesis/variable.lux
new file mode 100644
index 000000000..f6a45b02e
--- /dev/null
+++ b/lux-jvm/source/luxc/lang/synthesis/variable.lux
@@ -0,0 +1,98 @@
+(.module:
+ lux
+ (lux (data [number]
+ (coll [list "list/" Fold<List> Monoid<List>]
+ ["s" set])))
+ (luxc (lang ["la" analysis]
+ ["ls" synthesis]
+ [".L" variable #+ Variable])))
+
+(def: (bound-vars path)
+ (-> ls.Path (List Variable))
+ (case path
+ (#ls.BindP register)
+ (list (.int register))
+
+ (^or (#ls.SeqP pre post) (#ls.AltP pre post))
+ (list/compose (bound-vars pre) (bound-vars post))
+
+ _
+ (list)))
+
+(def: (path-bodies path)
+ (-> ls.Path (List ls.Synthesis))
+ (case path
+ (#ls.ExecP body)
+ (list body)
+
+ (#ls.SeqP pre post)
+ (path-bodies post)
+
+ (#ls.AltP pre post)
+ (list/compose (path-bodies pre) (path-bodies post))
+
+ _
+ (list)))
+
+(def: (non-arg? arity var)
+ (-> ls.Arity Variable Bit)
+ (and (variableL.local? var)
+ (n/> arity (.nat var))))
+
+(type: Tracker (s.Set Variable))
+
+(def: init-tracker Tracker (s.new number.Hash<Int>))
+
+(def: (unused-vars current-arity bound exprS)
+ (-> ls.Arity (List Variable) ls.Synthesis (List Variable))
+ (let [tracker (loop [exprS exprS
+ tracker (list/fold s.add init-tracker bound)]
+ (case exprS
+ (#ls.Variable var)
+ (if (non-arg? current-arity var)
+ (s.remove var tracker)
+ tracker)
+
+ (#ls.Variant tag last? memberS)
+ (recur memberS tracker)
+
+ (#ls.Tuple membersS)
+ (list/fold recur tracker membersS)
+
+ (#ls.Call funcS argsS)
+ (list/fold recur (recur funcS tracker) argsS)
+
+ (^or (#ls.Recur argsS)
+ (#ls.Procedure name argsS))
+ (list/fold recur tracker argsS)
+
+ (#ls.Let offset inputS outputS)
+ (|> tracker (recur inputS) (recur outputS))
+
+ (#ls.If testS thenS elseS)
+ (|> tracker (recur testS) (recur thenS) (recur elseS))
+
+ (#ls.Loop offset initsS bodyS)
+ (recur bodyS (list/fold recur tracker initsS))
+
+ (#ls.Case inputS outputPS)
+ (let [tracker' (list/fold s.add
+ (recur inputS tracker)
+ (bound-vars outputPS))]
+ (list/fold recur tracker' (path-bodies outputPS)))
+
+ (#ls.Function arity env bodyS)
+ (list/fold s.remove tracker env)
+
+ _
+ tracker
+ ))]
+ (s.to-list tracker)))
+
+## (def: (optimize-register-use current-arity [pathS bodyS])
+## (-> ls.Arity [ls.Path ls.Synthesis] [ls.Path ls.Synthesis])
+## (let [bound (bound-vars pathS)
+## unused (unused-vars current-arity bound bodyS)
+## adjusted (adjust-vars unused bound)]
+## [(|> pathS (clean-pattern adjusted) simplify-pattern)
+## (clean-expression adjusted bodyS)]))
diff --git a/lux-jvm/source/luxc/lang/translation/jvm.lux b/lux-jvm/source/luxc/lang/translation/jvm.lux
new file mode 100644
index 000000000..141e70184
--- /dev/null
+++ b/lux-jvm/source/luxc/lang/translation/jvm.lux
@@ -0,0 +1,182 @@
+(.module:
+ [lux (#- Module Definition)
+ ["." host (#+ import: do-to object)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ pipe
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["." io (#+ IO io)]
+ [concurrency
+ ["." atom (#+ Atom atom)]]]
+ [data
+ [binary (#+ Binary)]
+ ["." product]
+ ["." text ("#@." hash)
+ ["%" format (#+ format)]]
+ [collection
+ ["." array]
+ ["." dictionary (#+ Dictionary)]]]
+ [target
+ [jvm
+ ["." loader (#+ Library)]
+ ["." type
+ ["." descriptor]]]]
+ [tool
+ [compiler
+ [language
+ [lux
+ ["." generation]]]
+ ["." meta
+ [io (#+ lux-context)]
+ [archive
+ [descriptor (#+ Module)]
+ ["." artifact]]]]]]
+ [///
+ [host
+ ["." jvm (#+ Inst Definition Host State)
+ ["." def]
+ ["." inst]]]]
+ )
+
+(import: #long java/lang/reflect/Field
+ (get [#? java/lang/Object] #try #? java/lang/Object))
+
+(import: #long (java/lang/Class a)
+ (getField [java/lang/String] #try java/lang/reflect/Field))
+
+(import: #long java/lang/Object
+ (getClass [] (java/lang/Class java/lang/Object)))
+
+(import: #long java/lang/ClassLoader)
+
+(type: #export ByteCode Binary)
+
+(def: #export value-field Text "_value")
+(def: #export $Value (type.class "java.lang.Object" (list)))
+
+(exception: #export (cannot-load {class Text} {error Text})
+ (exception.report
+ ["Class" class]
+ ["Error" error]))
+
+(exception: #export (invalid-field {class Text} {field Text} {error Text})
+ (exception.report
+ ["Class" class]
+ ["Field" field]
+ ["Error" error]))
+
+(exception: #export (invalid-value {class Text})
+ (exception.report
+ ["Class" class]))
+
+(def: (class-value class-name class)
+ (-> Text (java/lang/Class java/lang/Object) (Try Any))
+ (case (java/lang/Class::getField ..value-field class)
+ (#try.Success field)
+ (case (java/lang/reflect/Field::get #.None field)
+ (#try.Success ?value)
+ (case ?value
+ (#.Some value)
+ (#try.Success value)
+
+ #.None
+ (exception.throw ..invalid-value class-name))
+
+ (#try.Failure error)
+ (exception.throw ..cannot-load [class-name error]))
+
+ (#try.Failure error)
+ (exception.throw ..invalid-field [class-name ..value-field error])))
+
+(def: class-path-separator ".")
+
+(def: #export bytecode-name
+ (-> Text Text)
+ (text.replace-all ..class-path-separator .module-separator))
+
+(def: #export (class-name [module-id artifact-id])
+ (-> generation.Context Text)
+ (format lux-context
+ ..class-path-separator (%.nat meta.version)
+ ..class-path-separator (%.nat module-id)
+ ..class-path-separator (%.nat artifact-id)))
+
+(def: (evaluate! library loader eval-class valueI)
+ (-> Library java/lang/ClassLoader Text Inst (Try [Any Definition]))
+ (let [bytecode-name (..bytecode-name eval-class)
+ bytecode (def.class #jvm.V1_6
+ #jvm.Public jvm.noneC
+ bytecode-name
+ (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>"
+ (type.method [(list) type.void (list)])
+ (|>> valueI
+ (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)
+ class (loader.load eval-class loader)
+ value (:: io.monad wrap (..class-value eval-class class))]
+ (wrap [value
+ [eval-class bytecode]])))))
+
+(def: (execute! library loader temp-label [class-name class-bytecode])
+ (-> Library java/lang/ClassLoader Text Definition (Try Any))
+ (io.run (do (try.with io.monad)
+ [existing-class? (|> (atom.read library)
+ (:: io.monad map (dictionary.contains? class-name))
+ (try.lift io.monad)
+ (: (IO (Try Bit))))
+ _ (if existing-class?
+ (wrap [])
+ (loader.store class-name class-bytecode library))]
+ (loader.load class-name loader))))
+
+(def: (define! library loader context valueI)
+ (-> Library java/lang/ClassLoader generation.Context Inst (Try [Text Any Definition]))
+ (let [class-name (..class-name context)]
+ (do try.monad
+ [[value definition] (evaluate! library loader class-name valueI)]
+ (wrap [class-name value definition]))))
+
+(def: #export host
+ (IO Host)
+ (io (let [library (loader.new-library [])
+ loader (loader.memory library)]
+ (: Host
+ (structure
+ (def: (evaluate! temp-label valueI)
+ (:: try.monad map product.left
+ (..evaluate! library loader (text.replace-all " " "$" temp-label) valueI)))
+
+ (def: execute!
+ (..execute! library loader))
+
+ (def: define!
+ (..define! library loader))
+
+ (def: (ingest context bytecode)
+ [(..class-name context) bytecode])
+
+ (def: (re-learn context [_ bytecode])
+ (io.run
+ (loader.store (..class-name context) bytecode library)))
+
+ (def: (re-load context [_ bytecode])
+ (io.run
+ (do (try.with io.monad)
+ [#let [class-name (..class-name context)]
+ _ (loader.store class-name bytecode library)
+ class (loader.load class-name loader)]
+ (:: io.monad wrap (..class-value class-name class))))))))))
+
+(def: #export $Variant (type.array ..$Value))
+(def: #export $Tuple (type.array ..$Value))
+(def: #export $Runtime (type.class (..class-name [0 0]) (list)))
+(def: #export $Function (type.class (..class-name [0 1]) (list)))
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/case.lux b/lux-jvm/source/luxc/lang/translation/jvm/case.lux
new file mode 100644
index 000000000..0d8aaa91e
--- /dev/null
+++ b/lux-jvm/source/luxc/lang/translation/jvm/case.lux
@@ -0,0 +1,239 @@
+(.module:
+ [lux (#- Type if let case)
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." function]
+ ["ex" exception (#+ exception:)]]
+ [data
+ [number
+ ["n" nat]]]
+ [target
+ [jvm
+ ["." type (#+ Type)
+ ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)]
+ ["." descriptor (#+ Descriptor)]
+ ["." signature (#+ Signature)]]]]
+ [tool
+ [compiler
+ ["." phase ("operation@." monad)]
+ [meta
+ [archive (#+ Archive)]]
+ [language
+ [lux
+ ["." synthesis (#+ Path Synthesis)]]]]]]
+ [luxc
+ [lang
+ [host
+ ["$" jvm (#+ Label Inst Operation Phase Generator)
+ ["_" inst]]]]]
+ ["." //
+ ["." runtime]])
+
+(def: (pop-altI stack-depth)
+ (-> Nat Inst)
+ (.case stack-depth
+ 0 function.identity
+ 1 _.POP
+ 2 _.POP2
+ _ ## (n.> 2)
+ (|>> _.POP2
+ (pop-altI (n.- 2 stack-depth)))))
+
+(def: peekI
+ Inst
+ (|>> _.DUP
+ (_.int +0)
+ _.AALOAD))
+
+(def: pushI
+ Inst
+ (_.INVOKESTATIC //.$Runtime "pm_push" (type.method [(list runtime.$Stack //.$Value) runtime.$Stack (list)])))
+
+(def: popI
+ (|>> (_.int +1)
+ _.AALOAD
+ (_.CHECKCAST runtime.$Stack)))
+
+(def: (path' stack-depth @else @end phase archive path)
+ (-> Nat Label Label Phase Archive Path (Operation Inst))
+ (.case path
+ #synthesis.Pop
+ (operation@wrap ..popI)
+
+ (#synthesis.Bind register)
+ (operation@wrap (|>> peekI
+ (_.ASTORE register)))
+
+ (^ (synthesis.path/bit value))
+ (operation@wrap (.let [jumpI (.if value _.IFEQ _.IFNE)]
+ (|>> peekI
+ (_.unwrap type.boolean)
+ (jumpI @else))))
+
+ (^ (synthesis.path/i64 value))
+ (operation@wrap (|>> peekI
+ (_.unwrap type.long)
+ (_.long (.int value))
+ _.LCMP
+ (_.IFNE @else)))
+
+ (^ (synthesis.path/f64 value))
+ (operation@wrap (|>> peekI
+ (_.unwrap type.double)
+ (_.double value)
+ _.DCMPL
+ (_.IFNE @else)))
+
+ (^ (synthesis.path/text value))
+ (operation@wrap (|>> peekI
+ (_.string value)
+ (_.INVOKEVIRTUAL (type.class "java.lang.Object" (list))
+ "equals"
+ (type.method [(list //.$Value) type.boolean (list)]))
+ (_.IFEQ @else)))
+
+ (#synthesis.Then bodyS)
+ (do phase.monad
+ [bodyI (phase archive bodyS)]
+ (wrap (|>> (pop-altI stack-depth)
+ bodyI
+ (_.GOTO @end))))
+
+ (^template [<pattern> <flag> <prepare>]
+ (^ (<pattern> idx))
+ (operation@wrap (<| _.with-label (function (_ @success))
+ _.with-label (function (_ @fail))
+ (|>> peekI
+ (_.CHECKCAST //.$Variant)
+ (_.int (.int (<prepare> idx)))
+ <flag>
+ (_.INVOKESTATIC //.$Runtime "pm_variant" (type.method [(list //.$Variant runtime.$Tag runtime.$Flag) runtime.$Value (list)]))
+ _.DUP
+ (_.IFNULL @fail)
+ (_.GOTO @success)
+ (_.label @fail)
+ _.POP
+ (_.GOTO @else)
+ (_.label @success)
+ pushI))))
+ ([synthesis.side/left _.NULL function.identity]
+ [synthesis.side/right (_.string "") .inc])
+
+ (^ (synthesis.member/left lefts))
+ (operation@wrap (.let [accessI (.case lefts
+ 0
+ _.AALOAD
+
+ lefts
+ (_.INVOKESTATIC //.$Runtime "tuple_left" (type.method [(list //.$Tuple runtime.$Index) //.$Value (list)])))]
+ (|>> peekI
+ (_.CHECKCAST //.$Tuple)
+ (_.int (.int lefts))
+ accessI
+ pushI)))
+
+ (^ (synthesis.member/right lefts))
+ (operation@wrap (|>> peekI
+ (_.CHECKCAST //.$Tuple)
+ (_.int (.int lefts))
+ (_.INVOKESTATIC //.$Runtime "tuple_right" (type.method [(list //.$Tuple runtime.$Index) //.$Value (list)]))
+ pushI))
+
+ ## Extra optimization
+ (^ (synthesis.path/seq
+ (synthesis.member/left 0)
+ (synthesis.!bind-top register thenP)))
+ (do phase.monad
+ [then! (path' stack-depth @else @end phase archive thenP)]
+ (wrap (|>> peekI
+ (_.CHECKCAST //.$Tuple)
+ (_.int +0)
+ _.AALOAD
+ (_.ASTORE register)
+ then!)))
+
+ ## Extra optimization
+ (^template [<pm> <getter>]
+ (^ (synthesis.path/seq
+ (<pm> lefts)
+ (synthesis.!bind-top register thenP)))
+ (do phase.monad
+ [then! (path' stack-depth @else @end phase archive thenP)]
+ (wrap (|>> peekI
+ (_.CHECKCAST //.$Tuple)
+ (_.int (.int lefts))
+ (_.INVOKESTATIC //.$Runtime <getter> (type.method [(list //.$Tuple runtime.$Index) //.$Value (list)]))
+ (_.ASTORE register)
+ then!))))
+ ([synthesis.member/left "tuple_left"]
+ [synthesis.member/right "tuple_right"])
+
+ (#synthesis.Alt leftP rightP)
+ (do phase.monad
+ [@alt-else _.make-label
+ leftI (path' (inc stack-depth) @alt-else @end phase archive leftP)
+ rightI (path' stack-depth @else @end phase archive rightP)]
+ (wrap (|>> _.DUP
+ leftI
+ (_.label @alt-else)
+ _.POP
+ rightI)))
+
+ (#synthesis.Seq leftP rightP)
+ (do phase.monad
+ [leftI (path' stack-depth @else @end phase archive leftP)
+ rightI (path' stack-depth @else @end phase archive rightP)]
+ (wrap (|>> leftI
+ rightI)))
+ ))
+
+(def: (path @end phase archive path)
+ (-> Label Phase Archive Path (Operation Inst))
+ (do phase.monad
+ [@else _.make-label
+ pathI (..path' 1 @else @end phase archive path)]
+ (wrap (|>> pathI
+ (_.label @else)
+ _.POP
+ (_.INVOKESTATIC //.$Runtime "pm_fail" (type.method [(list) type.void (list)]))
+ _.NULL
+ (_.GOTO @end)))))
+
+(def: #export (if phase archive [testS thenS elseS])
+ (Generator [Synthesis Synthesis Synthesis])
+ (do phase.monad
+ [testI (phase archive testS)
+ thenI (phase archive thenS)
+ elseI (phase archive elseS)]
+ (wrap (<| _.with-label (function (_ @else))
+ _.with-label (function (_ @end))
+ (|>> testI
+ (_.unwrap type.boolean)
+ (_.IFEQ @else)
+ thenI
+ (_.GOTO @end)
+ (_.label @else)
+ elseI
+ (_.label @end))))))
+
+(def: #export (let phase archive [inputS register exprS])
+ (Generator [Synthesis Nat Synthesis])
+ (do phase.monad
+ [inputI (phase archive inputS)
+ exprI (phase archive exprS)]
+ (wrap (|>> inputI
+ (_.ASTORE register)
+ exprI))))
+
+(def: #export (case phase archive [valueS path])
+ (Generator [Synthesis Path])
+ (do phase.monad
+ [@end _.make-label
+ valueI (phase archive valueS)
+ pathI (..path @end phase archive path)]
+ (wrap (|>> _.NULL
+ valueI
+ pushI
+ pathI
+ (_.label @end)))))
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/common.lux b/lux-jvm/source/luxc/lang/translation/jvm/common.lux
new file mode 100644
index 000000000..6cd7f4f2f
--- /dev/null
+++ b/lux-jvm/source/luxc/lang/translation/jvm/common.lux
@@ -0,0 +1,72 @@
+(.module:
+ [lux #*
+ ## [abstract
+ ## [monad (#+ do)]]
+ ## [control
+ ## ["." try (#+ Try)]
+ ## ["ex" exception (#+ exception:)]
+ ## ["." io]]
+ ## [data
+ ## [binary (#+ Binary)]
+ ## ["." text ("#/." hash)
+ ## format]
+ ## [collection
+ ## ["." dictionary (#+ Dictionary)]]]
+ ## ["." macro]
+ ## [host (#+ import:)]
+ ## [tool
+ ## [compiler
+ ## [reference (#+ Register)]
+ ## ["." name]
+ ## ["." phase]]]
+ ]
+ ## [luxc
+ ## [lang
+ ## [host
+ ## ["." jvm
+ ## [type]]]]]
+ )
+
+## (def: #export (with-artifacts action)
+## (All [a] (-> (Meta a) (Meta [Artifacts a])))
+## (function (_ state)
+## (case (action (update@ #.host
+## (|>> (:coerce Host)
+## (set@ #artifacts (dictionary.new text.hash))
+## (:coerce Nothing))
+## state))
+## (#try.Success [state' output])
+## (#try.Success [(update@ #.host
+## (|>> (:coerce Host)
+## (set@ #artifacts (|> (get@ #.host state) (:coerce Host) (get@ #artifacts)))
+## (:coerce Nothing))
+## state')
+## [(|> state' (get@ #.host) (:coerce Host) (get@ #artifacts))
+## output]])
+
+## (#try.Failure error)
+## (#try.Failure error))))
+
+## (def: #export (load-definition state)
+## (-> Lux (-> Name Binary (Try Any)))
+## (function (_ (^@ def-name [def-module def-name]) def-bytecode)
+## (let [normal-name (format (name.normalize def-name) (%n (text/hash def-name)))
+## class-name (format (text.replace-all "/" "." def-module) "." normal-name)]
+## (<| (macro.run state)
+## (do macro.monad
+## [_ (..store-class class-name def-bytecode)
+## class (..load-class class-name)]
+## (case (do try.monad
+## [field (Class::getField [..value-field] class)]
+## (Field::get [#.None] field))
+## (#try.Success (#.Some def-value))
+## (wrap def-value)
+
+## (#try.Success #.None)
+## (phase.throw invalid-definition-value (%name def-name))
+
+## (#try.Failure error)
+## (phase.throw cannot-load-definition
+## (format "Definition: " (%name def-name) "\n"
+## "Error:\n"
+## error))))))))
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/expression.lux b/lux-jvm/source/luxc/lang/translation/jvm/expression.lux
new file mode 100644
index 000000000..144e35f9b
--- /dev/null
+++ b/lux-jvm/source/luxc/lang/translation/jvm/expression.lux
@@ -0,0 +1,72 @@
+(.module:
+ [lux #*
+ [tool
+ [compiler
+ [language
+ [lux
+ ["." synthesis]
+ [phase
+ ["." extension]]]]]]]
+ [luxc
+ [lang
+ [host
+ [jvm (#+ Phase)]]]]
+ [//
+ ["." common]
+ ["." primitive]
+ ["." structure]
+ ["." reference]
+ ["." case]
+ ["." loop]
+ ["." function]])
+
+(def: #export (translate archive synthesis)
+ Phase
+ (case synthesis
+ (^ (synthesis.bit value))
+ (primitive.bit value)
+
+ (^ (synthesis.i64 value))
+ (primitive.i64 value)
+
+ (^ (synthesis.f64 value))
+ (primitive.f64 value)
+
+ (^ (synthesis.text value))
+ (primitive.text value)
+
+ (^ (synthesis.variant data))
+ (structure.variant translate archive data)
+
+ (^ (synthesis.tuple members))
+ (structure.tuple translate archive members)
+
+ (^ (synthesis.variable variable))
+ (reference.variable archive variable)
+
+ (^ (synthesis.constant constant))
+ (reference.constant archive constant)
+
+ (^ (synthesis.branch/let data))
+ (case.let translate archive data)
+
+ (^ (synthesis.branch/if data))
+ (case.if translate archive data)
+
+ (^ (synthesis.branch/case data))
+ (case.case translate archive data)
+
+ (^ (synthesis.loop/recur data))
+ (loop.recur translate archive data)
+
+ (^ (synthesis.loop/scope data))
+ (loop.scope translate archive data)
+
+ (^ (synthesis.function/apply data))
+ (function.call translate archive data)
+
+ (^ (synthesis.function/abstraction data))
+ (function.function translate archive data)
+
+ (#synthesis.Extension extension)
+ (extension.apply archive translate extension)))
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/extension.lux b/lux-jvm/source/luxc/lang/translation/jvm/extension.lux
new file mode 100644
index 000000000..9066dd156
--- /dev/null
+++ b/lux-jvm/source/luxc/lang/translation/jvm/extension.lux
@@ -0,0 +1,16 @@
+(.module:
+ [lux #*
+ [data
+ [collection
+ ["." dictionary]]]]
+ [////
+ [host
+ [jvm (#+ Bundle)]]]
+ ["." / #_
+ ["#." common]
+ ["#." host]])
+
+(def: #export bundle
+ Bundle
+ (dictionary.merge /common.bundle
+ /host.bundle))
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux b/lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux
new file mode 100644
index 000000000..383415c0a
--- /dev/null
+++ b/lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux
@@ -0,0 +1,388 @@
+(.module:
+ [lux (#- Type)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try]
+ ["<>" parser
+ ["<s>" synthesis (#+ Parser)]]]
+ [data
+ ["." product]
+ [number
+ ["f" frac]]
+ [collection
+ ["." list ("#@." monad)]
+ ["." dictionary]]]
+ [target
+ [jvm
+ ["." type]]]
+ [tool
+ [compiler
+ ["." phase]
+ [meta
+ [archive (#+ Archive)]]
+ [language
+ [lux
+ ["." synthesis (#+ Synthesis %synthesis)]
+ [phase
+ [generation
+ [extension (#+ Nullary Unary Binary Trinary Variadic
+ nullary unary binary trinary variadic)]]
+ ["." extension
+ ["." bundle]]]]]]]
+ [host (#+ import:)]]
+ [luxc
+ [lang
+ [host
+ ["$" jvm (#+ Label Inst Def Handler Bundle Operation Phase)
+ ["_" inst]]]]]
+ ["." ///
+ ["." runtime]])
+
+(def: #export (custom [parser handler])
+ (All [s]
+ (-> [(Parser s)
+ (-> Text Phase Archive s (Operation Inst))]
+ Handler))
+ (function (_ extension-name phase archive input)
+ (case (<s>.run parser input)
+ (#try.Success input')
+ (handler extension-name phase archive input')
+
+ (#try.Failure error)
+ (phase.throw extension.invalid-syntax [extension-name %synthesis input]))))
+
+(import: java/lang/Double
+ (#static MIN_VALUE Double)
+ (#static MAX_VALUE Double))
+
+(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 type.long)))
+(def: jvm-intI Inst (|>> (_.unwrap type.long) _.L2I))
+(def: check-stringI Inst (_.CHECKCAST $String))
+
+(def: (predicateI tester)
+ (-> (-> Label Inst)
+ Inst)
+ (let [$Boolean (type.class "java.lang.Boolean" (list))]
+ (<| _.with-label (function (_ @then))
+ _.with-label (function (_ @end))
+ (|>> (tester @then)
+ (_.GETSTATIC $Boolean "FALSE" $Boolean)
+ (_.GOTO @end)
+ (_.label @then)
+ (_.GETSTATIC $Boolean "TRUE" $Boolean)
+ (_.label @end)
+ ))))
+
+(def: unitI Inst (_.string synthesis.unit))
+
+## TODO: Get rid of this ASAP
+(def: lux::syntax-char-case!
+ (..custom [($_ <>.and
+ <s>.any
+ <s>.any
+ (<>.some (<s>.tuple ($_ <>.and
+ (<s>.tuple (<>.many <s>.i64))
+ <s>.any))))
+ (function (_ extension-name phase archive [input else conditionals])
+ (<| _.with-label (function (_ @end))
+ _.with-label (function (_ @else))
+ (do {@ phase.monad}
+ [inputG (phase archive input)
+ elseG (phase archive else)
+ conditionalsG+ (: (Operation (List [(List [Int Label])
+ Inst]))
+ (monad.map @ (function (_ [chars branch])
+ (do @
+ [branchG (phase archive branch)]
+ (wrap (<| _.with-label (function (_ @branch))
+ [(list@map (function (_ char)
+ [(.int char) @branch])
+ chars)
+ (|>> (_.label @branch)
+ branchG
+ (_.GOTO @end))]))))
+ conditionals))
+ #let [table (|> conditionalsG+
+ (list@map product.left)
+ list@join)
+ conditionalsG (|> conditionalsG+
+ (list@map product.right)
+ _.fuse)]]
+ (wrap (|>> inputG (_.unwrap type.long) _.L2I
+ (_.LOOKUPSWITCH @else table)
+ conditionalsG
+ (_.label @else)
+ elseG
+ (_.label @end)
+ )))))]))
+
+(def: (lux::is [referenceI sampleI])
+ (Binary Inst)
+ (|>> referenceI
+ sampleI
+ (predicateI _.IF_ACMPEQ)))
+
+(def: (lux::try riskyI)
+ (Unary Inst)
+ (|>> riskyI
+ (_.CHECKCAST ///.$Function)
+ (_.INVOKESTATIC ///.$Runtime "try" runtime.try)))
+
+(template [<name> <op>]
+ [(def: (<name> [maskI inputI])
+ (Binary Inst)
+ (|>> inputI (_.unwrap type.long)
+ maskI (_.unwrap type.long)
+ <op> (_.wrap type.long)))]
+
+ [i64::and _.LAND]
+ [i64::or _.LOR]
+ [i64::xor _.LXOR]
+ )
+
+(template [<name> <op>]
+ [(def: (<name> [shiftI inputI])
+ (Binary Inst)
+ (|>> inputI (_.unwrap type.long)
+ shiftI jvm-intI
+ <op>
+ (_.wrap type.long)))]
+
+ [i64::left-shift _.LSHL]
+ [i64::arithmetic-right-shift _.LSHR]
+ [i64::logical-right-shift _.LUSHR]
+ )
+
+(template [<name> <const> <type>]
+ [(def: (<name> _)
+ (Nullary Inst)
+ (|>> <const> (_.wrap <type>)))]
+
+ [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>]
+ [(def: (<name> [paramI subjectI])
+ (Binary Inst)
+ (|>> subjectI (_.unwrap <type>)
+ paramI (_.unwrap <type>)
+ <op>
+ (_.wrap <type>)))]
+
+ [i64::+ type.long _.LADD]
+ [i64::- type.long _.LSUB]
+ [i64::* type.long _.LMUL]
+ [i64::/ type.long _.LDIV]
+ [i64::% type.long _.LREM]
+
+ [f64::+ type.double _.DADD]
+ [f64::- type.double _.DSUB]
+ [f64::* type.double _.DMUL]
+ [f64::/ type.double _.DDIV]
+ [f64::% type.double _.DREM]
+ )
+
+(template [<eq> <lt> <type> <cmp>]
+ [(template [<name> <reference>]
+ [(def: (<name> [paramI subjectI])
+ (Binary Inst)
+ (|>> subjectI (_.unwrap <type>)
+ paramI (_.unwrap <type>)
+ <cmp>
+ (_.int <reference>)
+ (predicateI _.IF_ICMPEQ)))]
+
+ [<eq> +0]
+ [<lt> -1])]
+
+ [i64::= i64::< type.long _.LCMP]
+ [f64::= f64::< type.double _.DCMPG]
+ )
+
+(template [<name> <prepare> <transform>]
+ [(def: (<name> inputI)
+ (Unary Inst)
+ (|>> inputI <prepare> <transform>))]
+
+ [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)]))))]
+
+ [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)]))]
+ [f64::decode ..check-stringI
+ (_.INVOKESTATIC ///.$Runtime "decode_frac" (type.method [(list $String) ///.$Variant (list)]))]
+ )
+
+(def: (text::size inputI)
+ (Unary Inst)
+ (|>> inputI
+ ..check-stringI
+ (_.INVOKEVIRTUAL $String "length" (type.method [(list) type.int (list)]))
+ lux-intI))
+
+(template [<name> <pre-subject> <pre-param> <op> <post>]
+ [(def: (<name> [paramI subjectI])
+ (Binary Inst)
+ (|>> subjectI <pre-subject>
+ paramI <pre-param>
+ <op> <post>))]
+
+ [text::= (<|) (<|)
+ (_.INVOKEVIRTUAL $Object "equals" (type.method [(list $Object) type.boolean (list)]))
+ (_.wrap type.boolean)]
+ [text::< ..check-stringI ..check-stringI
+ (_.INVOKEVIRTUAL $String "compareTo" (type.method [(list $String) type.int (list)]))
+ (predicateI _.IFLT)]
+ [text::char ..check-stringI jvm-intI
+ (_.INVOKEVIRTUAL $String "charAt" (type.method [(list type.int) type.char (list)]))
+ lux-intI]
+ )
+
+(def: (text::concat [leftI rightI])
+ (Binary Inst)
+ (|>> leftI ..check-stringI
+ rightI ..check-stringI
+ (_.INVOKEVIRTUAL $String "concat" (type.method [(list $String) $String (list)]))))
+
+(def: (text::clip [startI endI subjectI])
+ (Trinary Inst)
+ (|>> subjectI ..check-stringI
+ startI jvm-intI
+ endI jvm-intI
+ (_.INVOKEVIRTUAL $String "substring" (type.method [(list type.int type.int) $String (list)]))))
+
+(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))
+ _.with-label (function (_ @end))
+ (|>> textI ..check-stringI
+ partI ..check-stringI
+ startI jvm-intI
+ (_.INVOKEVIRTUAL $String "indexOf" index-method)
+ _.DUP
+ (_.int -1)
+ (_.IF_ICMPEQ @not-found)
+ lux-intI
+ runtime.someI
+ (_.GOTO @end)
+ (_.label @not-found)
+ _.POP
+ runtime.noneI
+ (_.label @end))))
+
+(def: string-method (type.method [(list $String) type.void (list)]))
+(def: (io::log messageI)
+ (Unary Inst)
+ (let [$PrintStream (type.class "java.io.PrintStream" (list))]
+ (|>> (_.GETSTATIC $System "out" $PrintStream)
+ messageI
+ ..check-stringI
+ (_.INVOKEVIRTUAL $PrintStream "println" string-method)
+ unitI)))
+
+(def: (io::error messageI)
+ (Unary Inst)
+ (let [$Error (type.class "java.lang.Error" (list))]
+ (|>> (_.NEW $Error)
+ _.DUP
+ messageI
+ ..check-stringI
+ (_.INVOKESPECIAL $Error "<init>" string-method)
+ _.ATHROW)))
+
+(def: (io::exit codeI)
+ (Unary Inst)
+ (|>> codeI jvm-intI
+ (_.INVOKESTATIC $System "exit" (type.method [(list type.int) type.void (list)]))
+ _.NULL))
+
+(def: (io::current-time _)
+ (Nullary Inst)
+ (|>> (_.INVOKESTATIC $System "currentTimeMillis" (type.method [(list) type.long (list)]))
+ (_.wrap type.long)))
+
+(def: bundle::lux
+ Bundle
+ (|> (: Bundle bundle.empty)
+ (bundle.install "syntax char case!" lux::syntax-char-case!)
+ (bundle.install "is" (binary lux::is))
+ (bundle.install "try" (unary lux::try))))
+
+(def: bundle::i64
+ Bundle
+ (<| (bundle.prefix "i64")
+ (|> (: Bundle bundle.empty)
+ (bundle.install "and" (binary i64::and))
+ (bundle.install "or" (binary i64::or))
+ (bundle.install "xor" (binary i64::xor))
+ (bundle.install "left-shift" (binary i64::left-shift))
+ (bundle.install "logical-right-shift" (binary i64::logical-right-shift))
+ (bundle.install "arithmetic-right-shift" (binary i64::arithmetic-right-shift))
+ (bundle.install "=" (binary i64::=))
+ (bundle.install "<" (binary i64::<))
+ (bundle.install "+" (binary i64::+))
+ (bundle.install "-" (binary i64::-))
+ (bundle.install "*" (binary i64::*))
+ (bundle.install "/" (binary i64::/))
+ (bundle.install "%" (binary i64::%))
+ (bundle.install "f64" (unary i64::f64))
+ (bundle.install "char" (unary i64::char)))))
+
+(def: bundle::f64
+ Bundle
+ (<| (bundle.prefix "f64")
+ (|> (: Bundle bundle.empty)
+ (bundle.install "+" (binary f64::+))
+ (bundle.install "-" (binary f64::-))
+ (bundle.install "*" (binary f64::*))
+ (bundle.install "/" (binary f64::/))
+ (bundle.install "%" (binary f64::%))
+ (bundle.install "=" (binary f64::=))
+ (bundle.install "<" (binary f64::<))
+ (bundle.install "smallest" (nullary f64::smallest))
+ (bundle.install "min" (nullary f64::min))
+ (bundle.install "max" (nullary f64::max))
+ (bundle.install "i64" (unary f64::i64))
+ (bundle.install "encode" (unary f64::encode))
+ (bundle.install "decode" (unary f64::decode)))))
+
+(def: bundle::text
+ Bundle
+ (<| (bundle.prefix "text")
+ (|> (: Bundle bundle.empty)
+ (bundle.install "=" (binary text::=))
+ (bundle.install "<" (binary text::<))
+ (bundle.install "concat" (binary text::concat))
+ (bundle.install "index" (trinary text::index))
+ (bundle.install "size" (unary text::size))
+ (bundle.install "char" (binary text::char))
+ (bundle.install "clip" (trinary text::clip)))))
+
+(def: bundle::io
+ Bundle
+ (<| (bundle.prefix "io")
+ (|> (: Bundle bundle.empty)
+ (bundle.install "log" (unary io::log))
+ (bundle.install "error" (unary io::error))
+ (bundle.install "exit" (unary io::exit))
+ (bundle.install "current-time" (nullary io::current-time)))))
+
+(def: #export bundle
+ Bundle
+ (<| (bundle.prefix "lux")
+ (|> bundle::lux
+ (dictionary.merge bundle::i64)
+ (dictionary.merge bundle::f64)
+ (dictionary.merge bundle::text)
+ (dictionary.merge bundle::io))))
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux
new file mode 100644
index 000000000..7b90a8e4f
--- /dev/null
+++ b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux
@@ -0,0 +1,1047 @@
+(.module:
+ [lux (#- Type primitive int char type)
+ [host (#+ import:)]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." exception (#+ exception:)]
+ ["." function]
+ ["<>" parser ("#@." monad)
+ ["<t>" text]
+ ["<s>" synthesis (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." maybe]
+ ["." text ("#@." equivalence)
+ ["%" format (#+ format)]]
+ [number
+ ["." nat]]
+ [collection
+ ["." list ("#@." monad)]
+ ["." dictionary (#+ Dictionary)]
+ ["." set]]]
+ [target
+ [jvm
+ ["." type (#+ Type Typed Argument)
+ ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)]
+ ["." box]
+ ["." reflection]
+ ["." signature]
+ ["." parser]]]]
+ [tool
+ [compiler
+ ["." reference (#+ Variable)]
+ ["." phase ("#@." monad)]
+ [meta
+ [archive (#+ Archive)]]
+ [language
+ [lux
+ [analysis (#+ Environment)]
+ ["." synthesis (#+ Synthesis Path %synthesis)]
+ ["." generation]
+ [phase
+ [generation
+ [extension (#+ Nullary Unary Binary
+ nullary unary binary)]]
+ [analysis
+ [".A" reference]]
+ ["." extension
+ ["." bundle]
+ [analysis
+ ["/" jvm]]]]]]]]]
+ [luxc
+ [lang
+ [host
+ ["$" jvm (#+ Label Inst Def Handler Bundle Operation Phase)
+ ["_" inst]
+ ["_." def]]]]]
+ ["." // #_
+ [common (#+ custom)]
+ ["/#" //
+ ["#." reference]
+ ["#." function]]])
+
+(template [<name> <category> <parser>]
+ [(def: #export <name>
+ (Parser (Type <category>))
+ (<t>.embed <parser> <s>.text))]
+
+ [var Var parser.var]
+ [class Class parser.class]
+ [object Object parser.object]
+ [value Value parser.value]
+ [return Return parser.return]
+ )
+
+(exception: #export (not-an-object-array {arrayJT (Type Array)})
+ (exception.report
+ ["JVM Type" (|> arrayJT type.signature signature.signature)]))
+
+(def: #export object-array
+ (Parser (Type Object))
+ (do <>.monad
+ [arrayJT (<t>.embed parser.array <s>.text)]
+ (case (parser.array? arrayJT)
+ (#.Some elementJT)
+ (case (parser.object? elementJT)
+ (#.Some elementJT)
+ (wrap elementJT)
+
+ #.None
+ (<>.fail (exception.construct ..not-an-object-array arrayJT)))
+
+ #.None
+ (undefined))))
+
+(template [<name> <inst>]
+ [(def: <name>
+ Inst
+ <inst>)]
+
+ [L2S (|>> _.L2I _.I2S)]
+ [L2B (|>> _.L2I _.I2B)]
+ [L2C (|>> _.L2I _.I2C)]
+ )
+
+(template [<conversion> <name>]
+ [(def: (<name> inputI)
+ (Unary Inst)
+ (if (is? _.NOP <conversion>)
+ inputI
+ (|>> inputI
+ <conversion>)))]
+
+ [_.D2F conversion::double-to-float]
+ [_.D2I conversion::double-to-int]
+ [_.D2L conversion::double-to-long]
+ [_.F2D conversion::float-to-double]
+ [_.F2I conversion::float-to-int]
+ [_.F2L conversion::float-to-long]
+ [_.I2B conversion::int-to-byte]
+ [_.I2C conversion::int-to-char]
+ [_.I2D conversion::int-to-double]
+ [_.I2F conversion::int-to-float]
+ [_.I2L conversion::int-to-long]
+ [_.I2S conversion::int-to-short]
+ [_.L2D conversion::long-to-double]
+ [_.L2F conversion::long-to-float]
+ [_.L2I conversion::long-to-int]
+ [..L2S conversion::long-to-short]
+ [..L2B conversion::long-to-byte]
+ [..L2C conversion::long-to-char]
+ [_.I2B conversion::char-to-byte]
+ [_.I2S conversion::char-to-short]
+ [_.NOP conversion::char-to-int]
+ [_.I2L conversion::char-to-long]
+ [_.I2L conversion::byte-to-long]
+ [_.I2L conversion::short-to-long]
+ )
+
+(def: conversion
+ Bundle
+ (<| (bundle.prefix "conversion")
+ (|> (: Bundle bundle.empty)
+ (bundle.install "double-to-float" (unary conversion::double-to-float))
+ (bundle.install "double-to-int" (unary conversion::double-to-int))
+ (bundle.install "double-to-long" (unary conversion::double-to-long))
+ (bundle.install "float-to-double" (unary conversion::float-to-double))
+ (bundle.install "float-to-int" (unary conversion::float-to-int))
+ (bundle.install "float-to-long" (unary conversion::float-to-long))
+ (bundle.install "int-to-byte" (unary conversion::int-to-byte))
+ (bundle.install "int-to-char" (unary conversion::int-to-char))
+ (bundle.install "int-to-double" (unary conversion::int-to-double))
+ (bundle.install "int-to-float" (unary conversion::int-to-float))
+ (bundle.install "int-to-long" (unary conversion::int-to-long))
+ (bundle.install "int-to-short" (unary conversion::int-to-short))
+ (bundle.install "long-to-double" (unary conversion::long-to-double))
+ (bundle.install "long-to-float" (unary conversion::long-to-float))
+ (bundle.install "long-to-int" (unary conversion::long-to-int))
+ (bundle.install "long-to-short" (unary conversion::long-to-short))
+ (bundle.install "long-to-byte" (unary conversion::long-to-byte))
+ (bundle.install "long-to-char" (unary conversion::long-to-char))
+ (bundle.install "char-to-byte" (unary conversion::char-to-byte))
+ (bundle.install "char-to-short" (unary conversion::char-to-short))
+ (bundle.install "char-to-int" (unary conversion::char-to-int))
+ (bundle.install "char-to-long" (unary conversion::char-to-long))
+ (bundle.install "byte-to-long" (unary conversion::byte-to-long))
+ (bundle.install "short-to-long" (unary conversion::short-to-long))
+ )))
+
+(template [<name> <op>]
+ [(def: (<name> [xI yI])
+ (Binary Inst)
+ (|>> xI
+ yI
+ <op>))]
+
+ [int::+ _.IADD]
+ [int::- _.ISUB]
+ [int::* _.IMUL]
+ [int::/ _.IDIV]
+ [int::% _.IREM]
+ [int::and _.IAND]
+ [int::or _.IOR]
+ [int::xor _.IXOR]
+ [int::shl _.ISHL]
+ [int::shr _.ISHR]
+ [int::ushr _.IUSHR]
+
+ [long::+ _.LADD]
+ [long::- _.LSUB]
+ [long::* _.LMUL]
+ [long::/ _.LDIV]
+ [long::% _.LREM]
+ [long::and _.LAND]
+ [long::or _.LOR]
+ [long::xor _.LXOR]
+ [long::shl _.LSHL]
+ [long::shr _.LSHR]
+ [long::ushr _.LUSHR]
+
+ [float::+ _.FADD]
+ [float::- _.FSUB]
+ [float::* _.FMUL]
+ [float::/ _.FDIV]
+ [float::% _.FREM]
+
+ [double::+ _.DADD]
+ [double::- _.DSUB]
+ [double::* _.DMUL]
+ [double::/ _.DDIV]
+ [double::% _.DREM]
+ )
+
+(def: $Boolean (type.class box.boolean (list)))
+(def: falseI (_.GETSTATIC $Boolean "FALSE" $Boolean))
+(def: trueI (_.GETSTATIC $Boolean "TRUE" $Boolean))
+
+(template [<name> <op>]
+ [(def: (<name> [xI yI])
+ (Binary Inst)
+ (<| _.with-label (function (_ @then))
+ _.with-label (function (_ @end))
+ (|>> xI
+ yI
+ (<op> @then)
+ falseI
+ (_.GOTO @end)
+ (_.label @then)
+ trueI
+ (_.label @end))))]
+
+ [int::= _.IF_ICMPEQ]
+ [int::< _.IF_ICMPLT]
+
+ [char::= _.IF_ICMPEQ]
+ [char::< _.IF_ICMPLT]
+ )
+
+(template [<name> <op> <reference>]
+ [(def: (<name> [xI yI])
+ (Binary Inst)
+ (<| _.with-label (function (_ @then))
+ _.with-label (function (_ @end))
+ (|>> xI
+ yI
+ <op>
+ (_.int <reference>)
+ (_.IF_ICMPEQ @then)
+ falseI
+ (_.GOTO @end)
+ (_.label @then)
+ trueI
+ (_.label @end))))]
+
+ [long::= _.LCMP +0]
+ [long::< _.LCMP -1]
+
+ [float::= _.FCMPG +0]
+ [float::< _.FCMPG -1]
+
+ [double::= _.DCMPG +0]
+ [double::< _.DCMPG -1]
+ )
+
+(def: int
+ Bundle
+ (<| (bundle.prefix (reflection.reflection reflection.int))
+ (|> (: Bundle bundle.empty)
+ (bundle.install "+" (binary int::+))
+ (bundle.install "-" (binary int::-))
+ (bundle.install "*" (binary int::*))
+ (bundle.install "/" (binary int::/))
+ (bundle.install "%" (binary int::%))
+ (bundle.install "=" (binary int::=))
+ (bundle.install "<" (binary int::<))
+ (bundle.install "and" (binary int::and))
+ (bundle.install "or" (binary int::or))
+ (bundle.install "xor" (binary int::xor))
+ (bundle.install "shl" (binary int::shl))
+ (bundle.install "shr" (binary int::shr))
+ (bundle.install "ushr" (binary int::ushr))
+ )))
+
+(def: long
+ Bundle
+ (<| (bundle.prefix (reflection.reflection reflection.long))
+ (|> (: Bundle bundle.empty)
+ (bundle.install "+" (binary long::+))
+ (bundle.install "-" (binary long::-))
+ (bundle.install "*" (binary long::*))
+ (bundle.install "/" (binary long::/))
+ (bundle.install "%" (binary long::%))
+ (bundle.install "=" (binary long::=))
+ (bundle.install "<" (binary long::<))
+ (bundle.install "and" (binary long::and))
+ (bundle.install "or" (binary long::or))
+ (bundle.install "xor" (binary long::xor))
+ (bundle.install "shl" (binary long::shl))
+ (bundle.install "shr" (binary long::shr))
+ (bundle.install "ushr" (binary long::ushr))
+ )))
+
+(def: float
+ Bundle
+ (<| (bundle.prefix (reflection.reflection reflection.float))
+ (|> (: Bundle bundle.empty)
+ (bundle.install "+" (binary float::+))
+ (bundle.install "-" (binary float::-))
+ (bundle.install "*" (binary float::*))
+ (bundle.install "/" (binary float::/))
+ (bundle.install "%" (binary float::%))
+ (bundle.install "=" (binary float::=))
+ (bundle.install "<" (binary float::<))
+ )))
+
+(def: double
+ Bundle
+ (<| (bundle.prefix (reflection.reflection reflection.double))
+ (|> (: Bundle bundle.empty)
+ (bundle.install "+" (binary double::+))
+ (bundle.install "-" (binary double::-))
+ (bundle.install "*" (binary double::*))
+ (bundle.install "/" (binary double::/))
+ (bundle.install "%" (binary double::%))
+ (bundle.install "=" (binary double::=))
+ (bundle.install "<" (binary double::<))
+ )))
+
+(def: char
+ Bundle
+ (<| (bundle.prefix (reflection.reflection reflection.char))
+ (|> (: Bundle bundle.empty)
+ (bundle.install "=" (binary char::=))
+ (bundle.install "<" (binary char::<))
+ )))
+
+(def: (primitive-array-length-handler jvm-primitive)
+ (-> (Type Primitive) Handler)
+ (..custom
+ [<s>.any
+ (function (_ extension-name generate archive arrayS)
+ (do phase.monad
+ [arrayI (generate archive arrayS)]
+ (wrap (|>> arrayI
+ (_.CHECKCAST (type.array jvm-primitive))
+ _.ARRAYLENGTH))))]))
+
+(def: array::length::object
+ Handler
+ (..custom
+ [($_ <>.and ..object-array <s>.any)
+ (function (_ extension-name generate archive [elementJT arrayS])
+ (do phase.monad
+ [arrayI (generate archive arrayS)]
+ (wrap (|>> arrayI
+ (_.CHECKCAST (type.array elementJT))
+ _.ARRAYLENGTH))))]))
+
+(def: (new-primitive-array-handler jvm-primitive)
+ (-> (Type Primitive) Handler)
+ (function (_ extension-name generate archive inputs)
+ (case inputs
+ (^ (list lengthS))
+ (do phase.monad
+ [lengthI (generate archive lengthS)]
+ (wrap (|>> lengthI
+ (_.array jvm-primitive))))
+
+ _
+ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))))
+
+(def: array::new::object
+ Handler
+ (..custom
+ [($_ <>.and ..object <s>.any)
+ (function (_ extension-name generate archive [objectJT lengthS])
+ (do phase.monad
+ [lengthI (generate archive lengthS)]
+ (wrap (|>> lengthI
+ (_.ANEWARRAY objectJT)))))]))
+
+(def: (read-primitive-array-handler jvm-primitive loadI)
+ (-> (Type Primitive) Inst Handler)
+ (function (_ extension-name generate archive inputs)
+ (case inputs
+ (^ (list idxS arrayS))
+ (do phase.monad
+ [arrayI (generate archive arrayS)
+ idxI (generate archive idxS)]
+ (wrap (|>> arrayI
+ (_.CHECKCAST (type.array jvm-primitive))
+ idxI
+ loadI)))
+
+ _
+ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))))
+
+(def: array::read::object
+ Handler
+ (..custom
+ [($_ <>.and ..object-array <s>.any <s>.any)
+ (function (_ extension-name generate archive [elementJT idxS arrayS])
+ (do phase.monad
+ [arrayI (generate archive arrayS)
+ idxI (generate archive idxS)]
+ (wrap (|>> arrayI
+ (_.CHECKCAST (type.array elementJT))
+ idxI
+ _.AALOAD))))]))
+
+(def: (write-primitive-array-handler jvm-primitive storeI)
+ (-> (Type Primitive) Inst Handler)
+ (function (_ extension-name generate archive inputs)
+ (case inputs
+ (^ (list idxS valueS arrayS))
+ (do phase.monad
+ [arrayI (generate archive arrayS)
+ idxI (generate archive idxS)
+ valueI (generate archive valueS)]
+ (wrap (|>> arrayI
+ (_.CHECKCAST (type.array jvm-primitive))
+ _.DUP
+ idxI
+ valueI
+ storeI)))
+
+ _
+ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))))
+
+(def: array::write::object
+ Handler
+ (..custom
+ [($_ <>.and ..object-array <s>.any <s>.any <s>.any)
+ (function (_ extension-name generate archive [elementJT idxS valueS arrayS])
+ (do phase.monad
+ [arrayI (generate archive arrayS)
+ idxI (generate archive idxS)
+ valueI (generate archive valueS)]
+ (wrap (|>> arrayI
+ (_.CHECKCAST (type.array elementJT))
+ _.DUP
+ idxI
+ valueI
+ _.AASTORE))))]))
+
+(def: array
+ Bundle
+ (<| (bundle.prefix "array")
+ (|> bundle.empty
+ (dictionary.merge (<| (bundle.prefix "length")
+ (|> bundle.empty
+ (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.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.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.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))))
+ )))
+
+(def: (object::null _)
+ (Nullary Inst)
+ _.NULL)
+
+(def: (object::null? objectI)
+ (Unary Inst)
+ (<| _.with-label (function (_ @then))
+ _.with-label (function (_ @end))
+ (|>> objectI
+ (_.IFNULL @then)
+ falseI
+ (_.GOTO @end)
+ (_.label @then)
+ trueI
+ (_.label @end))))
+
+(def: (object::synchronized [monitorI exprI])
+ (Binary Inst)
+ (|>> monitorI
+ _.DUP
+ _.MONITORENTER
+ exprI
+ _.SWAP
+ _.MONITOREXIT))
+
+(def: (object::throw exceptionI)
+ (Unary Inst)
+ (|>> exceptionI
+ _.ATHROW))
+
+(def: $Class (type.class "java.lang.Class" (list)))
+
+(def: (object::class extension-name generate archive inputs)
+ Handler
+ (case inputs
+ (^ (list (synthesis.text class)))
+ (do phase.monad
+ []
+ (wrap (|>> (_.string class)
+ (_.INVOKESTATIC $Class "forName" (type.method [(list (type.class "java.lang.String" (list))) $Class (list)])))))
+
+ _
+ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))
+
+(def: object::instance?
+ Handler
+ (..custom
+ [($_ <>.and <s>.text <s>.any)
+ (function (_ extension-name generate archive [class objectS])
+ (do phase.monad
+ [objectI (generate archive objectS)]
+ (wrap (|>> objectI
+ (_.INSTANCEOF (type.class class (list)))
+ (_.wrap type.boolean)))))]))
+
+(def: (object::cast extension-name generate archive inputs)
+ Handler
+ (case inputs
+ (^ (list (synthesis.text from) (synthesis.text to) valueS))
+ (do phase.monad
+ [valueI (generate archive valueS)]
+ (`` (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])))
+
+(def: object-bundle
+ Bundle
+ (<| (bundle.prefix "object")
+ (|> (: Bundle bundle.empty)
+ (bundle.install "null" (nullary object::null))
+ (bundle.install "null?" (unary object::null?))
+ (bundle.install "synchronized" (binary object::synchronized))
+ (bundle.install "throw" (unary object::throw))
+ (bundle.install "class" object::class)
+ (bundle.install "instance?" object::instance?)
+ (bundle.install "cast" object::cast)
+ )))
+
+(def: primitives
+ (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: get::static
+ Handler
+ (..custom
+ [($_ <>.and <s>.text <s>.text <s>.text)
+ (function (_ extension-name generate archive [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: put::static
+ Handler
+ (..custom
+ [($_ <>.and <s>.text <s>.text <s>.text <s>.any)
+ (function (_ extension-name generate archive [class field unboxed valueS])
+ (do phase.monad
+ [valueI (generate archive 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: get::virtual
+ Handler
+ (..custom
+ [($_ <>.and <s>.text <s>.text <s>.text <s>.any)
+ (function (_ extension-name generate archive [class field unboxed objectS])
+ (do phase.monad
+ [objectI (generate archive 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: put::virtual
+ Handler
+ (..custom
+ [($_ <>.and <s>.text <s>.text <s>.text <s>.any <s>.any)
+ (function (_ extension-name generate archive [class field unboxed valueS objectS])
+ (do phase.monad
+ [valueI (generate archive valueS)
+ objectI (generate archive 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))))]))
+
+(type: Input (Typed Synthesis))
+
+(def: input
+ (Parser Input)
+ (<s>.tuple (<>.and ..value <s>.any)))
+
+(def: (generate-input generate archive [valueT valueS])
+ (-> Phase Archive Input
+ (Operation (Typed Inst)))
+ (do phase.monad
+ [valueI (generate archive 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 ..class <s>.text ..return (<>.some ..input))
+ (function (_ extension-name generate archive [class method outputT inputsTS])
+ (do {@ phase.monad}
+ [inputsTI (monad.map @ (generate-input generate archive) inputsTS)]
+ (wrap (|>> (_.fuse (list@map product.right inputsTI))
+ (_.INVOKESTATIC class method (type.method [(list@map product.left inputsTI) outputT (list)]))
+ (prepare-output outputT)))))]))
+
+(template [<name> <invoke>]
+ [(def: <name>
+ Handler
+ (..custom
+ [($_ <>.and ..class <s>.text ..return <s>.any (<>.some ..input))
+ (function (_ extension-name generate archive [class method outputT objectS inputsTS])
+ (do {@ phase.monad}
+ [objectI (generate archive objectS)
+ inputsTI (monad.map @ (generate-input generate archive) inputsTS)]
+ (wrap (|>> objectI
+ (_.CHECKCAST class)
+ (_.fuse (list@map product.right inputsTI))
+ (<invoke> class method
+ (type.method [(list@map product.left inputsTI)
+ outputT
+ (list)]))
+ (prepare-output outputT)))))]))]
+
+ [invoke::virtual _.INVOKEVIRTUAL]
+ [invoke::special _.INVOKESPECIAL]
+ [invoke::interface _.INVOKEINTERFACE]
+ )
+
+(def: invoke::constructor
+ Handler
+ (..custom
+ [($_ <>.and ..class (<>.some ..input))
+ (function (_ extension-name generate archive [class inputsTS])
+ (do {@ phase.monad}
+ [inputsTI (monad.map @ (generate-input generate archive) inputsTS)]
+ (wrap (|>> (_.NEW class)
+ _.DUP
+ (_.fuse (list@map product.right inputsTI))
+ (_.INVOKESPECIAL class "<init>" (type.method [(list@map product.left inputsTI) type.void (list)]))))))]))
+
+(def: member
+ Bundle
+ (<| (bundle.prefix "member")
+ (|> (: Bundle bundle.empty)
+ (dictionary.merge (<| (bundle.prefix "get")
+ (|> (: Bundle bundle.empty)
+ (bundle.install "static" get::static)
+ (bundle.install "virtual" get::virtual))))
+ (dictionary.merge (<| (bundle.prefix "put")
+ (|> (: Bundle bundle.empty)
+ (bundle.install "static" put::static)
+ (bundle.install "virtual" put::virtual))))
+ (dictionary.merge (<| (bundle.prefix "invoke")
+ (|> (: Bundle bundle.empty)
+ (bundle.install "static" invoke::static)
+ (bundle.install "virtual" invoke::virtual)
+ (bundle.install "special" invoke::special)
+ (bundle.install "interface" invoke::interface)
+ (bundle.install "constructor" invoke::constructor))))
+ )))
+
+(def: annotation-parameter
+ (Parser (/.Annotation-Parameter Synthesis))
+ (<s>.tuple (<>.and <s>.text <s>.any)))
+
+(def: annotation
+ (Parser (/.Annotation Synthesis))
+ (<s>.tuple (<>.and <s>.text (<>.some ..annotation-parameter))))
+
+(def: argument
+ (Parser Argument)
+ (<s>.tuple (<>.and <s>.text ..value)))
+
+(def: overriden-method-definition
+ (Parser [Environment (/.Overriden-Method Synthesis)])
+ (<s>.tuple (do <>.monad
+ [_ (<s>.text! /.overriden-tag)
+ ownerT ..class
+ name <s>.text
+ strict-fp? <s>.bit
+ annotations (<s>.tuple (<>.some ..annotation))
+ vars (<s>.tuple (<>.some ..var))
+ self-name <s>.text
+ arguments (<s>.tuple (<>.some ..argument))
+ returnT ..return
+ exceptionsT (<s>.tuple (<>.some ..class))
+ [environment body] (<s>.function 1
+ (<s>.tuple <s>.any))]
+ (wrap [environment
+ [ownerT name
+ strict-fp? annotations vars
+ self-name arguments returnT exceptionsT
+ body]]))))
+
+(def: (normalize-path normalize)
+ (-> (-> Synthesis Synthesis)
+ (-> Path Path))
+ (function (recur path)
+ (case path
+ (^ (synthesis.path/then bodyS))
+ (synthesis.path/then (normalize bodyS))
+
+ (^template [<tag>]
+ (^ (<tag> leftP rightP))
+ (<tag> (recur leftP) (recur rightP)))
+ ([#synthesis.Alt]
+ [#synthesis.Seq])
+
+ (^template [<tag>]
+ (^ (<tag> value))
+ path)
+ ([#synthesis.Pop]
+ [#synthesis.Test]
+ [#synthesis.Bind]
+ [#synthesis.Access]))))
+
+(def: (normalize-method-body mapping)
+ (-> (Dictionary Variable Variable) Synthesis Synthesis)
+ (function (recur body)
+ (case body
+ (^template [<tag>]
+ (^ (<tag> value))
+ body)
+ ([#synthesis.Primitive]
+ [synthesis.constant])
+
+ (^ (synthesis.variant [lefts right? sub]))
+ (synthesis.variant [lefts right? (recur sub)])
+
+ (^ (synthesis.tuple members))
+ (synthesis.tuple (list@map recur members))
+
+ (^ (synthesis.variable var))
+ (|> mapping
+ (dictionary.get var)
+ (maybe.default var)
+ synthesis.variable)
+
+ (^ (synthesis.branch/case [inputS pathS]))
+ (synthesis.branch/case [(recur inputS) (normalize-path recur pathS)])
+
+ (^ (synthesis.branch/let [inputS register outputS]))
+ (synthesis.branch/let [(recur inputS) register (recur outputS)])
+
+ (^ (synthesis.branch/if [testS thenS elseS]))
+ (synthesis.branch/if [(recur testS) (recur thenS) (recur elseS)])
+
+ (^ (synthesis.loop/scope [offset initsS+ bodyS]))
+ (synthesis.loop/scope [offset (list@map recur initsS+) (recur bodyS)])
+
+ (^ (synthesis.loop/recur updatesS+))
+ (synthesis.loop/recur (list@map recur updatesS+))
+
+ (^ (synthesis.function/abstraction [environment arity bodyS]))
+ (synthesis.function/abstraction [(|> environment (list@map (function (_ local)
+ (|> mapping
+ (dictionary.get local)
+ (maybe.default local)))))
+ arity
+ bodyS])
+
+ (^ (synthesis.function/apply [functionS inputsS+]))
+ (synthesis.function/apply [(recur functionS) (list@map recur inputsS+)])
+
+ (#synthesis.Extension [name inputsS+])
+ (#synthesis.Extension [name (list@map recur inputsS+)]))))
+
+(def: $Object (type.class "java.lang.Object" (list)))
+
+(def: (anonymous-init-method env)
+ (-> Environment (Type Method))
+ (type.method [(list.repeat (list.size env) $Object)
+ type.void
+ (list)]))
+
+(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
+ (list@map (.function (_ register)
+ (|>> (_.ALOAD 0)
+ (_.ALOAD (inc register))
+ (_.PUTFIELD class (///reference.foreign-name register) $Object))))
+ _.fuse)]
+ (_def.method #$.Public $.noneM "<init>" (anonymous-init-method env)
+ (|>> (_.ALOAD 0)
+ ((_.fuse (list@map product.right inputsTI)))
+ (_.INVOKESPECIAL super-class "<init>" (type.method [(list@map product.left inputsTI) type.void (list)]))
+ store-capturedI
+ _.RETURN))))
+
+(def: (anonymous-instance archive class env)
+ (-> Archive (Type Class) Environment (Operation Inst))
+ (do {@ phase.monad}
+ [captureI+ (monad.map @ (///reference.variable archive) env)]
+ (wrap (|>> (_.NEW class)
+ _.DUP
+ (_.fuse captureI+)
+ (_.INVOKESPECIAL class "<init>" (anonymous-init-method env))))))
+
+(def: (returnI returnT)
+ (-> (Type Return) Inst)
+ (case (type.void? returnT)
+ (#.Right returnT)
+ _.RETURN
+
+ (#.Left returnT)
+ (case (type.primitive? returnT)
+ (#.Left returnT)
+ (|>> (_.CHECKCAST 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
+ [($_ <>.and
+ ..class
+ (<s>.tuple (<>.some ..class))
+ (<s>.tuple (<>.some ..input))
+ (<s>.tuple (<>.some ..overriden-method-definition)))
+ (function (_ extension-name generate archive [super-class super-interfaces
+ inputsTS
+ overriden-methods])
+ (do {@ phase.monad}
+ [[context _] (generation.with-new-context archive (wrap []))
+ #let [[module-id artifact-id] context
+ anonymous-class-name (///.class-name context)
+ class (type.class anonymous-class-name (list))
+ total-environment (|> overriden-methods
+ ## Get all the environments.
+ (list@map product.left)
+ ## Combine them.
+ list@join
+ ## Remove duplicates.
+ (set.from-list reference.hash)
+ set.to-list)
+ global-mapping (|> total-environment
+ ## Give them names as "foreign" variables.
+ list.enumerate
+ (list@map (function (_ [id capture])
+ [capture (#reference.Foreign id)]))
+ (dictionary.from-list reference.hash))
+ normalized-methods (list@map (function (_ [environment
+ [ownerT name
+ strict-fp? annotations vars
+ self-name arguments returnT exceptionsT
+ body]])
+ (let [local-mapping (|> environment
+ list.enumerate
+ (list@map (function (_ [foreign-id capture])
+ [(#reference.Foreign foreign-id)
+ (|> global-mapping
+ (dictionary.get capture)
+ maybe.assume)]))
+ (dictionary.from-list reference.hash))]
+ [ownerT name
+ strict-fp? annotations vars
+ self-name arguments returnT exceptionsT
+ (normalize-method-body local-mapping body)]))
+ overriden-methods)]
+ inputsTI (monad.map @ (generate-input generate archive) inputsTS)
+ method-definitions (|> normalized-methods
+ (monad.map @ (function (_ [ownerT name
+ strict-fp? annotations vars
+ self-name arguments returnT exceptionsT
+ bodyS])
+ (do @
+ [bodyG (generation.with-context artifact-id
+ (generate archive bodyS))]
+ (wrap (_def.method #$.Public
+ (if strict-fp?
+ ($_ $.++M $.finalM $.strictM)
+ $.finalM)
+ name
+ (type.method [(list@map product.right arguments)
+ returnT
+ exceptionsT])
+ (|>> bodyG (returnI returnT)))))))
+ (:: @ map _def.fuse))
+ _ (generation.save! true ["" (%.nat artifact-id)]
+ [anonymous-class-name
+ (_def.class #$.V1_6 #$.Public $.finalC
+ anonymous-class-name (list)
+ super-class super-interfaces
+ (|>> (///function.with-environment total-environment)
+ (..with-anonymous-init class total-environment super-class inputsTI)
+ method-definitions))])]
+ (anonymous-instance archive class total-environment)))]))
+
+(def: bundle::class
+ Bundle
+ (<| (bundle.prefix "class")
+ (|> (: Bundle bundle.empty)
+ (bundle.install "anonymous" class::anonymous)
+ )))
+
+(def: #export bundle
+ Bundle
+ (<| (bundle.prefix "jvm")
+ (|> ..conversion
+ (dictionary.merge ..int)
+ (dictionary.merge ..long)
+ (dictionary.merge ..float)
+ (dictionary.merge ..double)
+ (dictionary.merge ..char)
+ (dictionary.merge ..array)
+ (dictionary.merge ..object-bundle)
+ (dictionary.merge ..member)
+ (dictionary.merge ..bundle::class)
+ )))
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/function.lux b/lux-jvm/source/luxc/lang/translation/jvm/function.lux
new file mode 100644
index 000000000..888ad9545
--- /dev/null
+++ b/lux-jvm/source/luxc/lang/translation/jvm/function.lux
@@ -0,0 +1,331 @@
+(.module:
+ [lux (#- Type function)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ [pipe (#+ when> new>)]
+ ["." function]]
+ [data
+ ["." product]
+ [text
+ ["%" format (#+ format)]]
+ [number
+ ["n" nat]
+ ["i" int]]
+ [collection
+ ["." list ("#@." functor monoid)]]]
+ [target
+ [jvm
+ ["." type (#+ Type)
+ ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)]]]]
+ [tool
+ [compiler
+ [arity (#+ Arity)]
+ [reference (#+ Register)]
+ ["." phase]
+ [language
+ [lux
+ [analysis (#+ Environment)]
+ [synthesis (#+ Synthesis Abstraction Apply)]
+ ["." generation]]]
+ [meta
+ [archive (#+ Archive)]]]]]
+ [luxc
+ [lang
+ [host
+ ["$" jvm (#+ Label Inst Def Operation Phase Generator)
+ ["." def]
+ ["_" inst]]]]]
+ ["." //
+ ["#." runtime]
+ ["." reference]])
+
+(def: arity-field Text "arity")
+
+(def: (poly-arg? arity)
+ (-> Arity Bit)
+ (n.> 1 arity))
+
+(def: (captured-args env)
+ (-> Environment (List (Type Value)))
+ (list.repeat (list.size env) //.$Value))
+
+(def: (init-method env arity)
+ (-> Environment Arity (Type Method))
+ (if (poly-arg? arity)
+ (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)
+ (type.method [(list.repeat arity //.$Value) //.$Value (list)]))
+
+(def: get-amount-of-partialsI
+ Inst
+ (|>> (_.ALOAD 0)
+ (_.GETFIELD //.$Function //runtime.partials-field type.int)))
+
+(def: (load-fieldI class field)
+ (-> (Type Class) Text Inst)
+ (|>> (_.ALOAD 0)
+ (_.GETFIELD class field //.$Value)))
+
+(def: (inputsI start amount)
+ (-> Register Nat Inst)
+ (|> (list.n/range start (n.+ start (dec amount)))
+ (list@map _.ALOAD)
+ _.fuse))
+
+(def: (applysI start amount)
+ (-> Register Nat Inst)
+ (let [max-args (n.min amount //runtime.num-apply-variants)
+ later-applysI (if (n.> //runtime.num-apply-variants amount)
+ (applysI (n.+ //runtime.num-apply-variants start) (n.- //runtime.num-apply-variants amount))
+ function.identity)]
+ (|>> (_.CHECKCAST //.$Function)
+ (inputsI start max-args)
+ (_.INVOKEVIRTUAL //.$Function //runtime.apply-method (//runtime.apply-signature max-args))
+ later-applysI)))
+
+(def: (inc-intI by)
+ (-> Nat Inst)
+ (|>> (_.int (.int by))
+ _.IADD))
+
+(def: (nullsI amount)
+ (-> Nat Inst)
+ (|> _.NULL
+ (list.repeat amount)
+ _.fuse))
+
+(def: (instance archive class arity env)
+ (-> Archive (Type Class) Arity Environment (Operation Inst))
+ (do {@ phase.monad}
+ [captureI+ (monad.map @ (reference.variable archive) env)
+ #let [argsI (if (poly-arg? arity)
+ (|> (nullsI (dec arity))
+ (list (_.int +0))
+ _.fuse)
+ function.identity)]]
+ (wrap (|>> (_.NEW class)
+ _.DUP
+ (_.fuse captureI+)
+ argsI
+ (_.INVOKESPECIAL class "<init>" (init-method env arity))))))
+
+(def: (reset-method return)
+ (-> (Type Class) (Type Method))
+ (type.method [(list) return (list)]))
+
+(def: (with-reset class arity env)
+ (-> (Type Class) Arity Environment Def)
+ (def.method #$.Public $.noneM "reset" (reset-method class)
+ (if (poly-arg? arity)
+ (let [env-size (list.size env)
+ captureI (|> (case env-size
+ 0 (list)
+ _ (list.n/range 0 (dec env-size)))
+ (list@map (.function (_ source)
+ (|>> (_.ALOAD 0)
+ (_.GETFIELD class (reference.foreign-name source) //.$Value))))
+ _.fuse)
+ argsI (|> (nullsI (dec arity))
+ (list (_.int +0))
+ _.fuse)]
+ (|>> (_.NEW class)
+ _.DUP
+ captureI
+ argsI
+ (_.INVOKESPECIAL class "<init>" (init-method env arity))
+ _.ARETURN))
+ (|>> (_.ALOAD 0)
+ _.ARETURN))))
+
+(def: (with-implementation arity @begin bodyI)
+ (-> Nat Label Inst Def)
+ (def.method #$.Public $.strictM "impl" (implementation-method arity)
+ (|>> (_.label @begin)
+ bodyI
+ _.ARETURN)))
+
+(def: function-init-method
+ (type.method [(list type.int) type.void (list)]))
+
+(def: (function-init arity env-size)
+ (-> Arity Nat Inst)
+ (if (n.= 1 arity)
+ (|>> (_.int +0)
+ (_.INVOKESPECIAL //.$Function "<init>" function-init-method))
+ (|>> (_.ILOAD (inc env-size))
+ (_.INVOKESPECIAL //.$Function "<init>" function-init-method))))
+
+(def: (with-init class env arity)
+ (-> (Type Class) Environment Arity Def)
+ (let [env-size (list.size env)
+ offset-partial (: (-> Nat Nat)
+ (|>> inc (n.+ env-size)))
+ store-capturedI (|> (case env-size
+ 0 (list)
+ _ (list.n/range 0 (dec env-size)))
+ (list@map (.function (_ register)
+ (|>> (_.ALOAD 0)
+ (_.ALOAD (inc register))
+ (_.PUTFIELD class (reference.foreign-name register) //.$Value))))
+ _.fuse)
+ store-partialI (if (poly-arg? arity)
+ (|> (list.n/range 0 (n.- 2 arity))
+ (list@map (.function (_ idx)
+ (let [register (offset-partial idx)]
+ (|>> (_.ALOAD 0)
+ (_.ALOAD (inc register))
+ (_.PUTFIELD class (reference.partial-name idx) //.$Value)))))
+ _.fuse)
+ function.identity)]
+ (def.method #$.Public $.noneM "<init>" (init-method env arity)
+ (|>> (_.ALOAD 0)
+ (function-init arity env-size)
+ store-capturedI
+ store-partialI
+ _.RETURN))))
+
+(def: (with-apply class env function-arity @begin bodyI apply-arity)
+ (-> (Type Class) Environment Arity Label Inst Arity
+ Def)
+ (let [num-partials (dec function-arity)
+ @default ($.new-label [])
+ @labels (list@map $.new-label (list.repeat num-partials []))
+ over-extent (|> (.int function-arity) (i.- (.int apply-arity)))
+ casesI (|> (list@compose @labels (list @default))
+ (list.zip2 (list.n/range 0 num-partials))
+ (list@map (.function (_ [stage @label])
+ (let [load-partialsI (if (n.> 0 stage)
+ (|> (list.n/range 0 (dec stage))
+ (list@map (|>> reference.partial-name (load-fieldI class)))
+ _.fuse)
+ function.identity)]
+ (cond (i.= over-extent (.int stage))
+ (|>> (_.label @label)
+ (_.ALOAD 0)
+ (when> [(new> (n.> 0 stage) [])]
+ [(_.INVOKEVIRTUAL class "reset" (reset-method class))])
+ load-partialsI
+ (inputsI 1 apply-arity)
+ (_.INVOKEVIRTUAL class "impl" (implementation-method function-arity))
+ _.ARETURN)
+
+ (i.> over-extent (.int stage))
+ (let [args-to-completion (|> function-arity (n.- stage))
+ args-left (|> apply-arity (n.- args-to-completion))]
+ (|>> (_.label @label)
+ (_.ALOAD 0)
+ (_.INVOKEVIRTUAL class "reset" (reset-method class))
+ load-partialsI
+ (inputsI 1 args-to-completion)
+ (_.INVOKEVIRTUAL class "impl" (implementation-method function-arity))
+ (applysI (inc args-to-completion) args-left)
+ _.ARETURN))
+
+ ## (i.< over-extent (.int stage))
+ (let [env-size (list.size env)
+ load-capturedI (|> (case env-size
+ 0 (list)
+ _ (list.n/range 0 (dec env-size)))
+ (list@map (|>> reference.foreign-name (load-fieldI class)))
+ _.fuse)]
+ (|>> (_.label @label)
+ (_.NEW class)
+ _.DUP
+ load-capturedI
+ get-amount-of-partialsI
+ (inc-intI apply-arity)
+ load-partialsI
+ (inputsI 1 apply-arity)
+ (nullsI (|> num-partials (n.- apply-arity) (n.- stage)))
+ (_.INVOKESPECIAL class "<init>" (init-method env function-arity))
+ _.ARETURN))
+ ))))
+ _.fuse)]
+ (def.method #$.Public $.noneM //runtime.apply-method (//runtime.apply-signature apply-arity)
+ (|>> get-amount-of-partialsI
+ (_.TABLESWITCH +0 (|> num-partials dec .int)
+ @default @labels)
+ casesI
+ ))))
+
+(def: #export with-environment
+ (-> Environment Def)
+ (|>> list.enumerate
+ (list@map (.function (_ [env-idx env-source])
+ (def.field #$.Private $.finalF (reference.foreign-name env-idx) //.$Value)))
+ def.fuse))
+
+(def: (with-partial arity)
+ (-> Arity Def)
+ (if (poly-arg? arity)
+ (|> (list.n/range 0 (n.- 2 arity))
+ (list@map (.function (_ idx)
+ (def.field #$.Private $.finalF (reference.partial-name idx) //.$Value)))
+ def.fuse)
+ function.identity))
+
+(def: #export (with-function archive @begin class env arity bodyI)
+ (-> Archive Label Text Environment Arity Inst
+ (Operation [Def Inst]))
+ (let [classD (type.class class (list))
+ applyD (: Def
+ (if (poly-arg? arity)
+ (|> (n.min arity //runtime.num-apply-variants)
+ (list.n/range 1)
+ (list@map (with-apply classD env arity @begin bodyI))
+ (list& (with-implementation arity @begin bodyI))
+ def.fuse)
+ (def.method #$.Public $.strictM //runtime.apply-method (//runtime.apply-signature 1)
+ (|>> (_.label @begin)
+ bodyI
+ _.ARETURN))))
+ functionD (: Def
+ (|>> (def.int-field #$.Public ($_ $.++F $.staticF $.finalF) arity-field (.int arity))
+ (with-environment env)
+ (with-partial arity)
+ (with-init classD env arity)
+ (with-reset classD arity env)
+ applyD
+ ))]
+ (do phase.monad
+ [instanceI (instance archive classD arity env)]
+ (wrap [functionD instanceI]))))
+
+(def: #export (function generate archive [env arity bodyS])
+ (Generator Abstraction)
+ (do phase.monad
+ [@begin _.make-label
+ [function-context bodyI] (generation.with-new-context archive
+ (generation.with-anchor [@begin 1]
+ (generate archive bodyS)))
+ #let [function-class (//.class-name function-context)]
+ [functionD instanceI] (with-function archive @begin function-class env arity bodyI)
+ _ (generation.save! true ["" (%.nat (product.right function-context))]
+ [function-class
+ (def.class #$.V1_6 #$.Public $.finalC
+ function-class (list)
+ //.$Function (list)
+ functionD)])]
+ (wrap instanceI)))
+
+(def: #export (call generate archive [functionS argsS])
+ (Generator Apply)
+ (do {@ phase.monad}
+ [functionI (generate archive functionS)
+ argsI (monad.map @ (generate archive) argsS)
+ #let [applyI (|> argsI
+ (list.split-all //runtime.num-apply-variants)
+ (list@map (.function (_ chunkI+)
+ (|>> (_.CHECKCAST //.$Function)
+ (_.fuse chunkI+)
+ (_.INVOKEVIRTUAL //.$Function //runtime.apply-method (//runtime.apply-signature (list.size chunkI+))))))
+ _.fuse)]]
+ (wrap (|>> functionI
+ applyI))))
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/loop.lux b/lux-jvm/source/luxc/lang/translation/jvm/loop.lux
new file mode 100644
index 000000000..1f2168fed
--- /dev/null
+++ b/lux-jvm/source/luxc/lang/translation/jvm/loop.lux
@@ -0,0 +1,81 @@
+(.module:
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." function]]
+ [data
+ [number
+ ["n" nat]]
+ [collection
+ ["." list ("#/." functor monoid)]]]
+ [tool
+ [compiler
+ [reference (#+ Register)]
+ ["." phase]
+ [language
+ [lux
+ ["." synthesis (#+ Synthesis)]
+ ["." generation]]]]]]
+ [luxc
+ [lang
+ [host
+ [jvm (#+ Inst Operation Phase Generator)
+ ["_" inst]]]]]
+ ["." //])
+
+(def: (invariant? register changeS)
+ (-> Register Synthesis Bit)
+ (case changeS
+ (^ (synthesis.variable/local var))
+ (n.= register var)
+
+ _
+ false))
+
+(def: #export (recur translate archive argsS)
+ (Generator (List Synthesis))
+ (do {@ phase.monad}
+ [[@begin start] generation.anchor
+ #let [end (|> argsS list.size dec (n.+ start))
+ pairs (list.zip2 (list.n/range start end)
+ argsS)]
+ ## It may look weird that first I compile the values separately,
+ ## and then I compile the stores/allocations.
+ ## It must be done that way in order to avoid a potential bug.
+ ## Let's say that you'll recur with 2 expressions: X and Y.
+ ## If Y depends on the value of X, and you don't compile values
+ ## and stores separately, then by the time Y is evaluated, it
+ ## will refer to the new value of X, instead of the old value, as
+ ## should be the case.
+ valuesI+ (monad.map @ (function (_ [register argS])
+ (: (Operation Inst)
+ (if (invariant? register argS)
+ (wrap function.identity)
+ (translate archive argS))))
+ pairs)
+ #let [storesI+ (list/map (function (_ [register argS])
+ (: Inst
+ (if (invariant? register argS)
+ function.identity
+ (_.ASTORE register))))
+ (list.reverse pairs))]]
+ (wrap (|>> (_.fuse valuesI+)
+ (_.fuse storesI+)
+ (_.GOTO @begin)))))
+
+(def: #export (scope translate archive [start initsS+ iterationS])
+ (Generator [Nat (List Synthesis) Synthesis])
+ (do {@ phase.monad}
+ [@begin _.make-label
+ initsI+ (monad.map @ (translate archive) initsS+)
+ iterationI (generation.with-anchor [@begin start]
+ (translate archive iterationS))
+ #let [initializationI (|> (list.enumerate initsI+)
+ (list/map (function (_ [register initI])
+ (|>> initI
+ (_.ASTORE (n.+ start register)))))
+ _.fuse)]]
+ (wrap (|>> initializationI
+ (_.label @begin)
+ iterationI))))
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/primitive.lux b/lux-jvm/source/luxc/lang/translation/jvm/primitive.lux
new file mode 100644
index 000000000..873c363bd
--- /dev/null
+++ b/lux-jvm/source/luxc/lang/translation/jvm/primitive.lux
@@ -0,0 +1,30 @@
+(.module:
+ [lux (#- i64)
+ [target
+ [jvm
+ ["." type]]]
+ [tool
+ [compiler
+ [phase ("operation@." monad)]]]]
+ [luxc
+ [lang
+ [host
+ ["." jvm (#+ Inst Operation)
+ ["_" inst]]]]])
+
+(def: #export bit
+ (-> Bit (Operation Inst))
+ (let [Boolean (type.class "java.lang.Boolean" (list))]
+ (function (_ value)
+ (operation@wrap (_.GETSTATIC Boolean (if value "TRUE" "FALSE") Boolean)))))
+
+(template [<name> <type> <load> <wrap>]
+ [(def: #export (<name> value)
+ (-> <type> (Operation Inst))
+ (let [loadI (|> value <load>)]
+ (operation@wrap (|>> loadI <wrap>))))]
+
+ [i64 (I64 Any) (<| _.long .int) (_.wrap type.long)]
+ [f64 Frac _.double (_.wrap type.double)]
+ [text Text _.string (<|)]
+ )
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/program.lux b/lux-jvm/source/luxc/lang/translation/jvm/program.lux
new file mode 100644
index 000000000..7ac897009
--- /dev/null
+++ b/lux-jvm/source/luxc/lang/translation/jvm/program.lux
@@ -0,0 +1,82 @@
+(.module:
+ [lux #*
+ [target
+ [jvm
+ ["$t" type]]]]
+ [luxc
+ [lang
+ [host
+ ["_" jvm
+ ["$d" def]
+ ["$i" inst]]]
+ [translation
+ ["." jvm
+ ["." runtime]]]]])
+
+(def: #export class "LuxProgram")
+
+(def: ^Object ($t.class "java.lang.Object" (list)))
+
+(def: #export (program programI)
+ (-> _.Inst _.Definition)
+ (let [nilI runtime.noneI
+ num-inputsI (|>> ($i.ALOAD 0) $i.ARRAYLENGTH)
+ decI (|>> ($i.int +1) $i.ISUB)
+ headI (|>> $i.DUP
+ ($i.ALOAD 0)
+ $i.SWAP
+ $i.AALOAD
+ $i.SWAP
+ $i.DUP_X2
+ $i.POP)
+ pairI (|>> ($i.int +2)
+ ($i.ANEWARRAY ..^Object)
+ $i.DUP_X1
+ $i.SWAP
+ ($i.int +0)
+ $i.SWAP
+ $i.AASTORE
+ $i.DUP_X1
+ $i.SWAP
+ ($i.int +1)
+ $i.SWAP
+ $i.AASTORE)
+ consI (|>> ($i.int +1)
+ ($i.string "")
+ $i.DUP2_X1
+ $i.POP2
+ runtime.variantI)
+ prepare-input-listI (<| $i.with-label (function (_ @loop))
+ $i.with-label (function (_ @end))
+ (|>> nilI
+ num-inputsI
+ ($i.label @loop)
+ decI
+ $i.DUP
+ ($i.IFLT @end)
+ headI
+ pairI
+ consI
+ $i.SWAP
+ ($i.GOTO @loop)
+ ($i.label @end)
+ $i.POP))
+ feed-inputsI ($i.INVOKEVIRTUAL jvm.$Function runtime.apply-method (runtime.apply-signature 1))
+ run-ioI (|>> ($i.CHECKCAST jvm.$Function)
+ $i.NULL
+ ($i.INVOKEVIRTUAL jvm.$Function runtime.apply-method (runtime.apply-signature 1)))
+ main-type ($t.method [(list ($t.array ($t.class "java.lang.String" (list))))
+ $t.void
+ (list)])]
+ [..class
+ ($d.class #_.V1_6
+ #_.Public _.finalC
+ ..class
+ (list) ..^Object
+ (list)
+ (|>> ($d.method #_.Public _.staticM "main" main-type
+ (|>> programI
+ prepare-input-listI
+ feed-inputsI
+ run-ioI
+ $i.RETURN))))]))
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/reference.lux b/lux-jvm/source/luxc/lang/translation/jvm/reference.lux
new file mode 100644
index 000000000..6bcf4a2e5
--- /dev/null
+++ b/lux-jvm/source/luxc/lang/translation/jvm/reference.lux
@@ -0,0 +1,65 @@
+(.module:
+ [lux #*
+ [abstract
+ [monad (#+ do)]]
+ [data
+ [text
+ ["%" format (#+ format)]]]
+ [target
+ [jvm
+ ["." type]]]
+ [tool
+ [compiler
+ ["." reference (#+ Register Variable)]
+ ["." phase ("operation@." monad)]
+ [meta
+ [archive (#+ Archive)]]
+ [language
+ [lux
+ ["." generation]]]]]]
+ [luxc
+ [lang
+ [host
+ [jvm (#+ Inst Operation)
+ ["_" inst]]]]]
+ ["." //
+ ["#." runtime]])
+
+(template [<name> <prefix>]
+ [(def: #export <name>
+ (-> Nat Text)
+ (|>> %.nat (format <prefix>)))]
+
+ [foreign-name "f"]
+ [partial-name "p"]
+ )
+
+(def: (foreign archive variable)
+ (-> Archive Register (Operation Inst))
+ (do {@ phase.monad}
+ [class-name (:: @ map //.class-name
+ (generation.context archive))]
+ (wrap (|>> (_.ALOAD 0)
+ (_.GETFIELD (type.class class-name (list))
+ (|> variable .nat foreign-name)
+ //.$Value)))))
+
+(def: local
+ (-> Register Inst)
+ (|>> _.ALOAD))
+
+(def: #export (variable archive variable)
+ (-> Archive Variable (Operation Inst))
+ (case variable
+ (#reference.Local variable)
+ (operation@wrap (local variable))
+
+ (#reference.Foreign variable)
+ (foreign archive variable)))
+
+(def: #export (constant archive name)
+ (-> Archive Name (Operation Inst))
+ (do {@ phase.monad}
+ [class-name (:: @ map //.class-name
+ (generation.remember archive name))]
+ (wrap (_.GETSTATIC (type.class class-name (list)) //.value-field //.$Value))))
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux b/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux
new file mode 100644
index 000000000..a657a7a38
--- /dev/null
+++ b/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux
@@ -0,0 +1,387 @@
+(.module:
+ [lux (#- Type)
+ [abstract
+ [monad (#+ do)]]
+ [data
+ [binary (#+ Binary)]
+ ["." product]
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#@." functor)]
+ ["." row]]]
+ ["." math]
+ [target
+ [jvm
+ ["." type (#+ Type)
+ ["." category (#+ Void Value' Value Return' Return Primitive Object Class Array Var Parameter Method)]
+ ["." reflection]]]]
+ [tool
+ [compiler (#+ Output)
+ [arity (#+ Arity)]
+ ["." phase]
+ [language
+ [lux
+ ["." synthesis]
+ ["." generation]]]
+ [meta
+ [archive
+ ["." artifact (#+ Registry)]]]]]]
+ [luxc
+ [lang
+ [host
+ ["$" jvm (#+ Label Inst Def Operation)
+ ["$d" def]
+ ["_" inst]]]]]
+ ["." // (#+ ByteCode)])
+
+(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: nullary-init-methodT
+ (type.method [(list) type.void (list)]))
+
+(def: throw-methodT
+ (type.method [(list) type.void (list)]))
+
+(def: #export logI
+ Inst
+ (let [PrintStream (type.class "java.io.PrintStream" (list))
+ outI (_.GETSTATIC (type.class "java.lang.System" (list)) "out" PrintStream)
+ printI (function (_ method)
+ (_.INVOKEVIRTUAL PrintStream method (type.method [(list $Value) type.void (list)])))]
+ (|>> outI (_.string "LOG: ") (printI "print")
+ outI _.SWAP (printI "println"))))
+
+(def: variant-method
+ (type.method [(list $Tag $Flag $Value) //.$Variant (list)]))
+
+(def: #export variantI
+ Inst
+ (_.INVOKESTATIC //.$Runtime "variant_make" variant-method))
+
+(def: #export leftI
+ Inst
+ (|>> (_.int +0)
+ _.NULL
+ _.DUP2_X1
+ _.POP2
+ variantI))
+
+(def: #export rightI
+ Inst
+ (|>> (_.int +1)
+ (_.string "")
+ _.DUP2_X1
+ _.POP2
+ variantI))
+
+(def: #export someI Inst rightI)
+
+(def: #export noneI
+ Inst
+ (|>> (_.int +0)
+ _.NULL
+ (_.string synthesis.unit)
+ variantI))
+
+(def: (tryI unsafeI)
+ (-> Inst Inst)
+ (<| _.with-label (function (_ @from))
+ _.with-label (function (_ @to))
+ _.with-label (function (_ @handler))
+ (|>> (_.try @from @to @handler (type.class "java.lang.Exception" (list)))
+ (_.label @from)
+ unsafeI
+ someI
+ _.ARETURN
+ (_.label @to)
+ (_.label @handler)
+ noneI
+ _.ARETURN)))
+
+(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 (Type Method))
+ (type.method [(list.repeat arity $Value) $Value (list)]))
+
+(def: adt-methods
+ Def
+ (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"
+ (type.method [(list $Tag $Flag $Value) //.$Variant (list)])
+ (|>> (_.int +3)
+ (_.ANEWARRAY $Value)
+ store-tagI
+ store-flagI
+ store-valueI
+ _.ARETURN)))))
+
+(def: frac-methods
+ Def
+ (|>> ($d.method #$.Public $.staticM "decode_frac" (type.method [(list $Text) //.$Variant (list)])
+ (tryI
+ (|>> (_.ALOAD 0)
+ (_.INVOKESTATIC (type.class "java.lang.Double" (list)) "parseDouble" (type.method [(list $Text) type.double (list)]))
+ (_.wrap type.double))))
+ ))
+
+(def: (illegal-state-exception message)
+ (-> Text Inst)
+ (let [IllegalStateException (type.class "java.lang.IllegalStateException" (list))]
+ (|>> (_.NEW IllegalStateException)
+ _.DUP
+ (_.string message)
+ (_.INVOKESPECIAL IllegalStateException "<init>" (type.method [(list $Text) type.void (list)])))))
+
+(def: pm-methods
+ Def
+ (let [tuple-sizeI (|>> (_.ALOAD 0) _.ARRAYLENGTH)
+ last-rightI (|>> tuple-sizeI (_.int +1) _.ISUB)
+ leftsI (_.ILOAD 1)
+ left-indexI leftsI
+ sub-leftsI (|>> leftsI
+ last-rightI
+ _.ISUB)
+ sub-tupleI (|>> (_.ALOAD 0) last-rightI _.AALOAD (_.CHECKCAST //.$Tuple))
+ recurI (: (-> Label Inst)
+ (function (_ @loop)
+ (|>> sub-leftsI (_.ISTORE 1)
+ sub-tupleI (_.ASTORE 0)
+ (_.GOTO @loop))))]
+ (|>> ($d.method #$.Public $.staticM "pm_fail" throw-methodT
+ (|>> (illegal-state-exception "Invalid expression for pattern-matching.")
+ _.ATHROW))
+ ($d.method #$.Public $.staticM "apply_fail" throw-methodT
+ (|>> (illegal-state-exception "Error while applying function.")
+ _.ATHROW))
+ ($d.method #$.Public $.staticM "pm_push" (type.method [(list $Stack $Value) $Stack (list)])
+ (|>> (_.int +2)
+ (_.ANEWARRAY $Value)
+ _.DUP
+ (_.int +1)
+ (_.ALOAD 0)
+ _.AASTORE
+ _.DUP
+ (_.int +0)
+ (_.ALOAD 1)
+ _.AASTORE
+ _.ARETURN))
+ ($d.method #$.Public $.staticM "pm_variant" (type.method [(list //.$Variant $Tag $Flag) $Value (list)])
+ (<| _.with-label (function (_ @loop))
+ _.with-label (function (_ @perfect-match!))
+ _.with-label (function (_ @tags-match!))
+ _.with-label (function (_ @maybe-nested))
+ _.with-label (function (_ @mismatch!))
+ (let [$variant (_.ALOAD 0)
+ $tag (_.ILOAD 1)
+ $last? (_.ALOAD 2)
+
+ variant-partI (: (-> Nat Inst)
+ (function (_ idx)
+ (|>> (_.int (.int idx)) _.AALOAD)))
+ ::tag (: Inst
+ (|>> (variant-partI 0) (_.unwrap type.int)))
+ ::last? (variant-partI 1)
+ ::value (variant-partI 2)
+
+ super-nested-tag (|>> _.SWAP ## variant::tag, tag
+ _.ISUB)
+ super-nested (|>> super-nested-tag ## super-tag
+ $variant ::last? ## super-tag, super-last
+ $variant ::value ## super-tag, super-last, super-value
+ ..variantI)
+
+ update-$tag _.ISUB
+ update-$variant (|>> $variant ::value
+ (_.CHECKCAST //.$Variant)
+ (_.ASTORE 0))
+ iterate! (: (-> Label Inst)
+ (function (_ @loop)
+ (|>> update-$variant
+ update-$tag
+ (_.GOTO @loop))))
+
+ not-found _.NULL])
+ (|>> $tag ## tag
+ (_.label @loop)
+ $variant ::tag ## tag, variant::tag
+ _.DUP2 (_.IF_ICMPEQ @tags-match!) ## tag, variant::tag
+ _.DUP2 (_.IF_ICMPGT @maybe-nested) ## tag, variant::tag
+ $last? (_.IFNULL @mismatch!) ## tag, variant::tag
+ super-nested ## super-variant
+ _.ARETURN
+ (_.label @tags-match!) ## tag, variant::tag
+ $last? ## tag, variant::tag, last?
+ $variant ::last? ## tag, variant::tag, last?, variant::last?
+ (_.IF_ACMPEQ @perfect-match!) ## tag, variant::tag
+ (_.label @maybe-nested) ## tag, variant::tag
+ $variant ::last? ## tag, variant::tag, variant::last?
+ (_.IFNULL @mismatch!) ## tag, variant::tag
+ (iterate! @loop)
+ (_.label @perfect-match!) ## tag, variant::tag
+ ## _.POP2
+ $variant ::value
+ _.ARETURN
+ (_.label @mismatch!) ## tag, variant::tag
+ ## _.POP2
+ not-found
+ _.ARETURN)))
+ ($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)])
+ (|>> (_.label @loop)
+ leftsI last-rightI (_.IF_ICMPGE @recursive)
+ left-accessI
+ _.ARETURN
+ (_.label @recursive)
+ ## Recursive
+ (recurI @loop))))
+ ($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))
+ (let [right-indexI (|>> leftsI
+ (_.int +1)
+ _.IADD)
+ right-accessI (|>> (_.ALOAD 0)
+ _.SWAP
+ _.AALOAD)
+ sub-rightI (|>> (_.ALOAD 0)
+ right-indexI
+ tuple-sizeI
+ (_.INVOKESTATIC (type.class "java.util.Arrays" (list)) "copyOfRange"
+ (type.method [(list //.$Tuple $Index $Index)
+ //.$Tuple
+ (list)])))])
+ (|>> (_.label @loop)
+ last-rightI right-indexI
+ _.DUP2 (_.IF_ICMPNE @not-tail)
+ ## _.POP
+ right-accessI
+ _.ARETURN
+ (_.label @not-tail)
+ (_.IF_ICMPGT @slice)
+ ## Must recurse
+ (recurI @loop)
+ (_.label @slice)
+ sub-rightI
+ _.ARETURN
+ )))
+ )))
+
+(def: #export try (type.method [(list //.$Function) //.$Variant (list)]))
+
+(def: io-methods
+ Def
+ (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))
+ print-writerI (|>> (_.NEW PrintWriter)
+ _.SWAP
+ _.DUP2
+ _.POP
+ _.SWAP
+ (_.boolean true)
+ (_.INVOKESPECIAL PrintWriter "<init>" (type.method [(list (type.class "java.io.Writer" (list)) type.boolean) type.void (list)]))
+ )]
+ (|>> ($d.method #$.Public $.staticM "try" ..try
+ (<| _.with-label (function (_ @from))
+ _.with-label (function (_ @to))
+ _.with-label (function (_ @handler))
+ (|>> (_.try @from @to @handler $Throwable)
+ (_.label @from)
+ (_.ALOAD 0)
+ _.NULL
+ (_.INVOKEVIRTUAL //.$Function apply-method (apply-signature 1))
+ rightI
+ _.ARETURN
+ (_.label @to)
+ (_.label @handler)
+ string-writerI ## TW
+ _.DUP2 ## TWTW
+ print-writerI ## TWTP
+ (_.INVOKEVIRTUAL $Throwable "printStackTrace" (type.method [(list (type.class "java.io.PrintWriter" (list))) type.void (list)])) ## TW
+ (_.INVOKEVIRTUAL StringWriter "toString" (type.method [(list) $Text (list)])) ## TS
+ _.SWAP _.POP leftI
+ _.ARETURN)))
+ )))
+
+(def: reflection
+ (All [category]
+ (-> (Type (<| Return' Value' category)) Text))
+ (|>> type.reflection reflection.reflection))
+
+(def: translate-runtime
+ (Operation [Text Binary])
+ (let [runtime-class (..reflection //.$Runtime)
+ bytecode ($d.class #$.V1_6 #$.Public $.finalC runtime-class (list) (type.class "java.lang.Object" (list)) (list)
+ (|>> adt-methods
+ frac-methods
+ pm-methods
+ io-methods))
+ payload ["0" bytecode]]
+ (do phase.monad
+ [_ (generation.execute! runtime-class [runtime-class bytecode])
+ _ (generation.save! false ["" "0"] payload)]
+ (wrap payload))))
+
+(def: translate-function
+ (Operation [Text Binary])
+ (let [applyI (|> (list.n/range 2 num-apply-variants)
+ (list@map (function (_ arity)
+ ($d.method #$.Public $.noneM apply-method (apply-signature arity)
+ (let [preI (|> (list.n/range 0 (dec arity))
+ (list@map _.ALOAD)
+ _.fuse)]
+ (|>> preI
+ (_.INVOKEVIRTUAL //.$Function apply-method (apply-signature (dec arity)))
+ (_.CHECKCAST //.$Function)
+ (_.ALOAD arity)
+ (_.INVOKEVIRTUAL //.$Function apply-method (apply-signature 1))
+ _.ARETURN)))))
+ (list& ($d.abstract-method #$.Public $.noneM apply-method (apply-signature 1)))
+ $d.fuse)
+ $Object (type.class "java.lang.Object" (list))
+ function-class (..reflection //.$Function)
+ 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 $Object "<init>" nullary-init-methodT)
+ (_.ALOAD 0)
+ (_.ILOAD 1)
+ (_.PUTFIELD //.$Function partials-field type.int)
+ _.RETURN))
+ applyI))
+ payload ["1" bytecode]]
+ (do phase.monad
+ [_ (generation.execute! function-class [function-class bytecode])
+ _ (generation.save! false ["" "1"] payload)]
+ (wrap payload))))
+
+(def: #export translate
+ (Operation [Registry Output])
+ (do phase.monad
+ [runtime-payload ..translate-runtime
+ function-payload ..translate-function]
+ (wrap [(|> artifact.empty
+ artifact.resource
+ product.right
+ artifact.resource
+ product.right)
+ (row.row runtime-payload
+ function-payload)])))
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/structure.lux b/lux-jvm/source/luxc/lang/translation/jvm/structure.lux
new file mode 100644
index 000000000..46f87142a
--- /dev/null
+++ b/lux-jvm/source/luxc/lang/translation/jvm/structure.lux
@@ -0,0 +1,79 @@
+(.module:
+ [lux (#- Type)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["ex" exception (#+ exception:)]]
+ [data
+ [number
+ ["n" nat]]
+ [text
+ ["%" format (#+ format)]]
+ [collection
+ ["." list]]]
+ [target
+ [jvm
+ ["." type (#+ Type)
+ ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)]
+ ["." descriptor (#+ Descriptor)]
+ ["." signature (#+ Signature)]]]]
+ [tool
+ [compiler
+ ["." phase]
+ [meta
+ [archive (#+ Archive)]]
+ [language
+ [lux
+ [synthesis (#+ Synthesis)]]]]]]
+ [luxc
+ [lang
+ [host
+ [jvm (#+ Inst Operation Phase Generator)
+ ["_" inst]]]]]
+ ["." //
+ ["#." runtime]])
+
+(exception: #export (not-a-tuple {size Nat})
+ (ex.report ["Expected size" ">= 2"]
+ ["Actual size" (%.nat size)]))
+
+(def: #export (tuple generate archive members)
+ (Generator (List Synthesis))
+ (do {@ phase.monad}
+ [#let [size (list.size members)]
+ _ (phase.assert not-a-tuple size
+ (n.>= 2 size))
+ membersI (|> members
+ list.enumerate
+ (monad.map @ (function (_ [idx member])
+ (do @
+ [memberI (generate archive member)]
+ (wrap (|>> _.DUP
+ (_.int (.int idx))
+ memberI
+ _.AASTORE)))))
+ (:: @ map _.fuse))]
+ (wrap (|>> (_.int (.int size))
+ (_.array //runtime.$Value)
+ membersI))))
+
+(def: (flagI right?)
+ (-> Bit Inst)
+ (if right?
+ (_.string "")
+ _.NULL))
+
+(def: #export (variant generate archive [lefts right? member])
+ (Generator [Nat Bit Synthesis])
+ (do phase.monad
+ [memberI (generate archive member)]
+ (wrap (|>> (_.int (.int (if right?
+ (.inc lefts)
+ lefts)))
+ (flagI right?)
+ memberI
+ (_.INVOKESTATIC //.$Runtime
+ "variant_make"
+ (type.method [(list //runtime.$Tag //runtime.$Flag //runtime.$Value)
+ //.$Variant
+ (list)]))))))