diff options
Diffstat (limited to 'new-luxc/source/luxc/lang')
32 files changed, 0 insertions, 6899 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)))) |