From b4d0eba7485caf0c6cf58de1193a9114fa273d8b Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 30 May 2020 15:19:28 -0400 Subject: Split new-luxc into lux-jvm and lux-r. --- new-luxc/source/luxc/lang/host/jvm.lux | 131 -------- new-luxc/source/luxc/lang/host/jvm/def.lux | 298 ------------------ new-luxc/source/luxc/lang/host/jvm/inst.lux | 464 ---------------------------- new-luxc/source/luxc/lang/host/r.lux | 299 ------------------ 4 files changed, 1192 deletions(-) delete mode 100644 new-luxc/source/luxc/lang/host/jvm.lux delete mode 100644 new-luxc/source/luxc/lang/host/jvm/def.lux delete mode 100644 new-luxc/source/luxc/lang/host/jvm/inst.lux delete mode 100644 new-luxc/source/luxc/lang/host/r.lux (limited to 'new-luxc/source/luxc/lang/host') 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 [ ] - [(type: #export - ( ..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 [ ] - [(def: #export ( 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) - - (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 [ ] - [(def: #export ( visibility config name value) - (-> //.Visibility //.Field-Config Text //.Def) - (function (_ writer) - (let [=field (do-to (ClassWriter::visitField ($_ i.+ - (visibility-flag visibility) - (field-flags config)) - (..binary-name name) - (..descriptor ) - (..signature ) - ( 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 [ ] - [(def: #export ( value) - (-> Inst) - (function (_ visitor) - (do-to visitor - (org/objectweb/asm/MethodVisitor::visitLdcInsn ( 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 [] - [(def: #export - Inst - (function (_ visitor) - (do-to visitor - (org/objectweb/asm/MethodVisitor::visitInsn (!prefix )))))] - - [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 [] - [(def: #export ( constant) - (-> Int Inst) - (function (_ visitor) - (do-to visitor - (org/objectweb/asm/MethodVisitor::visitIntInsn (!prefix ) constant))))] - - [BIPUSH] - [SIPUSH] - ) - -(template [] - [(def: #export - Inst - (function (_ visitor) - (do-to visitor - (org/objectweb/asm/MethodVisitor::visitInsn (!prefix )))))] - - [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 [] - [(def: #export ( register) - (-> Register Inst) - (function (_ visitor) - (do-to visitor - (org/objectweb/asm/MethodVisitor::visitVarInsn (!prefix ) (.int register)))))] - - [IINC] - [ILOAD] [LLOAD] [FLOAD] [DLOAD] [ALOAD] - [ISTORE] [LSTORE] [FSTORE] [DSTORE] [ASTORE] - ) - -(template [ ] - [(def: #export ( class field type) - (-> (Type Class) Text (Type Value) Inst) - (function (_ visitor) - (do-to visitor - (org/objectweb/asm/MethodVisitor::visitFieldInsn () (..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 [ +] - [(`` (template [ ] - [(def: #export ( class) - (-> (Type ) Inst) - (function (_ visitor) - (do-to visitor - (org/objectweb/asm/MethodVisitor::visitTypeInsn () (..class-name class)))))] - - (~~ (template.splice +))))] - - [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 [ ] - [(type@= type) ()] - - [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 [ ] - [(def: #export ( class method-name method) - (-> (Type Class) Text (Type Method) Inst) - (function (_ visitor) - (do-to visitor - (org/objectweb/asm/MethodVisitor::visitMethodInsn () - (..class-name class) - method-name - (|> method type.descriptor descriptor.descriptor) - ))))] - - [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 [] - [(def: #export ( @where) - (-> //.Label Inst) - (function (_ visitor) - (do-to visitor - (org/objectweb/asm/MethodVisitor::visitJumpInsn (!prefix ) @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 [ ] - [(def: ( type) - (-> (Type Primitive) Text) - (`` (cond (~~ (template [ ] - [(type@= type) ] - - [type.boolean ] - [type.byte ] - [type.short ] - [type.int ] - [type.long ] - [type.float ] - [type.double ] - [type.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] - [text] - text/format - [number] - (coll [list "list/" Functor Fold])) - (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 [ ] - [(def: #export - (-> (List Expression) Expression) - (composite-literal (format "(") ")" 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 [ ] - [(def: #export ( param subject) - (-> Expression Expression Expression) - (self-contained - (format (:representation subject) - " " " " - (:representation param))))] - - [= "=="] - [< "<"] - [<= "<="] - [> ">"] - [>= ">="] - [+ "+"] - [- "-"] - [* "*"] - [/ "/"] - [%% "%%"] - [** "**"] - [or "||"] - [and "&&"] - ) - - (def: #export @@ - (All [k] (-> (Var k) Expression)) - (|>> ..name self-contained)) - - (def: #export global - (-> Text Expression) - (|>> var @@)) - - (template [ ] - [(def: #export ( param subject) - (-> Expression Expression Expression) - (..apply (.list subject param) (..global )))] - - [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 [ ] - [(def: #export - (-> Expression Expression) - (|>> :representation (format ) 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 [ ] - [(def: #export ( message) - (-> Expression Expression) - (..apply (.list message) (..global )))] - - [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)))) - ) -- cgit v1.2.3