aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source
diff options
context:
space:
mode:
authorEduardo Julian2020-05-30 15:19:28 -0400
committerEduardo Julian2020-05-30 15:19:28 -0400
commitb4d0eba7485caf0c6cf58de1193a9114fa273d8b (patch)
treef6f7fa2967bb5923347db1ed1d4c9b08e56bf8c6 /new-luxc/source
parent6eaa3b57f3f1ea2ce13b942bdb4ef502fc1729bc (diff)
Split new-luxc into lux-jvm and lux-r.
Diffstat (limited to 'new-luxc/source')
-rw-r--r--new-luxc/source/luxc/lang/directive/jvm.lux538
-rw-r--r--new-luxc/source/luxc/lang/host/jvm.lux131
-rw-r--r--new-luxc/source/luxc/lang/host/jvm/def.lux298
-rw-r--r--new-luxc/source/luxc/lang/host/jvm/inst.lux464
-rw-r--r--new-luxc/source/luxc/lang/host/r.lux299
-rw-r--r--new-luxc/source/luxc/lang/synthesis/variable.lux98
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm.lux182
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/case.lux239
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/common.lux72
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/expression.lux72
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/extension.lux16
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/extension/common.lux388
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/extension/host.lux1047
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/function.lux331
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/loop.lux81
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/primitive.lux30
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/program.lux82
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/reference.lux65
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/runtime.lux387
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/structure.lux79
-rw-r--r--new-luxc/source/luxc/lang/translation/r.lux216
-rw-r--r--new-luxc/source/luxc/lang/translation/r/case.jvm.lux195
-rw-r--r--new-luxc/source/luxc/lang/translation/r/expression.jvm.lux88
-rw-r--r--new-luxc/source/luxc/lang/translation/r/function.jvm.lux94
-rw-r--r--new-luxc/source/luxc/lang/translation/r/loop.jvm.lux37
-rw-r--r--new-luxc/source/luxc/lang/translation/r/primitive.jvm.lux22
-rw-r--r--new-luxc/source/luxc/lang/translation/r/procedure/common.jvm.lux339
-rw-r--r--new-luxc/source/luxc/lang/translation/r/procedure/host.jvm.lux89
-rw-r--r--new-luxc/source/luxc/lang/translation/r/reference.jvm.lux42
-rw-r--r--new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux802
-rw-r--r--new-luxc/source/luxc/lang/translation/r/statement.jvm.lux45
-rw-r--r--new-luxc/source/luxc/lang/translation/r/structure.jvm.lux31
-rw-r--r--new-luxc/source/program.lux180
-rw-r--r--new-luxc/source/test/program.lux18
34 files changed, 0 insertions, 7097 deletions
diff --git a/new-luxc/source/luxc/lang/directive/jvm.lux b/new-luxc/source/luxc/lang/directive/jvm.lux
deleted file mode 100644
index 27b1c8688..000000000
--- a/new-luxc/source/luxc/lang/directive/jvm.lux
+++ /dev/null
@@ -1,538 +0,0 @@
-(.module:
- [lux #*
- [host (#+ import:)]
- [type (#+ :share)]
- [abstract
- ["." monad (#+ do)]]
- [control
- ["." try (#+ Try)]]
- [target
- ["/" jvm]]
- [data
- [identity (#+ Identity)]
- ["." product]
- [number
- ["." nat]]
- [text
- ["%" format (#+ format)]]
- [collection
- ["." list ("#@." fold)]
- ["." dictionary (#+ Dictionary)]
- ["." row (#+ Row) ("#@." functor fold)]]]
- [tool
- [compiler
- ["." phase]
- [language
- [lux
- [synthesis (#+ Synthesis)]
- ["." generation]
- ["." directive]
- [phase
- ["." extension
- ["." bundle]
- [directive
- ["./" lux]]]]]]]]]
- [///
- [host
- ["." jvm (#+ Inst)
- ["_" inst]]]])
-
-(import: #long org/objectweb/asm/Label
- (new []))
-
-(def: (literal literal)
- (-> /.Literal Inst)
- (case literal
- (#/.Boolean value) (_.boolean value)
- (#/.Int value) (_.int value)
- (#/.Long value) (_.long value)
- (#/.Double value) (_.double value)
- (#/.Char value) (_.char value)
- (#/.String value) (_.string value)))
-
-(def: (constant instruction)
- (-> /.Constant Inst)
- (case instruction
- (#/.BIPUSH constant) (_.BIPUSH constant)
-
- (#/.SIPUSH constant) (_.SIPUSH constant)
-
- #/.ICONST_M1 _.ICONST_M1
- #/.ICONST_0 _.ICONST_0
- #/.ICONST_1 _.ICONST_1
- #/.ICONST_2 _.ICONST_2
- #/.ICONST_3 _.ICONST_3
- #/.ICONST_4 _.ICONST_4
- #/.ICONST_5 _.ICONST_5
-
- #/.LCONST_0 _.LCONST_0
- #/.LCONST_1 _.LCONST_1
-
- #/.FCONST_0 _.FCONST_0
- #/.FCONST_1 _.FCONST_1
- #/.FCONST_2 _.FCONST_2
-
- #/.DCONST_0 _.DCONST_0
- #/.DCONST_1 _.DCONST_1
-
- #/.ACONST_NULL _.NULL
-
- (#/.LDC literal)
- (..literal literal)
- ))
-
-(def: (int-arithmetic instruction)
- (-> /.Int-Arithmetic Inst)
- (case instruction
- #/.IADD _.IADD
- #/.ISUB _.ISUB
- #/.IMUL _.IMUL
- #/.IDIV _.IDIV
- #/.IREM _.IREM
- #/.INEG _.INEG))
-
-(def: (long-arithmetic instruction)
- (-> /.Long-Arithmetic Inst)
- (case instruction
- #/.LADD _.LADD
- #/.LSUB _.LSUB
- #/.LMUL _.LMUL
- #/.LDIV _.LDIV
- #/.LREM _.LREM
- #/.LNEG _.LNEG))
-
-(def: (float-arithmetic instruction)
- (-> /.Float-Arithmetic Inst)
- (case instruction
- #/.FADD _.FADD
- #/.FSUB _.FSUB
- #/.FMUL _.FMUL
- #/.FDIV _.FDIV
- #/.FREM _.FREM
- #/.FNEG _.FNEG))
-
-(def: (double-arithmetic instruction)
- (-> /.Double-Arithmetic Inst)
- (case instruction
- #/.DADD _.DADD
- #/.DSUB _.DSUB
- #/.DMUL _.DMUL
- #/.DDIV _.DDIV
- #/.DREM _.DREM
- #/.DNEG _.DNEG))
-
-(def: (arithmetic instruction)
- (-> /.Arithmetic Inst)
- (case instruction
- (#/.Int-Arithmetic int-arithmetic)
- (..int-arithmetic int-arithmetic)
-
- (#/.Long-Arithmetic long-arithmetic)
- (..long-arithmetic long-arithmetic)
-
- (#/.Float-Arithmetic float-arithmetic)
- (..float-arithmetic float-arithmetic)
-
- (#/.Double-Arithmetic double-arithmetic)
- (..double-arithmetic double-arithmetic)))
-
-(def: (int-bitwise instruction)
- (-> /.Int-Bitwise Inst)
- (case instruction
- #/.IOR _.IOR
- #/.IXOR _.IXOR
- #/.IAND _.IAND
- #/.ISHL _.ISHL
- #/.ISHR _.ISHR
- #/.IUSHR _.IUSHR))
-
-(def: (long-bitwise instruction)
- (-> /.Long-Bitwise Inst)
- (case instruction
- #/.LOR _.LOR
- #/.LXOR _.LXOR
- #/.LAND _.LAND
- #/.LSHL _.LSHL
- #/.LSHR _.LSHR
- #/.LUSHR _.LUSHR))
-
-(def: (bitwise instruction)
- (-> /.Bitwise Inst)
- (case instruction
- (#/.Int-Bitwise int-bitwise)
- (..int-bitwise int-bitwise)
-
- (#/.Long-Bitwise long-bitwise)
- (..long-bitwise long-bitwise)))
-
-(def: (conversion instruction)
- (-> /.Conversion Inst)
- (case instruction
- #/.I2B _.I2B
- #/.I2S _.I2S
- #/.I2L _.I2L
- #/.I2F _.I2F
- #/.I2D _.I2D
- #/.I2C _.I2C
-
- #/.L2I _.L2I
- #/.L2F _.L2F
- #/.L2D _.L2D
-
- #/.F2I _.F2I
- #/.F2L _.F2L
- #/.F2D _.F2D
-
- #/.D2I _.D2I
- #/.D2L _.D2L
- #/.D2F _.D2F))
-
-(def: (array instruction)
- (-> /.Array Inst)
- (case instruction
- #/.ARRAYLENGTH _.ARRAYLENGTH
-
- (#/.NEWARRAY type) (_.NEWARRAY type)
- (#/.ANEWARRAY type) (_.ANEWARRAY type)
-
- #/.BALOAD _.BALOAD
- #/.BASTORE _.BASTORE
-
- #/.SALOAD _.SALOAD
- #/.SASTORE _.SASTORE
-
- #/.IALOAD _.IALOAD
- #/.IASTORE _.IASTORE
-
- #/.LALOAD _.LALOAD
- #/.LASTORE _.LASTORE
-
- #/.FALOAD _.FALOAD
- #/.FASTORE _.FASTORE
-
- #/.DALOAD _.DALOAD
- #/.DASTORE _.DASTORE
-
- #/.CALOAD _.CALOAD
- #/.CASTORE _.CASTORE
-
- #/.AALOAD _.AALOAD
- #/.AASTORE _.AASTORE))
-
-(def: (object instruction)
- (-> /.Object Inst)
- (case instruction
- (^template [<tag> <inst>]
- (<tag> class field-name field-type)
- (<inst> class field-name field-type))
- ([#/.GETSTATIC _.GETSTATIC]
- [#/.PUTSTATIC _.PUTSTATIC]
- [#/.GETFIELD _.GETFIELD]
- [#/.PUTFIELD _.PUTFIELD])
-
- (#/.NEW type) (_.NEW type)
-
- (#/.INSTANCEOF type) (_.INSTANCEOF type)
- (#/.CHECKCAST type) (_.CHECKCAST type)
-
- (^template [<tag> <inst>]
- (<tag> class method-name method-type)
- (<inst> class method-name method-type))
- ([#/.INVOKEINTERFACE _.INVOKEINTERFACE]
- [#/.INVOKESPECIAL _.INVOKESPECIAL]
- [#/.INVOKESTATIC _.INVOKESTATIC]
- [#/.INVOKEVIRTUAL _.INVOKEVIRTUAL])
- ))
-
-(def: (local-int instruction)
- (-> /.Local-Int Inst)
- (case instruction
- (#/.ILOAD register) (_.ILOAD register)
- (#/.ISTORE register) (_.ISTORE register)))
-
-(def: (local-long instruction)
- (-> /.Local-Long Inst)
- (case instruction
- (#/.LLOAD register) (_.LLOAD register)
- (#/.LSTORE register) (_.LSTORE register)))
-
-(def: (local-float instruction)
- (-> /.Local-Float Inst)
- (case instruction
- (#/.FLOAD register) (_.FLOAD register)
- (#/.FSTORE register) (_.FSTORE register)))
-
-(def: (local-double instruction)
- (-> /.Local-Double Inst)
- (case instruction
- (#/.DLOAD register) (_.DLOAD register)
- (#/.DSTORE register) (_.DSTORE register)))
-
-(def: (local-object instruction)
- (-> /.Local-Object Inst)
- (case instruction
- (#/.ALOAD register) (_.ALOAD register)
- (#/.ASTORE register) (_.ASTORE register)))
-
-(def: (local instruction)
- (-> /.Local Inst)
- (case instruction
- (#/.Local-Int instruction) (..local-int instruction)
- (#/.IINC register) (_.IINC register)
- (#/.Local-Long instruction) (..local-long instruction)
- (#/.Local-Float instruction) (..local-float instruction)
- (#/.Local-Double instruction) (..local-double instruction)
- (#/.Local-Object instruction) (..local-object instruction)))
-
-(def: (stack instruction)
- (-> /.Stack Inst)
- (case instruction
- #/.DUP _.DUP
- #/.DUP_X1 _.DUP_X1
- #/.DUP_X2 _.DUP_X2
- #/.DUP2 _.DUP2
- #/.DUP2_X1 _.DUP2_X1
- #/.DUP2_X2 _.DUP2_X2
- #/.SWAP _.SWAP
- #/.POP _.POP
- #/.POP2 _.POP2))
-
-(def: (comparison instruction)
- (-> /.Comparison Inst)
- (case instruction
- #/.LCMP _.LCMP
-
- #/.FCMPG _.FCMPG
- #/.FCMPL _.FCMPL
-
- #/.DCMPG _.DCMPG
- #/.DCMPL _.DCMPL))
-
-(def: (branching instruction)
- (-> (/.Branching org/objectweb/asm/Label) Inst)
- (case instruction
- (#/.IF_ICMPEQ label) (_.IF_ICMPEQ label)
- (#/.IF_ICMPGE label) (_.IF_ICMPGE label)
- (#/.IF_ICMPGT label) (_.IF_ICMPGT label)
- (#/.IF_ICMPLE label) (_.IF_ICMPLE label)
- (#/.IF_ICMPLT label) (_.IF_ICMPLT label)
- (#/.IF_ICMPNE label) (_.IF_ICMPNE label)
- (#/.IFEQ label) (_.IFEQ label)
- (#/.IFGE label) (_.IFGE label)
- (#/.IFGT label) (_.IFGT label)
- (#/.IFLE label) (_.IFLE label)
- (#/.IFLT label) (_.IFLT label)
- (#/.IFNE label) (_.IFNE label)
-
- (#/.TABLESWITCH min max default labels)
- (_.TABLESWITCH min max default labels)
-
- (#/.LOOKUPSWITCH default keys+labels)
- (_.LOOKUPSWITCH default keys+labels)
-
- (#/.IF_ACMPEQ label) (_.IF_ACMPEQ label)
- (#/.IF_ACMPNE label) (_.IF_ACMPNE label)
- (#/.IFNONNULL label) (_.IFNONNULL label)
- (#/.IFNULL label) (_.IFNULL label)))
-
-(def: (exception instruction)
- (-> (/.Exception org/objectweb/asm/Label) Inst)
- (case instruction
- (#/.Try start end handler exception) (_.try start end handler exception)
- #/.ATHROW _.ATHROW))
-
-(def: (concurrency instruction)
- (-> /.Concurrency Inst)
- (case instruction
- #/.MONITORENTER _.MONITORENTER
- #/.MONITOREXIT _.MONITOREXIT))
-
-(def: (return instruction)
- (-> /.Return Inst)
- (case instruction
- #/.RETURN _.RETURN
- #/.IRETURN _.IRETURN
- #/.LRETURN _.LRETURN
- #/.FRETURN _.FRETURN
- #/.DRETURN _.DRETURN
- #/.ARETURN _.ARETURN))
-
-(def: (control instruction)
- (-> (/.Control org/objectweb/asm/Label) Inst)
- (case instruction
- (#/.GOTO label) (_.GOTO label)
- (#/.Branching instruction) (..branching instruction)
- (#/.Exception instruction) (..exception instruction)
- (#/.Concurrency instruction) (..concurrency instruction)
- (#/.Return instruction) (..return instruction)))
-
-(def: (instruction instruction)
- (-> (/.Instruction org/objectweb/asm/Label) Inst)
- (case instruction
- #/.NOP _.NOP
- (#/.Constant instruction) (..constant instruction)
- (#/.Arithmetic instruction) (..arithmetic instruction)
- (#/.Bitwise instruction) (..bitwise instruction)
- (#/.Conversion instruction) (..conversion instruction)
- (#/.Array instruction) (..array instruction)
- (#/.Object instruction) (..object instruction)
- (#/.Local instruction) (..local instruction)
- (#/.Stack instruction) (..stack instruction)
- (#/.Comparison instruction) (..comparison instruction)
- (#/.Control instruction) (..control instruction)))
-
-(type: Mapping
- (Dictionary /.Label org/objectweb/asm/Label))
-
-(type: (Re-labeler context)
- (-> [Mapping (context /.Label)]
- [Mapping (context org/objectweb/asm/Label)]))
-
-(def: (relabel [mapping label])
- (Re-labeler Identity)
- (case (dictionary.get label mapping)
- (#.Some label)
- [mapping label]
-
- #.None
- (let [label' (org/objectweb/asm/Label::new)]
- [(dictionary.put label label' mapping) label'])))
-
-(def: (relabel-branching [mapping instruction])
- (Re-labeler /.Branching)
- (case instruction
- (^template [<tag>]
- (<tag> label)
- (let [[mapping label] (..relabel [mapping label])]
- [mapping (<tag> label)]))
- ([#/.IF_ICMPEQ] [#/.IF_ICMPGE] [#/.IF_ICMPGT] [#/.IF_ICMPLE] [#/.IF_ICMPLT] [#/.IF_ICMPNE]
- [#/.IFEQ] [#/.IFNE] [#/.IFGE] [#/.IFGT] [#/.IFLE] [#/.IFLT]
-
- [#/.IF_ACMPEQ] [#/.IF_ACMPNE] [#/.IFNONNULL] [#/.IFNULL])
-
- (#/.TABLESWITCH min max default labels)
- (let [[mapping default] (..relabel [mapping default])
- [mapping labels] (list@fold (function (_ input [mapping output])
- (let [[mapping input] (..relabel [mapping input])]
- [mapping (list& input output)]))
- [mapping (list)] labels)]
- [mapping (#/.TABLESWITCH min max default (list.reverse labels))])
-
- (#/.LOOKUPSWITCH default keys+labels)
- (let [[mapping default] (..relabel [mapping default])
- [mapping keys+labels] (list@fold (function (_ [expected input] [mapping output])
- (let [[mapping input] (..relabel [mapping input])]
- [mapping (list& [expected input] output)]))
- [mapping (list)] keys+labels)]
- [mapping (#/.LOOKUPSWITCH default (list.reverse keys+labels))])
- ))
-
-(def: (relabel-exception [mapping instruction])
- (Re-labeler /.Exception)
- (case instruction
- (#/.Try start end handler exception)
- (let [[mapping start] (..relabel [mapping start])
- [mapping end] (..relabel [mapping end])
- [mapping handler] (..relabel [mapping handler])]
- [mapping (#/.Try start end handler exception)])
-
- #/.ATHROW
- [mapping #/.ATHROW]
- ))
-
-(def: (relabel-control [mapping instruction])
- (Re-labeler /.Control)
- (case instruction
- (^template [<tag> <relabel>]
- (<tag> instruction)
- (let [[mapping instruction] (<relabel> [mapping instruction])]
- [mapping (<tag> instruction)]))
- ([#/.GOTO ..relabel]
- [#/.Branching ..relabel-branching]
- [#/.Exception ..relabel-exception])
-
- (^template [<tag>]
- (<tag> instruction)
- [mapping (<tag> instruction)])
- ([#/.Concurrency] [#/.Return])
- ))
-
-(def: (relabel-instruction [mapping instruction])
- (Re-labeler /.Instruction)
- (case instruction
- #/.NOP [mapping #/.NOP]
-
- (^template [<tag>]
- (<tag> instruction)
- [mapping (<tag> instruction)])
- ([#/.Constant]
- [#/.Arithmetic]
- [#/.Bitwise]
- [#/.Conversion]
- [#/.Array]
- [#/.Object]
- [#/.Local]
- [#/.Stack]
- [#/.Comparison])
-
- (#/.Control instruction)
- (let [[mapping instruction] (..relabel-control [mapping instruction])]
- [mapping (#/.Control instruction)])))
-
-(def: (relabel-bytecode [mapping bytecode])
- (Re-labeler /.Bytecode)
- (row@fold (function (_ input [mapping output])
- (let [[mapping input] (..relabel-instruction [mapping input])]
- [mapping (row.add input output)]))
- [mapping (row.row)]
- bytecode))
-
-(def: fresh
- Mapping
- (dictionary.new nat.hash))
-
-(def: bytecode
- (-> (/.Bytecode /.Label) Inst)
- (|>> [..fresh]
- ..relabel-bytecode
- product.right
- (row@map ..instruction)
- row.to-list
- _.fuse))
-
-(type: Pseudo-Handler
- (-> Text (List Synthesis) (Try (/.Bytecode /.Label))))
-
-(def: (true-handler pseudo)
- (-> Pseudo-Handler jvm.Handler)
- (function (_ extension-name phase archive inputs)
- (|> (pseudo extension-name inputs)
- (:: try.monad map ..bytecode)
- phase.lift)))
-
-(def: (def::generation extender)
- (-> jvm.Extender
- (directive.Handler jvm.Anchor jvm.Inst jvm.Definition))
- (function (handler extension-name phase archive inputsC+)
- (case inputsC+
- (^ (list nameC valueC))
- (do phase.monad
- [[_ _ name] (lux/.evaluate! archive Text nameC)
- [_ _ pseudo-handlerV] (lux/.evaluate! archive ..Pseudo-Handler valueC)
- _ (|> pseudo-handlerV
- (:coerce ..Pseudo-Handler)
- ..true-handler
- (extension.install extender (:coerce Text name))
- directive.lift-generation)
- _ (directive.lift-generation
- (generation.log! (format "Generation " (%.text (:coerce Text name)))))]
- (wrap directive.no-requirements))
-
- _
- (phase.throw extension.invalid-syntax [extension-name %.code inputsC+]))))
-
-(def: #export (bundle extender)
- (-> jvm.Extender
- (directive.Bundle jvm.Anchor jvm.Inst jvm.Definition))
- (|> bundle.empty
- (dictionary.put "lux def generation" (..def::generation extender))))
diff --git a/new-luxc/source/luxc/lang/host/jvm.lux b/new-luxc/source/luxc/lang/host/jvm.lux
deleted file mode 100644
index d957bdb1d..000000000
--- a/new-luxc/source/luxc/lang/host/jvm.lux
+++ /dev/null
@@ -1,131 +0,0 @@
-(.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/new-luxc/source/luxc/lang/host/jvm/def.lux b/new-luxc/source/luxc/lang/host/jvm/def.lux
deleted file mode 100644
index f274da61f..000000000
--- a/new-luxc/source/luxc/lang/host/jvm/def.lux
+++ /dev/null
@@ -1,298 +0,0 @@
-(.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/new-luxc/source/luxc/lang/host/jvm/inst.lux b/new-luxc/source/luxc/lang/host/jvm/inst.lux
deleted file mode 100644
index b673c7d7e..000000000
--- a/new-luxc/source/luxc/lang/host/jvm/inst.lux
+++ /dev/null
@@ -1,464 +0,0 @@
-(.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/new-luxc/source/luxc/lang/host/r.lux b/new-luxc/source/luxc/lang/host/r.lux
deleted file mode 100644
index 6e4c7fb5b..000000000
--- a/new-luxc/source/luxc/lang/host/r.lux
+++ /dev/null
@@ -1,299 +0,0 @@
-(.module:
- [lux #- not or and list if function cond when]
- (lux (control pipe)
- (data [maybe "maybe/" Functor<Maybe>]
- [text]
- text/format
- [number]
- (coll [list "list/" Functor<List> Fold<List>]))
- (type abstract)))
-
-(abstract: #export Single {} Any)
-(abstract: #export Poly {} Any)
-
-(abstract: #export (Var kind)
- {}
-
- Text
-
- (def: name (All [k] (-> (Var k) Text)) (|>> :representation))
-
- (def: #export var (-> Text (Var Single)) (|>> :abstraction))
- (def: #export var-args (Var Poly) (:abstraction "..."))
- )
-
-(type: #export SVar (Var Single))
-(type: #export PVar (Var Poly))
-
-(abstract: #export Expression
- {}
-
- Text
-
- (def: #export expression (-> Expression Text) (|>> :representation))
-
- (def: #export code (-> Text Expression) (|>> :abstraction))
-
- (def: (self-contained code)
- (-> Text Expression)
- (:abstraction
- (format "(" code ")")))
-
- (def: nest
- (-> Text Text)
- (|>> (format "\n")
- (text.replace-all "\n" "\n ")))
-
- (def: (_block expression)
- (-> Text Text)
- (format "{" (nest expression) "\n" "}"))
-
- (def: #export (block expression)
- (-> Expression Expression)
- (:abstraction
- (format "{" (:representation expression) "}")))
-
- (def: #export null
- Expression
- (|> "NULL" self-contained))
-
- (def: #export n/a
- Expression
- (|> "NA" self-contained))
-
- (def: #export not-available Expression n/a)
- (def: #export not-applicable Expression n/a)
- (def: #export no-answer Expression n/a)
-
- (def: #export bool
- (-> Bit Expression)
- (|>> (case> #0 "FALSE"
- #1 "TRUE")
- self-contained))
-
- (def: #export (int value)
- (-> Int Expression)
- (self-contained
- (format "as.integer(" (%i value) ")")))
-
- (def: #export float
- (-> Frac Expression)
- (|>> (cond> [(f/= number.positive-infinity)]
- [(new> "1.0/0.0")]
-
- [(f/= number.negative-infinity)]
- [(new> "-1.0/0.0")]
-
- [(f/= number.not-a-number)]
- [(new> "0.0/0.0")]
-
- ## else
- [%f])
- self-contained))
-
- (def: #export string
- (-> Text Expression)
- (|>> %t self-contained))
-
- (def: (composite-literal left-delimiter right-delimiter entry-serializer)
- (All [a] (-> Text Text (-> a Text)
- (-> (List a) Expression)))
- (.function (_ entries)
- (self-contained
- (format left-delimiter
- (|> entries (list/map entry-serializer) (text.join-with ","))
- right-delimiter))))
-
- (def: #export named-list
- (-> (List [Text Expression]) Expression)
- (composite-literal "list(" ")" (.function (_ [key value])
- (format key "=" (:representation value)))))
-
- (template [<name> <function>]
- [(def: #export <name>
- (-> (List Expression) Expression)
- (composite-literal (format <function> "(") ")" expression))]
-
- [vector "c"]
- [list "list"]
- )
-
- (def: #export (slice from to list)
- (-> Expression Expression Expression Expression)
- (self-contained
- (format (:representation list)
- "[" (:representation from) ":" (:representation to) "]")))
-
- (def: #export (slice-from from list)
- (-> Expression Expression Expression)
- (self-contained
- (format (:representation list)
- "[-1" ":-" (:representation from) "]")))
-
- (def: #export (apply args func)
- (-> (List Expression) Expression Expression)
- (self-contained
- (format (:representation func) "(" (text.join-with "," (list/map expression args)) ")")))
-
- (def: #export (apply-kw args kw-args func)
- (-> (List Expression) (List [Text Expression]) Expression Expression)
- (self-contained
- (format (:representation func)
- (format "("
- (text.join-with "," (list/map expression args)) ","
- (text.join-with "," (list/map (.function (_ [key val])
- (format key "=" (expression val)))
- kw-args))
- ")"))))
-
- (def: #export (nth idx list)
- (-> Expression Expression Expression)
- (self-contained
- (format (:representation list) "[[" (:representation idx) "]]")))
-
- (def: #export (if test then else)
- (-> Expression Expression Expression Expression)
- (self-contained
- (format "if(" (:representation test) ")"
- " " (.._block (:representation then))
- " else " (.._block (:representation else)))))
-
- (def: #export (when test then)
- (-> Expression Expression Expression)
- (self-contained
- (format "if(" (:representation test) ") {"
- (.._block (:representation then))
- "\n" "}")))
-
- (def: #export (cond clauses else)
- (-> (List [Expression Expression]) Expression Expression)
- (list/fold (.function (_ [test then] next)
- (if test then next))
- else
- (list.reverse clauses)))
-
- (template [<name> <op>]
- [(def: #export (<name> param subject)
- (-> Expression Expression Expression)
- (self-contained
- (format (:representation subject)
- " " <op> " "
- (:representation param))))]
-
- [= "=="]
- [< "<"]
- [<= "<="]
- [> ">"]
- [>= ">="]
- [+ "+"]
- [- "-"]
- [* "*"]
- [/ "/"]
- [%% "%%"]
- [** "**"]
- [or "||"]
- [and "&&"]
- )
-
- (def: #export @@
- (All [k] (-> (Var k) Expression))
- (|>> ..name self-contained))
-
- (def: #export global
- (-> Text Expression)
- (|>> var @@))
-
- (template [<name> <func>]
- [(def: #export (<name> param subject)
- (-> Expression Expression Expression)
- (..apply (.list subject param) (..global <func>)))]
-
- [bit-or "bitwOr"]
- [bit-and "bitwAnd"]
- [bit-xor "bitwXor"]
- [bit-shl "bitwShiftL"]
- [bit-ushr "bitwShiftR"]
- )
-
- (def: #export (bit-not subject)
- (-> Expression Expression)
- (..apply (.list subject) (..global "bitwNot")))
-
- (template [<name> <op>]
- [(def: #export <name>
- (-> Expression Expression)
- (|>> :representation (format <op>) self-contained))]
-
- [not "!"]
- [negate "-"]
- )
-
- (def: #export (length list)
- (-> Expression Expression)
- (..apply (.list list) (..global "length")))
-
- (def: #export (range from to)
- (-> Expression Expression Expression)
- (self-contained
- (format (:representation from) ":" (:representation to))))
-
- (def: #export (function inputs body)
- (-> (List (Ex [k] (Var k))) Expression Expression)
- (let [args (|> inputs (list/map ..name) (text.join-with ", "))]
- (self-contained
- (format "function(" args ") "
- (.._block (:representation body))))))
-
- (def: #export (try body warning error finally)
- (-> Expression (Maybe Expression) (Maybe Expression) (Maybe Expression) Expression)
- (let [optional (: (-> Text (Maybe Expression) (-> Text Text) Text)
- (.function (_ parameter value preparation)
- (|> value
- (maybe/map (|>> :representation preparation (format ", " parameter " = ")))
- (maybe.default ""))))]
- (self-contained
- (format "tryCatch("
- (.._block (:representation body))
- (optional "warning" warning id)
- (optional "error" error id)
- (optional "finally" finally .._block)
- ")"))))
-
- (def: #export (while test body)
- (-> Expression Expression Expression)
- (self-contained
- (format "while (" (:representation test) ") "
- (.._block (:representation body)))))
-
- (def: #export (for-in var inputs body)
- (-> SVar Expression Expression Expression)
- (self-contained
- (format "for (" (..name var) " in " (..expression inputs) ")"
- (.._block (:representation body)))))
-
- (template [<name> <keyword>]
- [(def: #export (<name> message)
- (-> Expression Expression)
- (..apply (.list message) (..global <keyword>)))]
-
- [stop "stop"]
- [print "print"]
- )
-
- (def: #export (set! var value)
- (-> (Var Single) Expression Expression)
- (self-contained
- (format (..name var) " <- " (:representation value))))
-
- (def: #export (set-nth! idx value list)
- (-> Expression Expression SVar Expression)
- (self-contained
- (format (..name list) "[[" (:representation idx) "]] <- " (:representation value))))
-
- (def: #export (then pre post)
- (-> Expression Expression Expression)
- (:abstraction
- (format (:representation pre)
- "\n"
- (:representation post))))
- )
diff --git a/new-luxc/source/luxc/lang/synthesis/variable.lux b/new-luxc/source/luxc/lang/synthesis/variable.lux
deleted file mode 100644
index f6a45b02e..000000000
--- a/new-luxc/source/luxc/lang/synthesis/variable.lux
+++ /dev/null
@@ -1,98 +0,0 @@
-(.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/new-luxc/source/luxc/lang/translation/jvm.lux b/new-luxc/source/luxc/lang/translation/jvm.lux
deleted file mode 100644
index 141e70184..000000000
--- a/new-luxc/source/luxc/lang/translation/jvm.lux
+++ /dev/null
@@ -1,182 +0,0 @@
-(.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/new-luxc/source/luxc/lang/translation/jvm/case.lux b/new-luxc/source/luxc/lang/translation/jvm/case.lux
deleted file mode 100644
index 0d8aaa91e..000000000
--- a/new-luxc/source/luxc/lang/translation/jvm/case.lux
+++ /dev/null
@@ -1,239 +0,0 @@
-(.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/new-luxc/source/luxc/lang/translation/jvm/common.lux b/new-luxc/source/luxc/lang/translation/jvm/common.lux
deleted file mode 100644
index 6cd7f4f2f..000000000
--- a/new-luxc/source/luxc/lang/translation/jvm/common.lux
+++ /dev/null
@@ -1,72 +0,0 @@
-(.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/new-luxc/source/luxc/lang/translation/jvm/expression.lux b/new-luxc/source/luxc/lang/translation/jvm/expression.lux
deleted file mode 100644
index 144e35f9b..000000000
--- a/new-luxc/source/luxc/lang/translation/jvm/expression.lux
+++ /dev/null
@@ -1,72 +0,0 @@
-(.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/new-luxc/source/luxc/lang/translation/jvm/extension.lux b/new-luxc/source/luxc/lang/translation/jvm/extension.lux
deleted file mode 100644
index 9066dd156..000000000
--- a/new-luxc/source/luxc/lang/translation/jvm/extension.lux
+++ /dev/null
@@ -1,16 +0,0 @@
-(.module:
- [lux #*
- [data
- [collection
- ["." dictionary]]]]
- [////
- [host
- [jvm (#+ Bundle)]]]
- ["." / #_
- ["#." common]
- ["#." host]])
-
-(def: #export bundle
- Bundle
- (dictionary.merge /common.bundle
- /host.bundle))
diff --git a/new-luxc/source/luxc/lang/translation/jvm/extension/common.lux b/new-luxc/source/luxc/lang/translation/jvm/extension/common.lux
deleted file mode 100644
index 383415c0a..000000000
--- a/new-luxc/source/luxc/lang/translation/jvm/extension/common.lux
+++ /dev/null
@@ -1,388 +0,0 @@
-(.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/new-luxc/source/luxc/lang/translation/jvm/extension/host.lux b/new-luxc/source/luxc/lang/translation/jvm/extension/host.lux
deleted file mode 100644
index 7b90a8e4f..000000000
--- a/new-luxc/source/luxc/lang/translation/jvm/extension/host.lux
+++ /dev/null
@@ -1,1047 +0,0 @@
-(.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/new-luxc/source/luxc/lang/translation/jvm/function.lux b/new-luxc/source/luxc/lang/translation/jvm/function.lux
deleted file mode 100644
index 888ad9545..000000000
--- a/new-luxc/source/luxc/lang/translation/jvm/function.lux
+++ /dev/null
@@ -1,331 +0,0 @@
-(.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/new-luxc/source/luxc/lang/translation/jvm/loop.lux b/new-luxc/source/luxc/lang/translation/jvm/loop.lux
deleted file mode 100644
index 1f2168fed..000000000
--- a/new-luxc/source/luxc/lang/translation/jvm/loop.lux
+++ /dev/null
@@ -1,81 +0,0 @@
-(.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/new-luxc/source/luxc/lang/translation/jvm/primitive.lux b/new-luxc/source/luxc/lang/translation/jvm/primitive.lux
deleted file mode 100644
index 873c363bd..000000000
--- a/new-luxc/source/luxc/lang/translation/jvm/primitive.lux
+++ /dev/null
@@ -1,30 +0,0 @@
-(.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/new-luxc/source/luxc/lang/translation/jvm/program.lux b/new-luxc/source/luxc/lang/translation/jvm/program.lux
deleted file mode 100644
index 7ac897009..000000000
--- a/new-luxc/source/luxc/lang/translation/jvm/program.lux
+++ /dev/null
@@ -1,82 +0,0 @@
-(.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/new-luxc/source/luxc/lang/translation/jvm/reference.lux b/new-luxc/source/luxc/lang/translation/jvm/reference.lux
deleted file mode 100644
index 6bcf4a2e5..000000000
--- a/new-luxc/source/luxc/lang/translation/jvm/reference.lux
+++ /dev/null
@@ -1,65 +0,0 @@
-(.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/new-luxc/source/luxc/lang/translation/jvm/runtime.lux b/new-luxc/source/luxc/lang/translation/jvm/runtime.lux
deleted file mode 100644
index a657a7a38..000000000
--- a/new-luxc/source/luxc/lang/translation/jvm/runtime.lux
+++ /dev/null
@@ -1,387 +0,0 @@
-(.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/new-luxc/source/luxc/lang/translation/jvm/structure.lux b/new-luxc/source/luxc/lang/translation/jvm/structure.lux
deleted file mode 100644
index 46f87142a..000000000
--- a/new-luxc/source/luxc/lang/translation/jvm/structure.lux
+++ /dev/null
@@ -1,79 +0,0 @@
-(.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)]))))))
diff --git a/new-luxc/source/luxc/lang/translation/r.lux b/new-luxc/source/luxc/lang/translation/r.lux
deleted file mode 100644
index a4a3db1f5..000000000
--- a/new-luxc/source/luxc/lang/translation/r.lux
+++ /dev/null
@@ -1,216 +0,0 @@
-(.module:
- lux
- (lux (control ["ex" exception #+ exception:]
- pipe
- [monad #+ do])
- (data [bit]
- [maybe]
- ["e" error #+ Error]
- [text "text/" Eq<Text>]
- text/format
- (coll [array]))
- [macro]
- [io #+ IO Process io]
- [host #+ class: interface: object]
- (world [file #+ File]))
- (luxc [lang]
- (lang [".L" variable #+ Register]
- (host [r #+ Expression]))
- [".C" io]))
-
-(template [<name>]
- [(exception: #export (<name> {message Text})
- message)]
-
- [No-Active-Module-Buffer]
- [Cannot-Execute]
-
- [No-Anchor]
- )
-
-(host.import: java/lang/Object)
-
-(host.import: java/lang/String
- (getBytes [String] #try [byte]))
-
-(host.import: java/lang/CharSequence)
-
-(host.import: java/lang/Appendable
- (append [CharSequence] Appendable))
-
-(host.import: java/lang/StringBuilder
- (new [])
- (toString [] String))
-
-(host.import: javax/script/ScriptEngine
- (eval [String] #try #? Object))
-
-(host.import: javax/script/ScriptEngineFactory
- (getScriptEngine [] ScriptEngine))
-
-(type: #export Anchor [Text Register])
-
-(type: #export Host
- {#context [Text Nat]
- #anchor (Maybe Anchor)
- #loader (-> Expression (Error Any))
- #interpreter (-> Expression (Error Object))
- #module-buffer (Maybe StringBuilder)
- #program-buffer StringBuilder})
-
-(def: #export init
- (IO Host)
- (io (let [interpreter (|> (undefined)
- (ScriptEngineFactory::getScriptEngine []))]
- {#context ["" +0]
- #anchor #.None
- #loader (function (_ code)
- (do e.Monad<Error>
- [_ (ScriptEngine::eval [(r.expression code)] interpreter)]
- (wrap [])))
- #interpreter (function (_ code)
- (do e.Monad<Error>
- [output (ScriptEngine::eval [(r.expression code)] interpreter)]
- (wrap (maybe.default (:coerce Object [])
- output))))
- #module-buffer #.None
- #program-buffer (StringBuilder::new [])})))
-
-(def: #export r-module-name Text "module.r")
-
-(def: #export init-module-buffer
- (Meta Any)
- (function (_ compiler)
- (#e.Success [(update@ #.host
- (|>> (:coerce Host)
- (set@ #module-buffer (#.Some (StringBuilder::new [])))
- (:coerce Nothing))
- compiler)
- []])))
-
-(def: #export (with-sub-context expr)
- (All [a] (-> (Meta a) (Meta [Text a])))
- (function (_ compiler)
- (let [old (:coerce Host (get@ #.host compiler))
- [old-name old-sub] (get@ #context old)
- new-name (format old-name "f___" (%i (.int old-sub)))]
- (case (expr (set@ #.host
- (:coerce Nothing (set@ #context [new-name +0] old))
- compiler))
- (#e.Success [compiler' output])
- (#e.Success [(update@ #.host
- (|>> (:coerce Host)
- (set@ #context [old-name (inc old-sub)])
- (:coerce Nothing))
- compiler')
- [new-name output]])
-
- (#e.Error error)
- (#e.Error error)))))
-
-(def: #export context
- (Meta Text)
- (function (_ compiler)
- (#e.Success [compiler
- (|> (get@ #.host compiler)
- (:coerce Host)
- (get@ #context)
- (let> [name sub]
- name))])))
-
-(def: #export (with-anchor anchor expr)
- (All [a] (-> Anchor (Meta a) (Meta a)))
- (function (_ compiler)
- (let [old (:coerce Host (get@ #.host compiler))]
- (case (expr (set@ #.host
- (:coerce Nothing (set@ #anchor (#.Some anchor) old))
- compiler))
- (#e.Success [compiler' output])
- (#e.Success [(update@ #.host
- (|>> (:coerce Host)
- (set@ #anchor (get@ #anchor old))
- (:coerce Nothing))
- compiler')
- output])
-
- (#e.Error error)
- (#e.Error error)))))
-
-(def: #export anchor
- (Meta Anchor)
- (function (_ compiler)
- (case (|> compiler (get@ #.host) (:coerce Host) (get@ #anchor))
- (#.Some anchor)
- (#e.Success [compiler anchor])
-
- #.None
- ((lang.throw No-Anchor "") compiler))))
-
-(def: #export module-buffer
- (Meta StringBuilder)
- (function (_ compiler)
- (case (|> compiler (get@ #.host) (:coerce Host) (get@ #module-buffer))
- #.None
- ((lang.throw No-Active-Module-Buffer "") compiler)
-
- (#.Some module-buffer)
- (#e.Success [compiler module-buffer]))))
-
-(def: #export program-buffer
- (Meta StringBuilder)
- (function (_ compiler)
- (#e.Success [compiler (|> compiler (get@ #.host) (:coerce Host) (get@ #program-buffer))])))
-
-(template [<name> <field> <outputT>]
- [(def: (<name> code)
- (-> Expression (Meta <outputT>))
- (function (_ compiler)
- (let [runner (|> compiler (get@ #.host) (:coerce Host) (get@ <field>))]
- (case (runner code)
- (#e.Error error)
- ((lang.throw Cannot-Execute error) compiler)
-
- (#e.Success output)
- (#e.Success [compiler output])))))]
-
- [load! #loader Any]
- [interpret #interpreter Object]
- )
-
-(def: #export variant-tag-field "luxVT")
-(def: #export variant-flag-field "luxVF")
-(def: #export variant-value-field "luxVV")
-
-(def: #export int-high-field "luxIH")
-(def: #export int-low-field "luxIL")
-
-(def: #export unit Text "")
-
-(def: #export (definition-name [module name])
- (-> Name Text)
- (lang.normalize-name (format module "$" name)))
-
-(def: #export (save code)
- (-> Expression (Meta Any))
- (do macro.Monad<Meta>
- [module-buffer module-buffer
- #let [_ (Appendable::append [(:coerce CharSequence (r.expression code))]
- module-buffer)]]
- (load! code)))
-
-(def: #export run interpret)
-
-(def: #export (save-module! target)
- (-> File (Meta (Process Any)))
- (do macro.Monad<Meta>
- [module macro.current-module-name
- module-buffer module-buffer
- program-buffer program-buffer
- #let [module-code (StringBuilder::toString [] module-buffer)
- _ (Appendable::append [(:coerce CharSequence (format module-code "\n"))]
- program-buffer)]]
- (wrap (ioC.write target
- (format (lang.normalize-name module) "/" r-module-name)
- (|> module-code
- (String::getBytes ["UTF-8"])
- e.assume)))))
diff --git a/new-luxc/source/luxc/lang/translation/r/case.jvm.lux b/new-luxc/source/luxc/lang/translation/r/case.jvm.lux
deleted file mode 100644
index 42460b620..000000000
--- a/new-luxc/source/luxc/lang/translation/r/case.jvm.lux
+++ /dev/null
@@ -1,195 +0,0 @@
-(.module:
- lux
- (lux (control [monad #+ do]
- ["ex" exception #+ exception:])
- (data [number]
- [text]
- text/format
- (coll [list "list/" Functor<List> Fold<List>]
- (set ["set" unordered #+ Set])))
- [macro #+ "meta/" Monad<Meta>]
- (macro [code]))
- (luxc [lang]
- (lang [".L" variable #+ Register Variable]
- ["ls" synthesis #+ Synthesis Path]
- (host [r #+ Expression SVar @@])))
- [//]
- (// [".T" runtime]
- [".T" primitive]
- [".T" reference]))
-
-(def: #export (translate-let translate register valueS bodyS)
- (-> (-> Synthesis (Meta Expression)) Register Synthesis Synthesis
- (Meta Expression))
- (do macro.Monad<Meta>
- [valueO (translate valueS)
- bodyO (translate bodyS)
- #let [$register (referenceT.variable register)]]
- (wrap (r.block
- ($_ r.then
- (r.set! $register valueO)
- bodyO)))))
-
-(def: #export (translate-record-get translate valueS pathP)
- (-> (-> Synthesis (Meta Expression)) Synthesis (List [Nat Bit])
- (Meta Expression))
- (do macro.Monad<Meta>
- [valueO (translate valueS)]
- (wrap (list/fold (function (_ [idx tail?] source)
- (let [method (if tail?
- runtimeT.product//right
- runtimeT.product//left)]
- (method source (r.int (:coerce Int idx)))))
- valueO
- pathP))))
-
-(def: #export (translate-if testO thenO elseO)
- (-> Expression Expression Expression Expression)
- (r.if testO thenO elseO))
-
-(def: $savepoint (r.var "lux_pm_cursor_savepoint"))
-(def: $cursor (r.var "lux_pm_cursor"))
-
-(def: top r.length)
-(def: next (|>> r.length (r.+ (r.int 1))))
-(def: (push! value var)
- (-> Expression SVar Expression)
- (r.set-nth! (next (@@ var)) value var))
-(def: (pop! var)
- (-> SVar Expression)
- (r.set-nth! (top (@@ var)) r.null var))
-
-(def: (push-cursor! value)
- (-> Expression Expression)
- (push! value $cursor))
-
-(def: save-cursor!
- Expression
- (push! (r.slice (r.float 1.0) (r.length (@@ $cursor)) (@@ $cursor))
- $savepoint))
-
-(def: restore-cursor!
- Expression
- (r.set! $cursor (r.nth (top (@@ $savepoint)) (@@ $savepoint))))
-
-(def: cursor-top
- Expression
- (|> (@@ $cursor) (r.nth (top (@@ $cursor)))))
-
-(def: pop-cursor!
- Expression
- (pop! $cursor))
-
-(def: pm-error (r.string "PM-ERROR"))
-
-(def: fail-pm! (r.stop pm-error))
-
-(def: $temp (r.var "lux_pm_temp"))
-
-(exception: #export (Unrecognized-Path {message Text})
- message)
-
-(def: $alt_error (r.var "alt_error"))
-
-(def: (pm-catch handler)
- (-> Expression Expression)
- (r.function (list $alt_error)
- (r.if (|> (@@ $alt_error) (r.= pm-error))
- handler
- (r.stop (@@ $alt_error)))))
-
-(def: (translate-pattern-matching' translate pathP)
- (-> (-> Synthesis (Meta Expression)) Path (Meta Expression))
- (case pathP
- (^code ("lux case exec" (~ bodyS)))
- (do macro.Monad<Meta>
- [bodyO (translate bodyS)]
- (wrap bodyO))
-
- (^code ("lux case pop"))
- (meta/wrap pop-cursor!)
-
- (^code ("lux case bind" (~ [_ (#.Nat register)])))
- (meta/wrap (r.set! (referenceT.variable register) cursor-top))
-
- (^template [<tag> <format>]
- [_ (<tag> value)]
- (meta/wrap (r.when (r.not (r.= (|> value <format>) cursor-top))
- fail-pm!)))
- ([#.Bit r.bool]
- [#.Frac r.float]
- [#.Text r.string])
-
- (^template [<tag> <format>]
- [_ (<tag> value)]
- (meta/wrap (r.when (r.not (runtimeT.int//= (|> value <format>) cursor-top))
- fail-pm!)))
- ([#.Nat (<| runtimeT.int (:coerce Int))]
- [#.Int runtimeT.int]
- [#.Rev (<| runtimeT.int (:coerce Int))])
-
- (^template [<pm> <getter>]
- (^code (<pm> (~ [_ (#.Nat idx)])))
- (meta/wrap (push-cursor! (<getter> cursor-top (r.int (:coerce Int idx))))))
- (["lux case tuple left" runtimeT.product//left]
- ["lux case tuple right" runtimeT.product//right])
-
- (^template [<pm> <flag>]
- (^code (<pm> (~ [_ (#.Nat idx)])))
- (meta/wrap ($_ r.then
- (r.set! $temp (runtimeT.sum//get cursor-top (r.int (:coerce Int idx)) <flag>))
- (r.if (r.= r.null (@@ $temp))
- fail-pm!
- (push-cursor! (@@ $temp))))))
- (["lux case variant left" r.null]
- ["lux case variant right" (r.string "")])
-
- (^code ("lux case seq" (~ leftP) (~ rightP)))
- (do macro.Monad<Meta>
- [leftO (translate-pattern-matching' translate leftP)
- rightO (translate-pattern-matching' translate rightP)]
- (wrap ($_ r.then
- leftO
- rightO)))
-
- (^code ("lux case alt" (~ leftP) (~ rightP)))
- (do macro.Monad<Meta>
- [leftO (translate-pattern-matching' translate leftP)
- rightO (translate-pattern-matching' translate rightP)]
- (wrap (r.try ($_ r.then
- save-cursor!
- leftO)
- #.None
- (#.Some (pm-catch ($_ r.then
- restore-cursor!
- rightO)))
- #.None)))
-
- _
- (lang.throw Unrecognized-Path (%code pathP))
- ))
-
-(def: (translate-pattern-matching translate pathP)
- (-> (-> Synthesis (Meta Expression)) Path (Meta Expression))
- (do macro.Monad<Meta>
- [pattern-matching! (translate-pattern-matching' translate pathP)]
- (wrap (r.try pattern-matching!
- #.None
- (#.Some (pm-catch (r.stop (r.string "Invalid expression for pattern-matching."))))
- #.None))))
-
-(def: (initialize-pattern-matching! stack-init)
- (-> Expression Expression)
- ($_ r.then
- (r.set! $cursor (r.list (list stack-init)))
- (r.set! $savepoint (r.list (list)))))
-
-(def: #export (translate-case translate valueS pathP)
- (-> (-> Synthesis (Meta Expression)) Synthesis Path (Meta Expression))
- (do macro.Monad<Meta>
- [valueO (translate valueS)
- pattern-matching! (translate-pattern-matching translate pathP)]
- (wrap (r.block
- ($_ r.then
- (initialize-pattern-matching! valueO)
- pattern-matching!)))))
diff --git a/new-luxc/source/luxc/lang/translation/r/expression.jvm.lux b/new-luxc/source/luxc/lang/translation/r/expression.jvm.lux
deleted file mode 100644
index 3c41fbe63..000000000
--- a/new-luxc/source/luxc/lang/translation/r/expression.jvm.lux
+++ /dev/null
@@ -1,88 +0,0 @@
-(.module:
- lux
- (lux (control [monad #+ do]
- ["ex" exception #+ exception:]
- ["p" parser])
- (data ["e" error]
- text/format)
- [macro]
- (macro ["s" syntax]))
- (luxc ["&" lang]
- (lang [".L" variable #+ Variable Register]
- [".L" extension]
- ["ls" synthesis]
- (host [r #+ Expression])))
- [//]
- (// [".T" runtime]
- [".T" primitive]
- [".T" structure]
- [".T" reference]
- [".T" function]
- [".T" case]
- [".T" procedure])
- )
-
-(template [<name>]
- [(exception: #export (<name> {message Text})
- message)]
-
- [Invalid-Function-Syntax]
- [Unrecognized-Synthesis]
- )
-
-(def: #export (translate synthesis)
- (-> ls.Synthesis (Meta Expression))
- (case synthesis
- (^code [])
- (:: macro.Monad<Meta> wrap runtimeT.unit)
-
- (^template [<tag> <generator>]
- [_ (<tag> value)]
- (<generator> value))
- ([#.Bit primitiveT.translate-bit]
- [#.Nat primitiveT.translate-nat]
- [#.Int primitiveT.translate-int]
- [#.Rev primitiveT.translate-rev]
- [#.Frac primitiveT.translate-frac]
- [#.Text primitiveT.translate-text])
-
- (^code ((~ [_ (#.Nat tag)]) (~ [_ (#.Bit last?)]) (~ valueS)))
- (structureT.translate-variant translate tag last? valueS)
-
- (^code [(~ singleton)])
- (translate singleton)
-
- (^code [(~+ members)])
- (structureT.translate-tuple translate members)
-
- (^ [_ (#.Form (list [_ (#.Int var)]))])
- (referenceT.translate-variable var)
-
- [_ (#.Identifier definition)]
- (referenceT.translate-definition definition)
-
- (^code ("lux let" (~ [_ (#.Nat register)]) (~ inputS) (~ exprS)))
- (caseT.translate-let translate register inputS exprS)
-
- (^code ("lux case" (~ inputS) (~ pathPS)))
- (caseT.translate-case translate inputS pathPS)
-
- (^code ("lux function" (~ [_ (#.Nat arity)]) [(~+ environment)] (~ bodyS)))
- (case (s.run environment (p.some s.int))
- (#e.Success environment)
- (functionT.translate-function translate environment arity bodyS)
-
- _
- (&.throw Invalid-Function-Syntax (%code synthesis)))
-
- (^code ("lux call" (~ functionS) (~+ argsS)))
- (functionT.translate-apply translate functionS argsS)
-
- (^code ((~ [_ (#.Text procedure)]) (~+ argsS)))
- (procedureT.translate-procedure translate procedure argsS)
- ## (do macro.Monad<Meta>
- ## [translation (extensionL.find-translation procedure)]
- ## (translation argsS))
-
- _
- (&.throw Unrecognized-Synthesis (%code synthesis))))
diff --git a/new-luxc/source/luxc/lang/translation/r/function.jvm.lux b/new-luxc/source/luxc/lang/translation/r/function.jvm.lux
deleted file mode 100644
index f39a5e1a2..000000000
--- a/new-luxc/source/luxc/lang/translation/r/function.jvm.lux
+++ /dev/null
@@ -1,94 +0,0 @@
-(.module:
- lux
- (lux (control [monad #+ do]
- pipe)
- (data [product]
- [text]
- text/format
- (coll [list "list/" Functor<List> Fold<List>]))
- [macro])
- (luxc ["&" lang]
- (lang ["ls" synthesis]
- [".L" variable #+ Variable]
- (host [r #+ Expression @@])))
- [//]
- (// [".T" reference]))
-
-(def: #export (translate-apply translate functionS argsS+)
- (-> (-> ls.Synthesis (Meta Expression)) ls.Synthesis (List ls.Synthesis) (Meta Expression))
- (do {@ macro.Monad<Meta>}
- [functionO (translate functionS)
- argsO+ (monad.map @ translate argsS+)]
- (wrap (r.apply argsO+ functionO))))
-
-(def: $curried (r.var "curried"))
-
-(def: (input-declaration register)
- (r.set! (referenceT.variable (inc register))
- (|> (@@ $curried) (r.nth (|> register inc .int r.int)))))
-
-(def: (with-closure function-name inits function-definition)
- (-> Text (List Expression) Expression (Meta Expression))
- (let [$closure (r.var (format function-name "___CLOSURE"))]
- (case inits
- #.Nil
- (do macro.Monad<Meta>
- [_ (//.save function-definition)]
- (wrap (r.global function-name)))
-
- _
- (do macro.Monad<Meta>
- [_ (//.save (r.set! $closure
- (r.function (|> (list.enumerate inits)
- (list/map (|>> product.left referenceT.closure)))
- ($_ r.then
- function-definition
- (r.global function-name)))))]
- (wrap (r.apply inits (@@ $closure)))))))
-
-(def: #export (translate-function translate env arity bodyS)
- (-> (-> ls.Synthesis (Meta Expression))
- (List Variable) ls.Arity ls.Synthesis
- (Meta Expression))
- (do {@ macro.Monad<Meta>}
- [[function-name bodyO] (//.with-sub-context
- (do @
- [function-name //.context]
- (//.with-anchor [function-name +1]
- (translate bodyS))))
- closureO+ (monad.map @ referenceT.translate-variable env)
- #let [arityO (|> arity .int r.int)
- $num_args (r.var "num_args")
- $function (r.var function-name)
- var-args (r.code (format "list" (r.expression (@@ r.var-args))))
- apply-poly (function (_ args func)
- (r.apply (list func args) (r.global "do.call")))]]
- (with-closure function-name closureO+
- (r.set! $function
- (r.function (list r.var-args)
- ($_ r.then
- (r.set! $curried var-args)
- (r.set! $num_args (r.length (@@ $curried)))
- (r.cond (list [(|> (@@ $num_args) (r.= arityO))
- ($_ r.then
- (r.set! (referenceT.variable +0) (@@ $function))
- (|> (list.n/range +0 (dec arity))
- (list/map input-declaration)
- (list/fold r.then bodyO)))]
- [(|> (@@ $num_args) (r.> arityO))
- (let [arity-args (r.slice (r.int 1) arityO (@@ $curried))
- output-func-args (r.slice (|> arityO (r.+ (r.int 1)))
- (@@ $num_args)
- (@@ $curried))]
- (|> (@@ $function)
- (apply-poly arity-args)
- (apply-poly output-func-args)))])
- ## (|> (@@ $num_args) (r.< arityO))
- (let [$missing (r.var "missing")]
- (r.function (list r.var-args)
- ($_ r.then
- (r.set! $missing var-args)
- (|> (@@ $function)
- (apply-poly (r.apply (list (@@ $curried) (@@ $missing))
- (r.global "append"))))))))))))
- ))
diff --git a/new-luxc/source/luxc/lang/translation/r/loop.jvm.lux b/new-luxc/source/luxc/lang/translation/r/loop.jvm.lux
deleted file mode 100644
index f1197e5ce..000000000
--- a/new-luxc/source/luxc/lang/translation/r/loop.jvm.lux
+++ /dev/null
@@ -1,37 +0,0 @@
-(.module:
- lux
- (lux (control [monad #+ do])
- (data [text]
- text/format
- (coll [list "list/" Functor<List>]))
- [macro])
- (luxc [lang]
- (lang ["ls" synthesis]
- (host [r #+ Expression @@])))
- [//]
- (// [".T" reference]))
-
-(def: #export (translate-loop translate offset initsS+ bodyS)
- (-> (-> ls.Synthesis (Meta Expression)) Nat (List ls.Synthesis) ls.Synthesis
- (Meta Expression))
- (do {@ macro.Monad<Meta>}
- [loop-name (|> (macro.gensym "loop")
- (:: @ map (|>> %code lang.normalize-name)))
- initsO+ (monad.map @ translate initsS+)
- bodyO (//.with-anchor [loop-name offset]
- (translate bodyS))
- #let [$loop-name (r.var loop-name)
- @loop-name (@@ $loop-name)]
- _ (//.save (r.set! $loop-name
- (r.function (|> (list.n/range +0 (dec (list.size initsS+)))
- (list/map (|>> (n/+ offset) referenceT.variable)))
- bodyO)))]
- (wrap (r.apply initsO+ @loop-name))))
-
-(def: #export (translate-recur translate argsS+)
- (-> (-> ls.Synthesis (Meta Expression)) (List ls.Synthesis)
- (Meta Expression))
- (do {@ macro.Monad<Meta>}
- [[loop-name offset] //.anchor
- argsO+ (monad.map @ translate argsS+)]
- (wrap (r.apply argsO+ (r.global loop-name)))))
diff --git a/new-luxc/source/luxc/lang/translation/r/primitive.jvm.lux b/new-luxc/source/luxc/lang/translation/r/primitive.jvm.lux
deleted file mode 100644
index 8bc7da848..000000000
--- a/new-luxc/source/luxc/lang/translation/r/primitive.jvm.lux
+++ /dev/null
@@ -1,22 +0,0 @@
-(.module:
- lux
- (lux [macro "meta/" Monad<Meta>])
- (luxc (lang (host [r #+ Expression])))
- [//]
- (// [".T" runtime]))
-
-(def: #export translate-bit
- (-> Bit (Meta Expression))
- (|>> r.bool meta/wrap))
-
-(def: #export translate-int
- (-> Int (Meta Expression))
- (|>> runtimeT.int meta/wrap))
-
-(def: #export translate-frac
- (-> Frac (Meta Expression))
- (|>> r.float meta/wrap))
-
-(def: #export translate-text
- (-> Text (Meta Expression))
- (|>> r.string meta/wrap))
diff --git a/new-luxc/source/luxc/lang/translation/r/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/r/procedure/common.jvm.lux
deleted file mode 100644
index 85ccd90dc..000000000
--- a/new-luxc/source/luxc/lang/translation/r/procedure/common.jvm.lux
+++ /dev/null
@@ -1,339 +0,0 @@
-(.module:
- lux
- (lux (control [monad #+ do]
- ["ex" exception #+ exception:]
- ["p" parser])
- (data ["e" error]
- [text]
- text/format
- [number]
- (coll [list "list/" Functor<List>]
- (dictionary ["dict" unordered #+ Dict])))
- [macro #+ with-gensyms]
- (macro [code]
- ["s" syntax #+ syntax:])
- [host])
- (luxc ["&" lang]
- (lang ["la" analysis]
- ["ls" synthesis]
- (host [r #+ Expression])))
- [///]
- (/// [".T" runtime]
- [".T" case]
- [".T" function]
- [".T" loop]))
-
-## [Types]
-(type: #export Translator
- (-> ls.Synthesis (Meta Expression)))
-
-(type: #export Proc
- (-> Translator (List ls.Synthesis) (Meta Expression)))
-
-(type: #export Bundle
- (Dict Text Proc))
-
-(syntax: (Vector {size s.nat} elemT)
- (wrap (list (` [(~+ (list.repeat size elemT))]))))
-
-(type: #export Nullary (-> (Vector +0 Expression) Expression))
-(type: #export Unary (-> (Vector +1 Expression) Expression))
-(type: #export Binary (-> (Vector +2 Expression) Expression))
-(type: #export Trinary (-> (Vector +3 Expression) Expression))
-(type: #export Variadic (-> (List Expression) Expression))
-
-## [Utils]
-(def: #export (install name unnamed)
- (-> Text (-> Text Proc)
- (-> Bundle Bundle))
- (dict.put name (unnamed name)))
-
-(def: #export (prefix prefix bundle)
- (-> Text Bundle Bundle)
- (|> bundle
- dict.entries
- (list/map (function (_ [key val]) [(format prefix " " key) val]))
- (dict.from-list text.Hash<Text>)))
-
-(def: (wrong-arity proc expected actual)
- (-> Text Nat Nat Text)
- (format "Wrong number of arguments for " (%t proc) "\n"
- "Expected: " (|> expected .int %i) "\n"
- " Actual: " (|> actual .int %i)))
-
-(syntax: (arity: {name s.local-identifier} {arity s.nat})
- (with-gensyms [g!_ g!proc g!name g!translate g!inputs]
- (do {@ macro.monad}
- [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))]
- (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!proc))
- (-> (-> (..Vector (~ (code.nat arity)) Expression) Expression)
- (-> Text ..Proc))
- (function ((~ g!_) (~ g!name))
- (function ((~ g!_) (~ g!translate) (~ g!inputs))
- (case (~ g!inputs)
- (^ (list (~+ g!input+)))
- (do macro.Monad<Meta>
- [(~+ (|> g!input+
- (list/map (function (_ g!input)
- (list g!input (` ((~ g!translate) (~ g!input))))))
- list.concat))]
- ((~' wrap) ((~ g!proc) [(~+ g!input+)])))
-
- (~' _)
- (macro.fail (wrong-arity (~ g!name) +1 (list.size (~ g!inputs))))))))))))))
-
-(arity: nullary +0)
-(arity: unary +1)
-(arity: binary +2)
-(arity: trinary +3)
-
-(def: #export (variadic proc)
- (-> Variadic (-> Text Proc))
- (function (_ proc-name)
- (function (_ translate inputsS)
- (do {@ macro.Monad<Meta>}
- [inputsI (monad.map @ translate inputsS)]
- (wrap (proc inputsI))))))
-
-## [Procedures]
-## [[Lux]]
-(def: (lux//is [leftO rightO])
- Binary
- (r.apply (list leftO rightO)
- (r.global "identical")))
-
-(def: (lux//if [testO thenO elseO])
- Trinary
- (caseT.translate-if testO thenO elseO))
-
-(def: (lux//try riskyO)
- Unary
- (runtimeT.lux//try riskyO))
-
-(exception: #export (Wrong-Syntax {message Text})
- message)
-
-(def: #export (wrong-syntax procedure args)
- (-> Text (List ls.Synthesis) Text)
- (format "Procedure: " procedure "\n"
- "Arguments: " (%code (code.tuple args))))
-
-(def: lux//loop
- (-> Text Proc)
- (function (_ proc-name)
- (function (_ translate inputsS)
- (case (s.run inputsS ($_ p.seq s.nat (s.tuple (p.many s.any)) s.any))
- (#e.Success [offset initsS+ bodyS])
- (loopT.translate-loop translate offset initsS+ bodyS)
-
- (#e.Error error)
- (&.throw Wrong-Syntax (wrong-syntax proc-name inputsS)))
- )))
-
-(def: lux//recur
- (-> Text Proc)
- (function (_ proc-name)
- (function (_ translate inputsS)
- (loopT.translate-recur translate inputsS))))
-
-(def: lux-procs
- Bundle
- (|> (dict.new text.Hash<Text>)
- (install "is" (binary lux//is))
- (install "try" (unary lux//try))
- (install "if" (trinary lux//if))
- (install "loop" lux//loop)
- (install "recur" lux//recur)
- ))
-
-## [[Bits]]
-(template [<name> <op>]
- [(def: (<name> [subjectO paramO])
- Binary
- (<op> paramO subjectO))]
-
- [bit//and runtimeT.bit//and]
- [bit//or runtimeT.bit//or]
- [bit//xor runtimeT.bit//xor]
- )
-
-(template [<name> <op>]
- [(def: (<name> [subjectO paramO])
- Binary
- (<op> (runtimeT.int64-low paramO) subjectO))]
-
- [bit//left-shift runtimeT.bit//left-shift]
- [bit//arithmetic-right-shift runtimeT.bit//arithmetic-right-shift]
- [bit//logical-right-shift runtimeT.bit//logical-right-shift]
- )
-
-(def: bit-procs
- Bundle
- (<| (prefix "bit")
- (|> (dict.new text.Hash<Text>)
- (install "and" (binary bit//and))
- (install "or" (binary bit//or))
- (install "xor" (binary bit//xor))
- (install "left-shift" (binary bit//left-shift))
- (install "logical-right-shift" (binary bit//logical-right-shift))
- (install "arithmetic-right-shift" (binary bit//arithmetic-right-shift))
- )))
-
-## [[Numbers]]
-(host.import: java/lang/Double
- (#static MIN_VALUE Double)
- (#static MAX_VALUE Double))
-
-(template [<name> <const> <encode>]
- [(def: (<name> _)
- Nullary
- (<encode> <const>))]
-
- [frac//smallest Double::MIN_VALUE r.float]
- [frac//min (f/* -1.0 Double::MAX_VALUE) r.float]
- [frac//max Double::MAX_VALUE r.float]
- )
-
-(template [<name> <op>]
- [(def: (<name> [subjectO paramO])
- Binary
- (|> subjectO (<op> paramO)))]
-
- [int//add runtimeT.int//+]
- [int//sub runtimeT.int//-]
- [int//mul runtimeT.int//*]
- [int//div runtimeT.int///]
- [int//rem runtimeT.int//%]
- )
-
-(template [<name> <op>]
- [(def: (<name> [subjectO paramO])
- Binary
- (<op> paramO subjectO))]
-
- [frac//add r.+]
- [frac//sub r.-]
- [frac//mul r.*]
- [frac//div r./]
- [frac//rem r.%%]
- [frac//= r.=]
- [frac//< r.<]
-
- [text//= r.=]
- [text//< r.<]
- )
-
-(template [<name> <cmp>]
- [(def: (<name> [subjectO paramO])
- Binary
- (<cmp> paramO subjectO))]
-
- [int//= runtimeT.int//=]
- [int//< runtimeT.int//<]
- )
-
-(def: (apply1 func)
- (-> Expression (-> Expression Expression))
- (function (_ value)
- (r.apply (list value) func)))
-
-(def: int//char (|>> runtimeT.int64-low (apply1 (r.global "intToUtf8"))))
-
-(def: int-procs
- Bundle
- (<| (prefix "int")
- (|> (dict.new text.Hash<Text>)
- (install "+" (binary int//add))
- (install "-" (binary int//sub))
- (install "*" (binary int//mul))
- (install "/" (binary int//div))
- (install "%" (binary int//rem))
- (install "=" (binary int//=))
- (install "<" (binary int//<))
- (install "to-frac" (unary runtimeT.int//to-float))
- (install "char" (unary int//char)))))
-
-(def: (frac//encode value)
- (-> Expression Expression)
- (r.apply (list (r.string "%f") value) (r.global "sprintf")))
-
-(def: frac-procs
- Bundle
- (<| (prefix "frac")
- (|> (dict.new text.Hash<Text>)
- (install "+" (binary frac//add))
- (install "-" (binary frac//sub))
- (install "*" (binary frac//mul))
- (install "/" (binary frac//div))
- (install "%" (binary frac//rem))
- (install "=" (binary frac//=))
- (install "<" (binary frac//<))
- (install "smallest" (nullary frac//smallest))
- (install "min" (nullary frac//min))
- (install "max" (nullary frac//max))
- (install "to-int" (unary (apply1 (r.global "as.integer"))))
- (install "encode" (unary frac//encode))
- (install "decode" (unary runtimeT.frac//decode)))))
-
-## [[Text]]
-(def: (text//concat [subjectO paramO])
- Binary
- (r.apply (list subjectO paramO) (r.global "paste0")))
-
-(def: (text//char [subjectO paramO])
- Binary
- (runtimeT.text//char subjectO paramO))
-
-(def: (text//clip [subjectO paramO extraO])
- Trinary
- (runtimeT.text//clip subjectO paramO extraO))
-
-(def: (text//index [textO partO startO])
- Trinary
- (runtimeT.text//index textO partO startO))
-
-(def: text-procs
- Bundle
- (<| (prefix "text")
- (|> (dict.new text.Hash<Text>)
- (install "=" (binary text//=))
- (install "<" (binary text//<))
- (install "concat" (binary text//concat))
- (install "index" (trinary text//index))
- (install "size" (unary (|>> (apply1 (r.global "nchar")) runtimeT.int//from-float)))
- (install "char" (binary text//char))
- (install "clip" (trinary text//clip))
- )))
-
-## [[IO]]
-(def: (io//exit input)
- Unary
- (r.apply-kw (list)
- (list ["status" (runtimeT.int//to-float input)])
- (r.global "quit")))
-
-(def: (void code)
- (-> Expression Expression)
- (r.block (r.then code runtimeT.unit)))
-
-(def: io-procs
- Bundle
- (<| (prefix "io")
- (|> (dict.new text.Hash<Text>)
- (install "log" (unary (|>> r.print ..void)))
- (install "error" (unary r.stop))
- (install "exit" (unary io//exit))
- (install "current-time" (nullary (function (_ _)
- (runtimeT.io//current-time! runtimeT.unit)))))))
-
-## [Bundles]
-(def: #export procedures
- Bundle
- (<| (prefix "lux")
- (|> lux-procs
- (dict.merge bit-procs)
- (dict.merge int-procs)
- (dict.merge frac-procs)
- (dict.merge text-procs)
- (dict.merge io-procs)
- )))
diff --git a/new-luxc/source/luxc/lang/translation/r/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/translation/r/procedure/host.jvm.lux
deleted file mode 100644
index 3bd33955f..000000000
--- a/new-luxc/source/luxc/lang/translation/r/procedure/host.jvm.lux
+++ /dev/null
@@ -1,89 +0,0 @@
-(.module:
- lux
- (lux (control [monad #+ do])
- (data [text]
- text/format
- (coll [list "list/" Functor<List>]
- (dictionary ["dict" unordered #+ Dict])))
- [macro "macro/" Monad<Meta>])
- (luxc ["&" lang]
- (lang ["la" analysis]
- ["ls" synthesis]
- (host [ruby #+ Ruby Expression Statement])))
- [///]
- (/// [".T" runtime])
- (// ["@" common]))
-
-## (template [<name> <lua>]
-## [(def: (<name> _) @.Nullary <lua>)]
-
-## [lua//nil "nil"]
-## [lua//table "{}"]
-## )
-
-## (def: (lua//global proc translate inputs)
-## (-> Text @.Proc)
-## (case inputs
-## (^ (list [_ (#.Text name)]))
-## (do macro.Monad<Meta>
-## []
-## (wrap name))
-
-## _
-## (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))
-
-## (def: (lua//call proc translate inputs)
-## (-> Text @.Proc)
-## (case inputs
-## (^ (list& functionS argsS+))
-## (do {@ macro.Monad<Meta>}
-## [functionO (translate functionS)
-## argsO+ (monad.map @ translate argsS+)]
-## (wrap (lua.apply functionO argsO+)))
-
-## _
-## (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))
-
-## (def: lua-procs
-## @.Bundle
-## (|> (dict.new text.Hash<Text>)
-## (@.install "nil" (@.nullary lua//nil))
-## (@.install "table" (@.nullary lua//table))
-## (@.install "global" lua//global)
-## (@.install "call" lua//call)))
-
-## (def: (table//call proc translate inputs)
-## (-> Text @.Proc)
-## (case inputs
-## (^ (list& tableS [_ (#.Text field)] argsS+))
-## (do {@ macro.Monad<Meta>}
-## [tableO (translate tableS)
-## argsO+ (monad.map @ translate argsS+)]
-## (wrap (lua.method field tableO argsO+)))
-
-## _
-## (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))
-
-## (def: (table//get [fieldO tableO])
-## @.Binary
-## (runtimeT.lua//get tableO fieldO))
-
-## (def: (table//set [fieldO valueO tableO])
-## @.Trinary
-## (runtimeT.lua//set tableO fieldO valueO))
-
-## (def: table-procs
-## @.Bundle
-## (<| (@.prefix "table")
-## (|> (dict.new text.Hash<Text>)
-## (@.install "call" table//call)
-## (@.install "get" (@.binary table//get))
-## (@.install "set" (@.trinary table//set)))))
-
-(def: #export procedures
- @.Bundle
- (<| (@.prefix "lua")
- (dict.new text.Hash<Text>)
- ## (|> lua-procs
- ## (dict.merge table-procs))
- ))
diff --git a/new-luxc/source/luxc/lang/translation/r/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/r/reference.jvm.lux
deleted file mode 100644
index 7de1c74ee..000000000
--- a/new-luxc/source/luxc/lang/translation/r/reference.jvm.lux
+++ /dev/null
@@ -1,42 +0,0 @@
-(.module:
- lux
- (lux [macro]
- (data [text]
- text/format))
- (luxc ["&" lang]
- (lang [".L" variable #+ Variable Register]
- (host [r #+ Expression SVar @@])))
- [//]
- (// [".T" runtime]))
-
-(template [<register> <translation> <prefix>]
- [(def: #export (<register> register)
- (-> Register SVar)
- (r.var (format <prefix> (%i (.int register)))))
-
- (def: #export (<translation> register)
- (-> Register (Meta Expression))
- (:: macro.Monad<Meta> wrap (@@ (<register> register))))]
-
- [closure translate-captured "c"]
- [variable translate-local "v"])
-
-(def: #export (local var)
- (-> Variable SVar)
- (if (variableL.captured? var)
- (closure (variableL.captured-register var))
- (variable (.nat var))))
-
-(def: #export (translate-variable var)
- (-> Variable (Meta Expression))
- (if (variableL.captured? var)
- (translate-captured (variableL.captured-register var))
- (translate-local (.nat var))))
-
-(def: #export global
- (-> Name SVar)
- (|>> //.definition-name r.var))
-
-(def: #export (translate-definition name)
- (-> Name (Meta Expression))
- (:: macro.Monad<Meta> wrap (@@ (global name))))
diff --git a/new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux
deleted file mode 100644
index d641041d2..000000000
--- a/new-luxc/source/luxc/lang/translation/r/runtime.jvm.lux
+++ /dev/null
@@ -1,802 +0,0 @@
-(.module:
- lux
- (lux (control ["p" parser "p/" Monad<Parser>]
- [monad #+ do])
- (data [bit]
- [number (#+ hex) ("int/" Interval<Int>)]
- text/format
- (coll [list "list/" Monad<List>]))
- [macro]
- (macro [code]
- ["s" syntax #+ syntax:])
- [io #+ Process])
- [//]
- (luxc [lang]
- (lang (host [r #+ SVar Expression @@]))))
-
-(def: prefix Text "LuxRuntime")
-
-(def: #export unit Expression (r.string //.unit))
-
-(def: full-32 (hex "+FFFFFFFF"))
-(def: half-32 (hex "+7FFFFFFF"))
-(def: post-32 (hex "+100000000"))
-
-(def: (cap-32 input)
- (-> Nat Int)
- (cond (n/> full-32 input)
- (|> input (bit.and full-32) cap-32)
-
- (n/> half-32 input)
- (|> post-32 (n/- input) .int (i/* -1))
-
- ## else
- (.int input)))
-
-(def: high-32 (bit.logical-right-shift +32))
-(def: low-32 (|>> (bit.and (hex "+FFFFFFFF"))))
-
-(def: #export (int value)
- (-> Int Expression)
- (let [value (.nat value)
- high (|> value ..high-32 cap-32)
- low (|> value ..low-32 cap-32)]
- (r.named-list (list [//.int-high-field (r.int high)]
- [//.int-low-field (r.int low)]))))
-
-(def: (flag value)
- (-> Bit Expression)
- (if value
- (r.string "")
- r.null))
-
-(def: (variant' tag last? value)
- (-> Expression Expression Expression Expression)
- (r.named-list (list [//.variant-tag-field tag]
- [//.variant-flag-field last?]
- [//.variant-value-field value])))
-
-(def: #export (variant tag last? value)
- (-> Nat Bit Expression Expression)
- (variant' (r.int (.int tag))
- (flag last?)
- value))
-
-(def: #export none
- Expression
- (variant +0 #0 unit))
-
-(def: #export some
- (-> Expression Expression)
- (variant +1 #1))
-
-(def: #export left
- (-> Expression Expression)
- (variant +0 #0))
-
-(def: #export right
- (-> Expression Expression)
- (variant +1 #1))
-
-(type: Runtime Expression)
-
-(def: declaration
- (s.Syntax [Text (List Text)])
- (p.either (p.seq s.local-identifier (p/wrap (list)))
- (s.form (p.seq s.local-identifier (p.some s.local-identifier)))))
-
-(syntax: (runtime: {[name args] declaration}
- definition)
- (let [implementation (code.local-identifier (format "@@" name))
- runtime (format prefix "__" (lang.normalize-name name))
- $runtime (` (r.var (~ (code.text runtime))))
- @runtime (` (@@ (~ $runtime)))
- argsC+ (list/map code.local-identifier args)
- argsLC+ (list/map (|>> lang.normalize-name (format "LRV__") code.text (~) (r.var) (`))
- args)
- declaration (` ((~ (code.local-identifier name))
- (~+ argsC+)))
- type (` (-> (~+ (list.repeat (list.size argsC+) (` r.Expression)))
- r.Expression))]
- (wrap (list (` (def: (~' #export) (~ declaration)
- (~ type)
- (~ (case argsC+
- #.Nil
- @runtime
-
- _
- (` (r.apply (list (~+ argsC+)) (~ @runtime)))))))
- (` (def: (~ implementation)
- r.Expression
- (~ (case argsC+
- #.Nil
- (` (r.set! (~ $runtime) (~ definition)))
-
- _
- (` (let [(~+ (|> (list.zip2 argsC+ argsLC+)
- (list/map (function (_ [left right])
- (list left right)))
- list/join))]
- (r.set! (~ $runtime)
- (r.function (list (~+ argsLC+))
- (~ definition)))))))))))))
-
-(syntax: #export (with-vars {vars (s.tuple (p.many s.local-identifier))}
- body)
- (wrap (list (` (let [(~+ (|> vars
- (list/map (function (_ var)
- (list (code.local-identifier var)
- (` (r.var (~ (code.text (format "LRV__" (lang.normalize-name var)))))))))
- list/join))]
- (~ body))))))
-
-(def: high-shift (r.bit-shl (r.int 32)))
-
-(runtime: f2^32 (|> (r.int 2) (r.** (r.int 32))))
-(runtime: f2^63 (|> (r.int 2) (r.** (r.int 63))))
-
-(def: (as-double value)
- (-> Expression Expression)
- (r.apply (list value) (r.global "as.double")))
-
-(def: (as-integer value)
- (-> Expression Expression)
- (r.apply (list value) (r.global "as.integer")))
-
-(runtime: (int//unsigned-low input)
- (with-vars [low]
- ($_ r.then
- (r.set! low (|> (@@ input) (r.nth (r.string //.int-low-field))))
- (r.if (|> (@@ low) (r.>= (r.int 0)))
- (@@ low)
- (|> (@@ low) (r.+ f2^32))))))
-
-(runtime: (int//to-float input)
- (let [high (|> (@@ input)
- (r.nth (r.string //.int-high-field))
- high-shift)
- low (|> (@@ input)
- int//unsigned-low)]
- (|> high (r.+ low) as-double)))
-
-(runtime: (int//new high low)
- (r.named-list (list [//.int-high-field (as-integer (@@ high))]
- [//.int-low-field (as-integer (@@ low))])))
-
-(template [<name> <value>]
- [(runtime: <name>
- (..int <value>))]
-
- [int//zero 0]
- [int//one 1]
- [int//min int/bottom]
- [int//max int/top]
- )
-
-(def: #export int64-high (r.nth (r.string //.int-high-field)))
-(def: #export int64-low (r.nth (r.string //.int-low-field)))
-
-(runtime: (bit//not input)
- (int//new (|> (@@ input) int64-high r.bit-not)
- (|> (@@ input) int64-low r.bit-not)))
-
-(runtime: (int//+ param subject)
- (with-vars [sH sL pH pL
- x00 x16 x32 x48]
- ($_ r.then
- (r.set! sH (|> (@@ subject) int64-high))
- (r.set! sL (|> (@@ subject) int64-low))
- (r.set! pH (|> (@@ param) int64-high))
- (r.set! pL (|> (@@ param) int64-low))
- (let [bits16 (r.code "0xFFFF")
- move-top-16 (r.bit-shl (r.int 16))
- top-16 (r.bit-ushr (r.int 16))
- bottom-16 (r.bit-and bits16)
- split-16 (function (_ source)
- [(|> source top-16)
- (|> source bottom-16)])
- split-int (function (_ high low)
- [(split-16 high)
- (split-16 low)])
-
- [[s48 s32] [s16 s00]] (split-int (@@ sH) (@@ sL))
- [[p48 p32] [p16 p00]] (split-int (@@ pH) (@@ pL))
- new-half (function (_ top bottom)
- (|> top bottom-16 move-top-16
- (r.bit-or (bottom-16 bottom))))]
- ($_ r.then
- (r.set! x00 (|> s00 (r.+ p00)))
- (r.set! x16 (|> (@@ x00) top-16 (r.+ s16) (r.+ p16)))
- (r.set! x32 (|> (@@ x16) top-16 (r.+ s32) (r.+ p32)))
- (r.set! x48 (|> (@@ x32) top-16 (r.+ s48) (r.+ p48)))
- (int//new (new-half (@@ x48) (@@ x32))
- (new-half (@@ x16) (@@ x00))))))))
-
-(runtime: (int//= reference sample)
- (let [n/a? (function (_ value)
- (r.apply (list value) (r.global "is.na")))
- isTRUE? (function (_ value)
- (r.apply (list value) (r.global "isTRUE")))
- comparison (: (-> (-> Expression Expression) Expression)
- (function (_ field)
- (|> (|> (field (@@ sample)) (r.= (field (@@ reference))))
- (r.or (|> (n/a? (field (@@ sample)))
- (r.and (n/a? (field (@@ reference)))))))))]
- (|> (comparison int64-high)
- (r.and (comparison int64-low))
- isTRUE?)))
-
-(runtime: (int//negate input)
- (r.if (|> (@@ input) (int//= int//min))
- int//min
- (|> (@@ input) bit//not (int//+ int//one))))
-
-(runtime: int//-one
- (int//negate int//one))
-
-(runtime: (int//- param subject)
- (int//+ (int//negate (@@ param)) (@@ subject)))
-
-(runtime: (int//< reference sample)
- (with-vars [r-? s-?]
- ($_ r.then
- (r.set! s-? (|> (@@ sample) int64-high (r.< (r.int 0))))
- (r.set! r-? (|> (@@ reference) int64-high (r.< (r.int 0))))
- (|> (|> (@@ s-?) (r.and (r.not (@@ r-?))))
- (r.or (|> (r.not (@@ s-?)) (r.and (@@ r-?)) r.not))
- (r.or (|> (@@ sample)
- (int//- (@@ reference))
- int64-high
- (r.< (r.int 0))))))))
-
-(runtime: (int//from-float input)
- (r.cond (list [(r.apply (list (@@ input)) (r.global "is.nan"))
- int//zero]
- [(|> (@@ input) (r.<= (r.negate f2^63)))
- int//min]
- [(|> (@@ input) (r.+ (r.float 1.0)) (r.>= f2^63))
- int//max]
- [(|> (@@ input) (r.< (r.float 0.0)))
- (|> (@@ input) r.negate int//from-float int//negate)])
- (int//new (|> (@@ input) (r./ f2^32))
- (|> (@@ input) (r.%% f2^32)))))
-
-(runtime: (int//* param subject)
- (with-vars [sH sL pH pL
- x00 x16 x32 x48]
- ($_ r.then
- (r.set! sH (|> (@@ subject) int64-high))
- (r.set! pH (|> (@@ param) int64-high))
- (let [negative-subject? (|> (@@ sH) (r.< (r.int 0)))
- negative-param? (|> (@@ pH) (r.< (r.int 0)))]
- (r.cond (list [negative-subject?
- (r.if negative-param?
- (int//* (int//negate (@@ param))
- (int//negate (@@ subject)))
- (int//negate (int//* (@@ param)
- (int//negate (@@ subject)))))]
-
- [negative-param?
- (int//negate (int//* (int//negate (@@ param))
- (@@ subject)))])
- ($_ r.then
- (r.set! sL (|> (@@ subject) int64-low))
- (r.set! pL (|> (@@ param) int64-low))
- (let [bits16 (r.code "0xFFFF")
- move-top-16 (r.bit-shl (r.int 16))
- top-16 (r.bit-ushr (r.int 16))
- bottom-16 (r.bit-and bits16)
- split-16 (function (_ source)
- [(|> source top-16)
- (|> source bottom-16)])
- split-int (function (_ high low)
- [(split-16 high)
- (split-16 low)])
- new-half (function (_ top bottom)
- (|> top bottom-16 move-top-16
- (r.bit-or (bottom-16 bottom))))
- x16-top (|> (@@ x16) top-16)
- x32-top (|> (@@ x32) top-16)]
- (with-vars [s48 s32 s16 s00
- p48 p32 p16 p00]
- (let [[[_s48 _s32] [_s16 _s00]] (split-int (@@ sH) (@@ sL))
- [[_p48 _p32] [_p16 _p00]] (split-int (@@ pH) (@@ pL))
- set-subject-chunks! ($_ r.then (r.set! s48 _s48) (r.set! s32 _s32) (r.set! s16 _s16) (r.set! s00 _s00))
- set-param-chunks! ($_ r.then (r.set! p48 _p48) (r.set! p32 _p32) (r.set! p16 _p16) (r.set! p00 _p00))]
- ($_ r.then
- set-subject-chunks!
- set-param-chunks!
- (r.set! x00 (|> (@@ s00) (r.* (@@ p00))))
- (r.set! x16 (|> (@@ x00) top-16 (r.+ (|> (@@ s16) (r.* (@@ p00))))))
- (r.set! x32 x16-top)
- (r.set! x16 (|> (@@ x16) bottom-16 (r.+ (|> (@@ s00) (r.* (@@ p16))))))
- (r.set! x32 (|> (@@ x32) (r.+ x16-top) (r.+ (|> (@@ s32) (r.* (@@ p00))))))
- (r.set! x48 x32-top)
- (r.set! x32 (|> (@@ x32) bottom-16 (r.+ (|> (@@ s16) (r.* (@@ p16))))))
- (r.set! x48 (|> (@@ x48) (r.+ x32-top)))
- (r.set! x32 (|> (@@ x32) bottom-16 (r.+ (|> (@@ s00) (r.* (@@ p32))))))
- (r.set! x48 (|> (@@ x48) (r.+ x32-top)
- (r.+ (|> (@@ s48) (r.* (@@ p00))))
- (r.+ (|> (@@ s32) (r.* (@@ p16))))
- (r.+ (|> (@@ s16) (r.* (@@ p32))))
- (r.+ (|> (@@ s00) (r.* (@@ p48))))))
- (int//new (new-half (@@ x48) (@@ x32))
- (new-half (@@ x16) (@@ x00))))))
- )))))))
-
-(def: (limit-shift! shift)
- (-> SVar Expression)
- (r.set! shift (|> (@@ shift) (r.bit-and (r.int 63)))))
-
-(def: (no-shift-clause shift input)
- (-> SVar SVar [Expression Expression])
- [(|> (@@ shift) (r.= (r.int 0)))
- (@@ input)])
-
-(runtime: (bit//left-shift shift input)
- ($_ r.then
- (limit-shift! shift)
- (r.cond (list (no-shift-clause shift input)
- [(|> (@@ shift) (r.< (r.int 32)))
- (let [mid (|> (int64-low (@@ input)) (r.bit-ushr (|> (r.int 32) (r.- (@@ shift)))))
- high (|> (int64-high (@@ input))
- (r.bit-shl (@@ shift))
- (r.bit-or mid))
- low (|> (int64-low (@@ input))
- (r.bit-shl (@@ shift)))]
- (int//new high low))])
- (let [high (|> (int64-high (@@ input))
- (r.bit-shl (|> (@@ shift) (r.- (r.int 32)))))]
- (int//new high (r.int 0))))))
-
-(runtime: (bit//arithmetic-right-shift-32 shift input)
- (let [top-bit (|> (@@ input) (r.bit-and (r.int (hex "80000000"))))]
- (|> (@@ input)
- (r.bit-ushr (@@ shift))
- (r.bit-or top-bit))))
-
-(runtime: (bit//arithmetic-right-shift shift input)
- ($_ r.then
- (limit-shift! shift)
- (r.cond (list (no-shift-clause shift input)
- [(|> (@@ shift) (r.< (r.int 32)))
- (let [mid (|> (int64-high (@@ input)) (r.bit-shl (|> (r.int 32) (r.- (@@ shift)))))
- high (|> (int64-high (@@ input))
- (bit//arithmetic-right-shift-32 (@@ shift)))
- low (|> (int64-low (@@ input))
- (r.bit-ushr (@@ shift))
- (r.bit-or mid))]
- (int//new high low))])
- (let [low (|> (int64-high (@@ input))
- (bit//arithmetic-right-shift-32 (|> (@@ shift) (r.- (r.int 32)))))
- high (r.if (|> (int64-high (@@ input)) (r.>= (r.int 0)))
- (r.int 0)
- (r.int -1))]
- (int//new high low)))))
-
-(runtime: (int/// param subject)
- (let [negative? (|>> (int//< int//zero))
- valid-division-check [(|> (@@ param) (int//= int//zero))
- (r.stop (r.string "Cannot divide by zero!"))]
- short-circuit-check [(|> (@@ subject) (int//= int//zero))
- int//zero]]
- (r.cond (list valid-division-check
- short-circuit-check
-
- [(|> (@@ subject) (int//= int//min))
- (r.cond (list [(|> (|> (@@ param) (int//= int//one))
- (r.or (|> (@@ param) (int//= int//-one))))
- int//min]
- [(|> (@@ param) (int//= int//min))
- int//one])
- (with-vars [approximation]
- ($_ r.then
- (r.set! approximation
- (|> (@@ subject)
- (bit//arithmetic-right-shift (r.int 1))
- (int/// (@@ param))
- (bit//left-shift (r.int 1))))
- (r.if (|> (@@ approximation) (int//= int//zero))
- (r.if (negative? (@@ param))
- int//one
- int//-one)
- (let [remainder (int//- (int//* (@@ param) (@@ approximation))
- (@@ subject))]
- (|> remainder
- (int/// (@@ param))
- (int//+ (@@ approximation))))))))]
- [(|> (@@ param) (int//= int//min))
- int//zero]
-
- [(negative? (@@ subject))
- (r.if (negative? (@@ param))
- (|> (int//negate (@@ subject))
- (int/// (int//negate (@@ param))))
- (|> (int//negate (@@ subject))
- (int/// (@@ param))
- int//negate))]
-
- [(negative? (@@ param))
- (|> (@@ param)
- int//negate
- (int/// (@@ subject))
- int//negate)])
- (with-vars [result remainder approximate approximate-result log2 approximate-remainder]
- ($_ r.then
- (r.set! result int//zero)
- (r.set! remainder (@@ subject))
- (r.while (|> (|> (@@ remainder) (int//< (@@ param)))
- (r.or (|> (@@ remainder) (int//= (@@ param)))))
- (let [calc-rough-estimate (r.apply (list (|> (int//to-float (@@ remainder)) (r./ (int//to-float (@@ param)))))
- (r.global "floor"))
- calc-approximate-result (int//from-float (@@ approximate))
- calc-approximate-remainder (|> (@@ approximate-result) (int//* (@@ param)))
- delta (r.if (|> (r.float 48.0) (r.<= (@@ log2)))
- (r.float 1.0)
- (r.** (|> (@@ log2) (r.- (r.float 48.0)))
- (r.float 2.0)))]
- ($_ r.then
- (r.set! approximate (r.apply (list (r.float 1.0) calc-rough-estimate)
- (r.global "max")))
- (r.set! log2 (let [log (function (_ input)
- (r.apply (list input) (r.global "log")))]
- (r.apply (list (|> (log (r.int 2))
- (r./ (log (@@ approximate)))))
- (r.global "ceil"))))
- (r.set! approximate-result calc-approximate-result)
- (r.set! approximate-remainder calc-approximate-remainder)
- (r.while (|> (negative? (@@ approximate-remainder))
- (r.or (|> (@@ approximate-remainder) (int//< (@@ remainder)))))
- ($_ r.then
- (r.set! approximate (|> delta (r.- (@@ approximate))))
- (r.set! approximate-result calc-approximate-result)
- (r.set! approximate-remainder calc-approximate-remainder)))
- (r.set! result (|> (r.if (|> (@@ approximate-result) (int//= int//zero))
- int//one
- (@@ approximate-result))
- (int//+ (@@ result))))
- (r.set! remainder (|> (@@ remainder) (int//- (@@ approximate-remainder)))))))
- (@@ result)))
- )))
-
-(runtime: (int//% param subject)
- (let [flat (|> (@@ subject) (int/// (@@ param)) (int//* (@@ param)))]
- (|> (@@ subject) (int//- flat))))
-
-(def: runtime//int
- Runtime
- ($_ r.then
- @@int//zero
- @@int//one
- @@int//min
- @@int//max
- @@int//=
- @@int//<
- @@int//+
- @@int//-
- @@int//negate
- @@int//-one
- @@int//unsigned-low
- @@int//to-float
- @@int//*
- @@int///
- @@int//%))
-
-(runtime: (lux//try op)
- (with-vars [error value]
- (r.try ($_ r.then
- (r.set! value (r.apply (list ..unit) (@@ op)))
- (..right (@@ value)))
- #.None
- (#.Some (r.function (list error)
- (..left (r.nth (r.string "message")
- (@@ error)))))
- #.None)))
-
-(runtime: (lux//program-args program-args)
- (with-vars [inputs value]
- ($_ r.then
- (r.set! inputs ..none)
- (<| (r.for-in value (@@ program-args))
- (r.set! inputs (..some (r.list (list (@@ value) (@@ inputs))))))
- (@@ inputs))))
-
-(def: runtime//lux
- Runtime
- ($_ r.then
- @@lux//try
- @@lux//program-args))
-
-(def: current-time-float
- Expression
- (let [raw-time (r.apply (list) (r.global "Sys.time"))]
- (r.apply (list raw-time) (r.global "as.numeric"))))
-
-(runtime: (io//current-time! _)
- (|> current-time-float
- (r.* (r.float 1,000.0))
- int//from-float))
-
-(def: runtime//io
- Runtime
- ($_ r.then
- @@io//current-time!))
-
-(def: minimum-index-length
- (-> SVar Expression)
- (|>> @@ (r.+ (r.int 1))))
-
-(def: (product-element product index)
- (-> Expression Expression Expression)
- (|> product (r.nth (|> index (r.+ (r.int 1))))))
-
-(def: (product-tail product)
- (-> SVar Expression)
- (|> (@@ product) (r.nth (r.length (@@ product)))))
-
-(def: (updated-index min-length product)
- (-> Expression Expression Expression)
- (|> min-length (r.- (r.length product))))
-
-(runtime: (product//left product index)
- (let [$index_min_length (r.var "index_min_length")]
- ($_ r.then
- (r.set! $index_min_length (minimum-index-length index))
- (r.if (|> (r.length (@@ product)) (r.> (@@ $index_min_length)))
- ## No need for recursion
- (product-element (@@ product) (@@ index))
- ## Needs recursion
- (product//left (product-tail product)
- (updated-index (@@ $index_min_length) (@@ product)))))))
-
-(runtime: (product//right product index)
- (let [$index_min_length (r.var "index_min_length")]
- ($_ r.then
- (r.set! $index_min_length (minimum-index-length index))
- (r.cond (list [## Last element.
- (|> (r.length (@@ product)) (r.= (@@ $index_min_length)))
- (product-element (@@ product) (@@ index))]
- [## Needs recursion
- (|> (r.length (@@ product)) (r.< (@@ $index_min_length)))
- (product//right (product-tail product)
- (updated-index (@@ $index_min_length) (@@ product)))])
- ## Must slice
- (|> (@@ product) (r.slice-from (@@ index)))))))
-
-(runtime: (sum//get sum wanted_tag wants_last)
- (let [no-match r.null
- sum-tag (|> (@@ sum) (r.nth (r.string //.variant-tag-field)))
- sum-flag (|> (@@ sum) (r.nth (r.string //.variant-flag-field)))
- sum-value (|> (@@ sum) (r.nth (r.string //.variant-value-field)))
- is-last? (|> sum-flag (r.= (r.string "")))
- test-recursion (r.if is-last?
- ## Must recurse.
- (sum//get sum-value
- (|> (@@ wanted_tag) (r.- sum-tag))
- (@@ wants_last))
- no-match)]
- (r.cond (list [(r.= sum-tag (@@ wanted_tag))
- (r.if (r.= (@@ wants_last) sum-flag)
- sum-value
- test-recursion)]
-
- [(|> (@@ wanted_tag) (r.> sum-tag))
- test-recursion]
-
- [(|> (|> (@@ wants_last) (r.= (r.string "")))
- (r.and (|> (@@ wanted_tag) (r.< sum-tag))))
- (variant' (|> sum-tag (r.- (@@ wanted_tag))) sum-flag sum-value)])
-
- no-match)))
-
-(def: runtime//adt
- Runtime
- ($_ r.then
- @@product//left
- @@product//right
- @@sum//get
- ))
-
-(template [<name> <op>]
- [(runtime: (<name> mask input)
- (int//new (<op> (int64-high (@@ mask))
- (int64-high (@@ input)))
- (<op> (int64-low (@@ mask))
- (int64-low (@@ input)))))]
-
- [bit//and r.bit-and]
- [bit//or r.bit-or]
- [bit//xor r.bit-xor]
- )
-
-(runtime: (bit//logical-right-shift shift input)
- ($_ r.then
- (limit-shift! shift)
- (r.cond (list (no-shift-clause shift input)
- [(|> (@@ shift) (r.< (r.int 32)))
- (with-vars [$mid]
- (let [mid (|> (int64-high (@@ input)) (r.bit-shl (|> (r.int 32) (r.- (@@ shift)))))
- high (|> (int64-high (@@ input)) (r.bit-ushr (@@ shift)))
- low (|> (int64-low (@@ input))
- (r.bit-ushr (@@ shift))
- (r.bit-or (r.if (r.apply (list (@@ $mid)) (r.global "is.na"))
- (r.int 0)
- (@@ $mid))))]
- ($_ r.then
- (r.set! $mid mid)
- (int//new high low))))]
- [(|> (@@ shift) (r.= (r.int 32)))
- (let [high (int64-high (@@ input))]
- (int//new (r.int 0) high))])
- (let [low (|> (int64-high (@@ input)) (r.bit-ushr (|> (@@ shift) (r.- (r.int 32)))))]
- (int//new (r.int 0) low)))))
-
-(def: runtime//bit
- Runtime
- ($_ r.then
- @@bit//and
- @@bit//or
- @@bit//xor
- @@bit//not
- @@bit//left-shift
- @@bit//arithmetic-right-shift-32
- @@bit//arithmetic-right-shift
- @@bit//logical-right-shift
- ))
-
-(runtime: (frac//decode input)
- (with-vars [output]
- ($_ r.then
- (r.set! output (r.apply (list (@@ input)) (r.global "as.numeric")))
- (r.if (|> (@@ output) (r.= r.n/a))
- ..none
- (..some (@@ output))))))
-
-(def: runtime//frac
- Runtime
- ($_ r.then
- @@frac//decode))
-
-(def: inc (-> Expression Expression) (|>> (r.+ (r.int 1))))
-
-(template [<name> <top-cmp>]
- [(def: (<name> top value)
- (-> Expression Expression Expression)
- (|> (|> value (r.>= (r.int 0)))
- (r.and (|> value (<top-cmp> top)))))]
-
- [within? r.<]
- [up-to? r.<=]
- )
-
-(def: (text-clip start end text)
- (-> Expression Expression Expression Expression)
- (r.apply (list text start end)
- (r.global "substr")))
-
-(def: (text-length text)
- (-> Expression Expression)
- (r.apply (list text) (r.global "nchar")))
-
-(runtime: (text//index subject param start)
- (with-vars [idx startF subjectL]
- ($_ r.then
- (r.set! startF (int//to-float (@@ start)))
- (r.set! subjectL (text-length (@@ subject)))
- (r.if (|> (@@ startF) (within? (@@ subjectL)))
- ($_ r.then
- (r.set! idx (|> (r.apply-kw (list (@@ param) (r.if (|> (@@ startF) (r.= (r.int 0)))
- (@@ subject)
- (text-clip (inc (@@ startF))
- (inc (@@ subjectL))
- (@@ subject))))
- (list ["fixed" (r.bool #1)])
- (r.global "regexpr"))
- (r.nth (r.int 1))))
- (r.if (|> (@@ idx) (r.= (r.int -1)))
- ..none
- (..some (int//from-float (|> (@@ idx) (r.+ (@@ startF)))))))
- ..none))))
-
-(runtime: (text//clip text from to)
- (with-vars [length]
- ($_ r.then
- (r.set! length (r.length (@@ text)))
- (r.if ($_ r.and
- (|> (@@ to) (within? (@@ length)))
- (|> (@@ from) (up-to? (@@ to))))
- (..some (text-clip (inc (@@ from)) (inc (@@ to)) (@@ text)))
- ..none))))
-
-(def: (char-at idx text)
- (-> Expression Expression Expression)
- (r.apply (list (text-clip idx idx text))
- (r.global "utf8ToInt")))
-
-(runtime: (text//char text idx)
- (r.if (|> (@@ idx) (within? (r.length (@@ text))))
- ($_ r.then
- (r.set! idx (inc (@@ idx)))
- (..some (int//from-float (char-at (@@ idx) (@@ text)))))
- ..none))
-
-(def: runtime//text
- Runtime
- ($_ r.then
- @@text//index
- @@text//clip
- @@text//char))
-
-(def: (check-index-out-of-bounds array idx body)
- (-> Expression Expression Expression Expression)
- (r.if (|> idx (r.<= (r.length array)))
- body
- (r.stop (r.string "Array index out of bounds!"))))
-
-(runtime: (array//new size)
- (with-vars [output]
- ($_ r.then
- (r.set! output (r.list (list)))
- (r.set-nth! (|> (@@ size) (r.+ (r.int 1)))
- r.null
- output)
- (@@ output))))
-
-(runtime: (array//get array idx)
- (with-vars [temp]
- (<| (check-index-out-of-bounds (@@ array) (@@ idx))
- ($_ r.then
- (r.set! temp (|> (@@ array) (r.nth (@@ idx))))
- (r.if (|> (@@ temp) (r.= r.null))
- ..none
- (..some (@@ temp)))))))
-
-(runtime: (array//put array idx value)
- (<| (check-index-out-of-bounds (@@ array) (@@ idx))
- ($_ r.then
- (r.set-nth! (@@ idx) (@@ value) array)
- (@@ array))))
-
-(def: runtime//array
- Runtime
- ($_ r.then
- @@array//new
- @@array//get
- @@array//put))
-
-(runtime: (box//write value box)
- ($_ r.then
- (r.set-nth! (r.int 1) (@@ value) box)
- ..unit))
-
-(def: runtime//box
- Runtime
- ($_ r.then
- @@box//write))
-
-(def: runtime
- Runtime
- ($_ r.then
- runtime//lux
- @@f2^32
- @@f2^63
- @@int//new
- @@int//from-float
- runtime//bit
- runtime//int
- runtime//adt
- runtime//frac
- runtime//text
- runtime//array
- runtime//box
- runtime//io
- ))
-
-(def: #export artifact Text (format prefix ".r"))
-
-(def: #export translate
- (Meta (Process Any))
- (do macro.Monad<Meta>
- [_ //.init-module-buffer
- _ (//.save runtime)]
- (//.save-module! artifact)))
diff --git a/new-luxc/source/luxc/lang/translation/r/statement.jvm.lux b/new-luxc/source/luxc/lang/translation/r/statement.jvm.lux
deleted file mode 100644
index 1798cb56d..000000000
--- a/new-luxc/source/luxc/lang/translation/r/statement.jvm.lux
+++ /dev/null
@@ -1,45 +0,0 @@
-(.module:
- lux
- (lux (control [monad #+ do])
- [macro]
- (data text/format))
- (luxc (lang [".L" module]
- (host [r #+ Expression @@])))
- [//]
- (// [".T" runtime]
- [".T" reference]
- [".T" eval]))
-
-(def: #export (translate-def name expressionT expressionO metaV)
- (-> Text Type Expression Code (Meta Any))
- (do {@ macro.Monad<Meta>}
- [current-module macro.current-module-name
- #let [def-name [current-module name]]]
- (case (macro.get-identifier-ann (name-of #.alias) metaV)
- (#.Some real-def)
- (do @
- [[realT realA realV] (macro.find-def real-def)
- _ (moduleL.define def-name [realT metaV realV])]
- (wrap []))
-
- _
- (do @
- [#let [def-name (referenceT.global def-name)]
- _ (//.save (r.set! def-name expressionO))
- expressionV (evalT.eval (@@ def-name))
- _ (moduleL.define def-name [expressionT metaV expressionV])
- _ (if (macro.type? metaV)
- (case (macro.declared-tags metaV)
- #.Nil
- (wrap [])
-
- tags
- (moduleL.declare-tags tags (macro.export? metaV) (:coerce Type expressionV)))
- (wrap []))
- #let [_ (log! (format "DEF " (%name def-name)))]]
- (wrap []))
- )))
-
-(def: #export (translate-program programO)
- (-> Expression (Meta Expression))
- (macro.fail "translate-program NOT IMPLEMENTED YET"))
diff --git a/new-luxc/source/luxc/lang/translation/r/structure.jvm.lux b/new-luxc/source/luxc/lang/translation/r/structure.jvm.lux
deleted file mode 100644
index cea8fcd59..000000000
--- a/new-luxc/source/luxc/lang/translation/r/structure.jvm.lux
+++ /dev/null
@@ -1,31 +0,0 @@
-(.module:
- lux
- (lux (control [monad #+ do])
- (data [text]
- text/format)
- [macro])
- (luxc ["&" lang]
- (lang [synthesis #+ Synthesis]
- (host [r #+ Expression])))
- [//]
- (// [".T" runtime]))
-
-(def: #export (translate-tuple translate elemsS+)
- (-> (-> Synthesis (Meta Expression)) (List Synthesis) (Meta Expression))
- (case elemsS+
- #.Nil
- (:: macro.Monad<Meta> wrap runtimeT.unit)
-
- (#.Cons singletonS #.Nil)
- (translate singletonS)
-
- _
- (do {@ macro.Monad<Meta>}
- [elemsT+ (monad.map @ translate elemsS+)]
- (wrap (r.list elemsT+)))))
-
-(def: #export (translate-variant translate tag tail? valueS)
- (-> (-> Synthesis (Meta Expression)) Nat Bit Synthesis (Meta Expression))
- (do macro.Monad<Meta>
- [valueT (translate valueS)]
- (wrap (runtimeT.variant tag tail? valueT))))
diff --git a/new-luxc/source/program.lux b/new-luxc/source/program.lux
deleted file mode 100644
index e2cf047e9..000000000
--- a/new-luxc/source/program.lux
+++ /dev/null
@@ -1,180 +0,0 @@
-(.module:
- [lux (#- Definition)
- ["@" target]
- ["." host (#+ import:)]
- [abstract
- [monad (#+ do)]]
- [control
- ["." io (#+ IO)]
- ["." try (#+ Try)]
- [parser
- [cli (#+ program:)]]
- [concurrency
- ["." promise (#+ Promise)]]]
- [data
- ["." product]
- [text
- ["%" format (#+ format)]]
- [collection
- [array (#+ Array)]
- ["." dictionary]]]
- [world
- ["." file]]
- [target
- [jvm
- [bytecode (#+ Bytecode)]]]
- [tool
- [compiler
- [default
- ["." platform (#+ Platform)]]
- [language
- [lux
- [analysis
- ["." macro (#+ Expander)]]
- [phase
- [extension (#+ Phase Bundle Operation Handler Extender)
- ["." analysis #_
- ["#" jvm]]
- ["." generation #_
- ["#" jvm]]
- ## ["." directive #_
- ## ["#" jvm]]
- ]
- [generation
- ["." jvm #_
- ## ["." runtime (#+ Anchor Definition)]
- ["." packager]
- ## ["#/." host]
- ]]]]]]]]
- [program
- ["/" compositor
- ["/." cli]
- ["/." static]]]
- [luxc
- [lang
- [host
- ["_" jvm]]
- ["." directive #_
- ["#" jvm]]
- [translation
- ["." jvm
- ["." runtime]
- ["." expression]
- ["#/." program]
- ["translation" extension]]]]])
-
-(import: #long java/lang/reflect/Method
- (invoke [java/lang/Object [java/lang/Object]] #try java/lang/Object))
-
-(import: #long (java/lang/Class c)
- (getMethod [java/lang/String [(java/lang/Class java/lang/Object)]] #try java/lang/reflect/Method))
-
-(import: #long java/lang/Object
- (getClass [] (java/lang/Class java/lang/Object)))
-
-(def: _object-class
- (java/lang/Class java/lang/Object)
- (host.class-for java/lang/Object))
-
-(def: _apply2-args
- (Array (java/lang/Class java/lang/Object))
- (|> (host.array (java/lang/Class java/lang/Object) 2)
- (host.array-write 0 _object-class)
- (host.array-write 1 _object-class)))
-
-(def: _apply4-args
- (Array (java/lang/Class java/lang/Object))
- (|> (host.array (java/lang/Class java/lang/Object) 4)
- (host.array-write 0 _object-class)
- (host.array-write 1 _object-class)
- (host.array-write 2 _object-class)
- (host.array-write 3 _object-class)))
-
-(def: #export (expander macro inputs lux)
- Expander
- (do try.monad
- [apply-method (|> macro
- (:coerce java/lang/Object)
- (java/lang/Object::getClass)
- (java/lang/Class::getMethod "apply" _apply2-args))]
- (:coerce (Try (Try [Lux (List Code)]))
- (java/lang/reflect/Method::invoke
- (:coerce java/lang/Object macro)
- (|> (host.array java/lang/Object 2)
- (host.array-write 0 (:coerce java/lang/Object inputs))
- (host.array-write 1 (:coerce java/lang/Object lux)))
- apply-method))))
-
-(def: #export platform
- ## (IO (Platform Anchor (Bytecode Any) Definition))
- (IO (Platform _.Anchor _.Inst _.Definition))
- (do io.monad
- [## host jvm/host.host
- host jvm.host]
- (wrap {#platform.&file-system (file.async file.system)
- #platform.host host
- ## #platform.phase jvm.generate
- #platform.phase expression.translate
- ## #platform.runtime runtime.generate
- #platform.runtime runtime.translate
- #platform.write product.right})))
-
-(def: extender
- Extender
- ## TODO: Stop relying on coercions ASAP.
- (<| (:coerce Extender)
- (function (@self handler))
- (:coerce Handler)
- (function (@self name phase))
- (:coerce Phase)
- (function (@self parameters))
- (:coerce Operation)
- (function (@self state))
- (:coerce Try)
- try.assume
- (:coerce Try)
- (do try.monad
- [method (|> handler
- (:coerce java/lang/Object)
- (java/lang/Object::getClass)
- (java/lang/Class::getMethod "apply" _apply4-args))]
- (java/lang/reflect/Method::invoke
- (:coerce java/lang/Object handler)
- (|> (host.array java/lang/Object 4)
- (host.array-write 0 (:coerce java/lang/Object name))
- (host.array-write 1 (:coerce java/lang/Object phase))
- (host.array-write 2 (:coerce java/lang/Object parameters))
- (host.array-write 3 (:coerce java/lang/Object state)))
- method))))
-
-(def: (target service)
- (-> /cli.Service /cli.Target)
- (case service
- (^or (#/cli.Compilation [sources libraries target module])
- (#/cli.Interpretation [sources libraries target module])
- (#/cli.Export [sources target]))
- target))
-
-(def: (declare-success! _)
- (-> Any (Promise Any))
- (promise.future (io.exit +0)))
-
-(program: [{service /cli.service}]
- (let [jar-path (format (..target service) (:: file.system separator) "program.jar")]
- (exec (do promise.monad
- [_ (/.compiler {#/static.host @.jvm
- #/static.host-module-extension ".jvm"
- #/static.target (..target service)
- #/static.artifact-extension ".class"}
- ..expander
- analysis.bundle
- ..platform
- ## generation.bundle
- translation.bundle
- (directive.bundle ..extender)
- jvm/program.program
- ..extender
- service
- [(packager.package jvm/program.class) jar-path])]
- (..declare-success! []))
- (io.io []))))
diff --git a/new-luxc/source/test/program.lux b/new-luxc/source/test/program.lux
deleted file mode 100644
index 270f9005d..000000000
--- a/new-luxc/source/test/program.lux
+++ /dev/null
@@ -1,18 +0,0 @@
-(.module:
- [lux #*
- ["_" test (#+ Test)]
- [control
- ["." io]
- [parser
- [cli (#+ program:)]]]]
- [spec
- ["." compositor]]
- {1
- ["." /]})
-
-(program: args
- (<| io.io
- _.run!
- ## (_.times 100)
- (_.seed 1985013625126912890)
- (compositor.spec /.jvm /.bundle /.expander /.program)))