git.iko.soy/Idris-dev
on master help sign in
Backend support for Java
commit43056d675d6ac51d782b98cb043bd9b7ba44fb4c authorJan Bessai <Jan.Bessai@tu-dortmund.de> dateMon 11 Mar 2013, 19:48 (14 years ago) parenta02202d
35 files changed+1914−36
compare with master
unifiedsplit
idris.cabal+15−14 java/idris.jar java/org/idris/rts/Closure.java+17 java/org/idris/rts/ForeignPrimitives.java+198 java/org/idris/rts/IdrisObject.java+19 java/org/idris/rts/TailCallClosure.java+26 samples/interp.idr+1−1 src/IRTS/CodegenJava.hs+1455−16 test/Makefile+4−1 test/mkjavatest.pl+24 test/reg002/run_java+6 test/reg004/run_java+6 test/reg005/run_java+6 test/reg006/run_java+3 test/runtest.pl+14−4 test/test001/run_java+6 test/test003/run_java+7 test/test004/run_java+6 test/test005/run_java+6 test/test006/run_java+6 test/test007/run_java+6 test/test008/run_java+6 test/test009/run_java+6 test/test010/run_java+5 test/test011/run_java+6 test/test012/run_java+3 test/test013/run_java+6 test/test014/run_java+6 test/test015/run_java+6 test/test016/run_java+6 test/test017/run_java+4 test/test018/run_java+7 test/test019/run_java+6 test/test020/run_java+7 test/test021/run_java+9
idris.cabal+15−14
@@ -10,21 +10,21 @@ Stability: Beta
1010Category: Compilers/Interpreters, Dependent Types
1111Synopsis: Functional Programming Language with Dependent Types
1212Description: Idris is a general purpose language with full dependent types.
13− It is compiled, with eager evaluation.
13+ It is compiled, with eager evaluation.
1414 Dependent types allow types to be predicated on values,
1515 meaning that some aspects of a program's behaviour can be
16− specified precisely in the type. The language is closely
16+ specified precisely in the type. The language is closely
1717 related to Epigram and Agda. There is a tutorial at <http://www.idris-lang.org/documentation>.
1818 Features include:
1919 .
2020 * Full dependent types with dependent pattern matching
21− .
22− * where clauses, with rule, simple case expressions,
21+ .
22+ * where clauses, with rule, simple case expressions,
2323 pattern matching let and lambda bindings
2424 .
2525 * Type classes, monad comprehensions
2626 .
27− * do notation, idiom brackets, syntactic conveniences for lists,
27+ * do notation, idiom brackets, syntactic conveniences for lists,
2828 tuples, dependent pairs
2929 .
3030 * Totality checking
@@ -50,7 +50,7 @@ Data-files: rts/libidris_rts.a rts/idris_rts.h rts/idris_gc.h
5050 js/Runtime-common.js
5151 js/Runtime-node.js
5252 js/Runtime-browser.js
53−Extra-source-files: lib/Makefile lib/*.idr lib/Prelude/*.idr
53+Extra-source-files: lib/Makefile lib/*.idr lib/Prelude/*.idr
5454 lib/Network/*.idr lib/Control/*.idr
5555 lib/Control/Monad/*.idr lib/Language/*.idr
5656 lib/System/Concurrency/*.idr
@@ -65,14 +65,14 @@ Extra-source-files: lib/Makefile lib/*.idr lib/Prelude/*.idr
6565
6666source-repository head
6767 type: git
68− location: git://github.com/edwinb/Idris-dev.git
68+ location: git://github.com/edwinb/Idris-dev.git
6969
7070
7171Executable idris
7272 Main-is: Main.hs
7373 hs-source-dirs: src
74− Other-modules: Core.TT, Core.Evaluate, Core.Typecheck,
75− Core.ProofShell, Core.ProofState, Core.CoreParser,
74+ Other-modules: Core.TT, Core.Evaluate, Core.Typecheck,
75+ Core.ProofShell, Core.ProofState, Core.CoreParser,
7676 Core.ShellParser, Core.Unify, Core.Elaborate,
7777 Core.CaseTree, Core.Constraints,
7878
@@ -82,7 +82,7 @@ Executable idris
8282 Idris.Delaborate, Idris.Primitives, Idris.Imports,
8383 Idris.Compiler, Idris.Prover, Idris.ElabTerm,
8484 Idris.Coverage, Idris.IBC, Idris.Unlit,
85− Idris.DataOpts, Idris.Transforms, Idris.DSL,
85+ Idris.DataOpts, Idris.Transforms, Idris.DSL,
8686 Idris.UnusedArgs, Idris.Docs, Idris.Completion,
8787
8888 Util.Pretty, Util.System,
@@ -96,11 +96,12 @@ Executable idris
9696
9797 Paths_idris
9898
99− Build-depends: base>=4 && <5, parsec>=3, mtl, Cabal,
99+ Build-depends: base>=4 && <5, parsec>=3, mtl, Cabal,
100100 haskeline>=0.7, split, directory,
101− containers, process, transformers, filepath,
102− directory, binary, bytestring, pretty
103−
101+ containers, process, transformers, filepath,
102+ directory, binary, bytestring, pretty,
103+ language-java>=0.2.2
104+
104105 Extensions: MultiParamTypeClasses, FunctionalDependencies,
105106 FlexibleInstances, TemplateHaskell
106107 ghc-prof-options: -auto-all -caf-all
java/idris.jarnew file

Binary file not shown.

java/org/idris/rts/Closure.javanew file+17
@@ -0,0 +1,17 @@
1+package org.idris.rts;
2+
3+import java.util.concurrent.Callable;
4+
5+public abstract class Closure implements Callable<Object>, Runnable {
6+ protected final Object [] context;
7+
8+ protected Closure(final Object ... context) {
9+ this.context = context;
10+ }
11+
12+ public void run() {
13+ call();
14+ }
15+
16+ public abstract Object call();
17+}
java/org/idris/rts/ForeignPrimitives.javanew file+198
@@ -0,0 +1,198 @@
1+package org.idris.rts;
2+
3+import java.util.Arrays;
4+import java.util.List;
5+import java.util.Map;
6+import java.util.HashMap;
7+import java.util.Set;
8+import java.util.HashSet;
9+import java.io.Closeable;
10+import java.io.File;
11+import java.io.IOException;
12+import java.io.EOFException;
13+import java.io.PrintStream;
14+import java.io.InputStream;
15+import java.nio.ByteBuffer;
16+import java.nio.file.Files;
17+import java.nio.file.OpenOption;
18+import java.nio.file.StandardOpenOption;
19+import java.nio.channels.Channels;
20+import java.nio.channels.SeekableByteChannel;
21+import java.nio.channels.ReadableByteChannel;
22+import java.util.concurrent.BlockingQueue;
23+import java.util.concurrent.LinkedBlockingQueue;
24+import java.util.concurrent.Semaphore;
25+
26+@SuppressWarnings("unchecked")
27+public class ForeignPrimitives {
28+ private static final Map<Thread, List<String>> args = new HashMap<>();
29+ private static final Semaphore messageMutex = new Semaphore(1);
30+ private static final Map<Thread, BlockingQueue<Object>> messages = new HashMap<>();
31+ private static final Set<Object> feofFiles = new HashSet<>();
32+
33+ public static synchronized void idris_initArgs(Thread t, String [] args) {
34+ ForeignPrimitives.args.put(t, Arrays.asList(args));
35+ }
36+
37+ public static synchronized int idris_numArgs(Object thread) {
38+ List<String> argsForThread = ForeignPrimitives.args.get((Thread)thread);
39+ return (argsForThread == null ? 0 : argsForThread.size());
40+ }
41+
42+ public static synchronized String idris_getArg(Object thread, int num) {
43+ List<String> argsForThread = ForeignPrimitives.args.get((Thread)thread);
44+ return (argsForThread == null ? null : argsForThread.get(num));
45+ }
46+
47+ public static String getenv(String x) {
48+ return System.getenv(x);
49+ }
50+
51+ public static void exit(int exitCode) {
52+ System.exit(exitCode);
53+ }
54+
55+ public static void usleep(int microsecs) {
56+ try {
57+ Thread.sleep(microsecs / 1000, microsecs % 1000);
58+ } catch (InterruptedException ex) {
59+ }
60+ }
61+
62+ public static void idris_sendMessage(Object from, Object dest, Object message) throws InterruptedException {
63+ messageMutex.acquire();
64+ BlockingQueue<Object> messagesForTarget = messages.get((Thread)dest);
65+ if (messagesForTarget == null) {
66+ messagesForTarget = new LinkedBlockingQueue<>();
67+ messages.put((Thread)dest, messagesForTarget);
68+ }
69+ messagesForTarget.put(message);
70+ messageMutex.release();
71+ }
72+
73+ public static int idris_checkMessage(Object dest) throws InterruptedException {
74+ messageMutex.acquire();
75+ BlockingQueue<Object> messagesForTarget = messages.get((Thread)dest);
76+ messageMutex.release();
77+ return (messagesForTarget == null ? 0 : messagesForTarget.size());
78+ }
79+
80+ public static Object idris_recvMessage(Object dest) throws InterruptedException {
81+ messageMutex.acquire();
82+ BlockingQueue<Object> messagesForTarget = messages.get((Thread)dest);
83+ if (messagesForTarget == null) {
84+ messagesForTarget = new LinkedBlockingQueue();
85+ messages.put((Thread)dest, messagesForTarget);
86+ }
87+ messageMutex.release();
88+ return messagesForTarget.take();
89+ }
90+
91+ public static void putStr(String str) {
92+ System.out.print(str);
93+ }
94+
95+ public static void putchar(char c) {
96+ System.out.print(c);
97+ }
98+
99+ public static int getchar() {
100+ try {
101+ return (char)System.in.read();
102+ } catch (IOException ex) {
103+ return -1;
104+ }
105+ }
106+
107+ public static SeekableByteChannel fileOpen(String name, String privs) {
108+ try {
109+ OpenOption [] options;
110+ switch (privs) {
111+ case "r" :
112+ options = new StandardOpenOption []
113+ { StandardOpenOption.READ };
114+ break;
115+ case "r+" :
116+ options = new StandardOpenOption []
117+ { StandardOpenOption.READ,
118+ StandardOpenOption.WRITE };
119+ break;
120+ case "w" :
121+ options = new StandardOpenOption []
122+ { StandardOpenOption.WRITE,
123+ StandardOpenOption.CREATE };
124+ break;
125+ case "w+" :
126+ options = new StandardOpenOption []
127+ { StandardOpenOption.READ,
128+ StandardOpenOption.WRITE,
129+ StandardOpenOption.CREATE };
130+ break;
131+ case "a" :
132+ options = new StandardOpenOption []
133+ { StandardOpenOption.WRITE,
134+ StandardOpenOption.CREATE,
135+ StandardOpenOption.APPEND };
136+ break;
137+ case "a+" :
138+ options = new StandardOpenOption []
139+ { StandardOpenOption.READ,
140+ StandardOpenOption.WRITE,
141+ StandardOpenOption.CREATE,
142+ StandardOpenOption.APPEND };
143+ break;
144+ default :
145+ options = new StandardOpenOption [] {};
146+ break;
147+ }
148+ return Files.newByteChannel(new File(name).toPath(), options);
149+ } catch (IOException ex) {
150+ return null;
151+ }
152+ }
153+
154+ public static synchronized void fileClose(Object file) throws IOException {
155+ ((Closeable)file).close();
156+ feofFiles.remove(file);
157+ }
158+
159+ public static void fputStr(Object file, String string) throws IOException {
160+ if (file instanceof PrintStream) {
161+ ((PrintStream)file).print(string);
162+ } else if (file instanceof SeekableByteChannel) {
163+ ((SeekableByteChannel)file).write(ByteBuffer.wrap(string.getBytes()));
164+ }
165+ }
166+
167+ public static synchronized String idris_readStr(Object file) throws IOException {
168+ ReadableByteChannel channel = file instanceof InputStream ?
169+ Channels.newChannel((InputStream)file) :
170+ (ReadableByteChannel)file;
171+ ByteBuffer buf = ByteBuffer.allocate(1);
172+ StringBuilder resultBuilder = new StringBuilder("");
173+ String delimiter = System.getProperty("line.separator");
174+ int read = 0;
175+ do {
176+ buf.rewind();
177+ read = channel.read(buf);
178+ if (read > 0) {
179+ resultBuilder.append(new String(buf.array()));
180+ if (resultBuilder.lastIndexOf(delimiter) > -1) {
181+ return resultBuilder.toString();
182+ }
183+ }
184+ if (read < 0) {
185+ feofFiles.add(file);
186+ }
187+ } while (read >= 0);
188+ return resultBuilder.toString();
189+ }
190+
191+ public static int fileEOF(Object file) {
192+ return (feofFiles.contains(file) ? 1 : 0);
193+ }
194+
195+ public static int isNull(Object o) {
196+ return (o == null ? 1 : 0);
197+ }
198+}
java/org/idris/rts/IdrisObject.javanew file+19
@@ -0,0 +1,19 @@
1+package org.idris.rts;
2+
3+public class IdrisObject {
4+ private final int constructorId;
5+ private final Object data[];
6+
7+ public IdrisObject(final int constructorId, final Object ... data) {
8+ this.constructorId = constructorId;
9+ this.data = data;
10+ }
11+
12+ public int getConstructorId() {
13+ return constructorId;
14+ }
15+
16+ public Object[] getData() {
17+ return data;
18+ }
19+}
java/org/idris/rts/TailCallClosure.javanew file+26
@@ -0,0 +1,26 @@
1+package org.idris.rts;
2+
3+public class TailCallClosure extends Closure {
4+ private final Closure function;
5+
6+ public TailCallClosure(Closure function) {
7+ super();
8+ this.function = function;
9+ }
10+
11+ public final Object call() {
12+ Closure function = this.function;
13+ Object result = null;
14+ while (function != null) {
15+ result = function.call();
16+ function = null;
17+ if (result instanceof TailCallClosure) {
18+ function = ((TailCallClosure)result).function;
19+ } else {
20+ return result;
21+ }
22+ }
23+ return result;
24+ }
25+}
26+
samples/interp.idr+1−1
@@ -1,4 +1,4 @@
1−module main
1+module Main
22
33data Ty = TyInt | TyBool | TyFun Ty Ty
44
src/IRTS/CodegenJava.hs+1455−16
@@ -1,23 +1,1462 @@
11module IRTS.CodegenJava (codegenJava) where
22
3−import IRTS.BCImp
4−import IRTS.Lang
5−import IRTS.Simplified
6−import Core.TT
7−import Paths_idris
8−import Util.System
9−import IRTS.CodegenCommon
10−
11−import Data.Char
12−import System.Process
13−import System.Exit
14−import System.IO
15−import System.Directory
16−import Control.Monad
3+import Core.TT
4+import IRTS.BCImp
5+import IRTS.CodegenCommon
6+import IRTS.Lang
7+import IRTS.Simplified
8+import Paths_idris
9+import Util.System
10+
11+import Control.Applicative
12+import Control.Arrow
13+import Control.Monad
14+import Data.Char
15+import Data.Maybe (fromJust)
16+import Language.Java.Parser
17+import Language.Java.Pretty
18+import Language.Java.Syntax hiding (Name)
19+import qualified Language.Java.Syntax as J
20+import System.Directory
21+import System.Exit
22+import System.FilePath
23+import System.IO
24+import System.Process
1725
1826codegenJava :: [(Name, SDecl)] ->
19− String -> -- output file name
27+ FilePath -> -- output file name
2028 OutputType ->
2129 IO ()
22−codegenJava defs out exec = putStrLn "Not implemented yet"
30+codegenJava defs out exec =
31+ either (error)
32+ (writeFile out . flatIndent . prettyPrint)
33+ (mkCompilationUnit defs out)
34+
35+mkCompilationUnit :: [(Name, SDecl)] ->
36+ FilePath ->
37+ Either String CompilationUnit
38+mkCompilationUnit defs out =
39+ CompilationUnit Nothing [ ImportDecl False idrisRts True
40+ , ImportDecl True idrisForeign True
41+ , ImportDecl False bigInteger False
42+ , ImportDecl False stringBuffer False
43+ , ImportDecl False runtimeException False
44+ , ImportDecl False scanner False
45+ , ImportDecl False arrays False
46+ ] <$>
47+ mkTypeDecl defs out
48+ where
49+ idrisRts = J.Name $ map Ident ["org", "idris", "rts"]
50+ idrisForeign = J.Name $ map Ident ["org", "idris", "rts", "ForeignPrimitives"]
51+ bigInteger = J.Name $ map Ident ["java", "math", "BigInteger"]
52+ stringBuffer = J.Name $ map Ident ["java", "lang", "StringBuffer"]
53+ runtimeException = J.Name $ map Ident ["java", "lang", "RuntimeException"]
54+ scanner = J.Name $ map Ident ["java", "util", "Scanner"]
55+ arrays = J.Name $ map Ident ["java", "util", "Arrays"]
56+
57+flatIndent :: String -> String
58+flatIndent (' ' : ' ' : xs) = flatIndent xs
59+flatIndent (x:xs) = x:flatIndent xs
60+flatIndent [] = []
61+
62+prefixCallNamespaces :: Ident -> SExp -> SExp
63+prefixCallNamespaces (Ident name) (SApp tail (NS n ns) args) = SApp tail (NS n (name:ns)) args
64+prefixCallNamespaces name (SLet var e1 e2) = SLet var (prefixCallNamespaces name e1) (prefixCallNamespaces name e2)
65+prefixCallNamespaces name (SUpdate var e) = SUpdate var (prefixCallNamespaces name e)
66+prefixCallNamespaces name (SCase var alts) = SCase var (map (prefixCallNamespacesCase name) alts)
67+prefixCallNamespaces name (SChkCase var alts) = SChkCase var (map (prefixCallNamespacesCase name) alts)
68+prefixCallNamespaces _ exp = exp
69+
70+prefixCallNamespacesCase :: Ident -> SAlt -> SAlt
71+prefixCallNamespacesCase name (SConCase x y n ns e) = SConCase x y n ns (prefixCallNamespaces name e)
72+prefixCallNamespacesCase name (SConstCase c e) = SConstCase c (prefixCallNamespaces name e)
73+prefixCallNamespacesCase name (SDefaultCase e) = SDefaultCase (prefixCallNamespaces name e)
74+
75+prefixCallNamespacesDecl :: Ident -> SDecl -> SDecl
76+prefixCallNamespacesDecl name (SFun fname args i e) = SFun fname args i (prefixCallNamespaces name e)
77+
78+mkTypeDecl :: [(Name, SDecl)] ->
79+ FilePath ->
80+ Either String [TypeDecl]
81+mkTypeDecl defs out =
82+ (\ name body -> [ClassTypeDecl $ ClassDecl [ Public
83+ , Annotation $ SingleElementAnnotation
84+ (J.Name [Ident "SuppressWarnings"])
85+ (EVVal . InitExp . Lit $ String "unchecked")
86+ ]
87+ name
88+ []
89+ Nothing
90+ []
91+ body])
92+ <$> mkClassName out
93+ <*> ( mkClassName out
94+ >>= (\ ident -> mkClassBody (map (second (prefixCallNamespacesDecl ident)) defs))
95+ )
96+
97+mkClassName :: FilePath -> Either String Ident
98+mkClassName path =
99+ left (\ err -> "Parser error in \"" ++ path ++ "\": " ++ (show err))
100+ (parser ident . takeBaseName $ takeFileName path)
101+
102+mkClassBody :: [(Name, SDecl)] ->
103+ Either String ClassBody
104+mkClassBody defs = (ClassBody . addMainMethod . mergeInnerClasses)
105+ <$> mapM mkDecl defs
106+
107+addMainMethod :: [Decl] -> [Decl]
108+addMainMethod decls
109+ | findMain decls = mkMainMethod : decls
110+ | otherwise = decls
111+ where
112+ findMain ((MemberDecl (MemberClassDecl (ClassDecl _ (Ident "Main") _ _ _ (ClassBody body)))):_) =
113+ findMainMethod body
114+ findMain (_:decls) = findMain decls
115+ findMain [] = False
116+
117+ findMainMethod ((MemberDecl (MethodDecl _ _ _ (Ident "main") [] _ _)):_) = True
118+ findMainMethod (_:decls) = findMainMethod decls
119+ findMainMethod [] = False
120+
121+mkMainMethod :: Decl
122+mkMainMethod =
123+ MemberDecl $ MethodDecl [Public, Static]
124+ []
125+ Nothing
126+ (Ident "main")
127+ [FormalParam [] stringArrayType False (VarId $ Ident "args")]
128+ []
129+ (MethodBody . Just $ Block [ BlockStmt . ExpStmt . MethodInv $
130+ MethodCall (J.Name [Ident "idris_initArgs"])
131+ [ MethodInv $ TypeMethodCall
132+ (J.Name [Ident "Thread"])
133+ []
134+ (Ident "currentThread")
135+ []
136+ , ExpName $ J.Name [Ident "args"]
137+ ]
138+ , BlockStmt . ExpStmt . MethodInv $
139+ MethodCall (J.Name [Ident "runMain_0"])
140+ []
141+ ]
142+ )
143+
144+mergeInnerClasses :: [Decl] -> [Decl]
145+mergeInnerClasses = foldl mergeInner []
146+ where
147+ mergeInner ((decl@(MemberDecl (MemberClassDecl (ClassDecl priv name targs ext imp (ClassBody body))))):decls)
148+ decl'@(MemberDecl (MemberClassDecl (ClassDecl _ name' _ ext' imp' (ClassBody body'))))
149+ | name == name' =
150+ (MemberDecl $ MemberClassDecl $
151+ ClassDecl priv
152+ name
153+ targs
154+ (mplus ext ext')
155+ (imp ++ imp')
156+ (ClassBody $ mergeInnerClasses (body ++ body')))
157+ : decls
158+ | otherwise = decl:(mergeInner decls decl')
159+ mergeInner (decl:decls) decl' = decl:(mergeInner decls decl')
160+ mergeInner [] decl' = [decl']
161+
162+
163+mkIdentifier :: Name -> Either String Ident
164+mkIdentifier (NS name _) = mkIdentifier name
165+mkIdentifier (MN i name) = (\ (Ident x) -> Ident $ x ++ ('_' : show i))
166+ <$> mkIdentifier (UN name)
167+mkIdentifier (UN name) =
168+ left (\ err -> "Parser error in \"" ++ name ++ "\": " ++ (show err))
169+ ( parser ident
170+ . cleanReserved
171+ . cleanNonLetter
172+ . cleanStart
173+ $ cleanWs False name)
174+ where
175+ cleanStart (x:xs)
176+ | isNumber x = '_' : (x:xs)
177+ | otherwise = (x:xs)
178+ cleanStart [] = []
179+ cleanNonLetter (x:xs)
180+ | x == '#' = "_Hash" ++ cleanNonLetter xs
181+ | x == '@' = "_At" ++ cleanNonLetter xs
182+ | x == '$' = "_Dollar" ++ cleanNonLetter xs
183+ | x == '!' = "_Bang" ++ cleanNonLetter xs
184+ | x == '.' = "_Dot" ++ cleanNonLetter xs
185+ | x == '\'' = "_Prime" ++ cleanNonLetter xs
186+ | x == '*' = "_Times" ++ cleanNonLetter xs
187+ | x == '+' = "_Plus" ++ cleanNonLetter xs
188+ | x == '/' = "_Divide" ++ cleanNonLetter xs
189+ | x == '-' = "_Minus" ++ cleanNonLetter xs
190+ | x == '%' = "_Mod" ++ cleanNonLetter xs
191+ | x == '<' = "_LessThan" ++ cleanNonLetter xs
192+ | x == '=' = "_Equals" ++ cleanNonLetter xs
193+ | x == '>' = "_MoreThan" ++ cleanNonLetter xs
194+ | x == '[' = "_LSBrace" ++ cleanNonLetter xs
195+ | x == ']' = "_RSBrace" ++ cleanNonLetter xs
196+ | x == '(' = "_LBrace" ++ cleanNonLetter xs
197+ | x == ')' = "_RBrace" ++ cleanNonLetter xs
198+ | x == '_' = "__" ++ cleanNonLetter xs
199+ | not (isAlphaNum x) = "_" ++ (show $ ord x) ++ xs
200+ | otherwise = x:cleanNonLetter xs
201+ cleanNonLetter [] = []
202+ cleanWs capitalize (x:xs)
203+ | isSpace x = cleanWs True xs
204+ | capitalize = (toUpper x) : (cleanWs False xs)
205+ | otherwise = x : (cleanWs False xs)
206+ cleanWs _ [] = []
207+
208+
209+ cleanReserved "param" = "_param"
210+ cleanReserved "context" = "_context"
211+ cleanReserved "newcontext" = "_newcontext"
212+
213+ cleanReserved "void" = "_void"
214+ cleanReserved "null" = "_null"
215+ cleanReserved "int" = "_int"
216+ cleanReserved "long" = "_long"
217+ cleanReserved "char" = "_char"
218+ cleanReserved "byte" = "_byte"
219+ cleanReserved "double" = "_double"
220+ cleanReserved "float" = "_float"
221+ cleanReserved "boolean" = "_boolean"
222+ cleanReserved "Object" = "_Object"
223+ cleanReserved "String" = "_String"
224+ cleanReserved "StringBuilder" = "_StringBuilder"
225+ cleanReserved "StringBuffer" = "_StringBuffer"
226+ cleanReserved "Scanner" = "_Scanner"
227+ cleanReserved "Integer" = "_Integer"
228+ cleanReserved "Double" = "_Double"
229+ cleanReserved "Byte" = "_Byte"
230+ cleanReserved "Character" = "_Character"
231+ cleanReserved "BigInteger" = "_BigInteger"
232+ cleanReserved "Boolean" = "_Boolean"
233+ cleanReserved "Closure" = "_Closure"
234+ cleanReserved "IdrisObject" = "_IdrisObject"
235+ cleanReserved "TailCallClosure" = "_TailCallClosure"
236+ cleanReserved "System" = "_System"
237+ cleanReserved "Math" = "_Math"
238+ cleanReserved "Arrays" = "_Arrays"
239+ cleanReserved "RuntimeException" = "_RuntimeException"
240+ cleanReserved "Comparable" = "_Comparable"
241+
242+ cleanReserved "class" = "_class"
243+ cleanReserved "enum" = "_enum"
244+ cleanReserved "interface" = "_interface"
245+ cleanReserved "extends" = "_extends"
246+ cleanReserved "implements" = "_implements"
247+ cleanReserved "public" = "_public"
248+ cleanReserved "private" = "_private"
249+ cleanReserved "protected" = "_protected"
250+ cleanReserved "static" = "_static"
251+ cleanReserved "final" = "_final"
252+ cleanReserved "abstract" = "_abstract"
253+ cleanReserved "strict" = "_strict"
254+ cleanReserved "volatile" = "_volatile"
255+ cleanReserved "transient" = "_transient"
256+ cleanReserved "native" = "_native"
257+
258+ cleanReserved "import" = "_import"
259+ cleanReserved "package" = "_package"
260+
261+ cleanReserved "throw" = "_throw"
262+ cleanReserved "throws" = "_throws"
263+ cleanReserved "try" = "_try"
264+ cleanReserved "catch" = "_catch"
265+
266+ cleanReserved "synchronized" = "_synchronized"
267+
268+ cleanReserved "if" = "_if"
269+ cleanReserved "else" = "_else"
270+ cleanReserved "switch" = "_switch"
271+ cleanReserved "case" = "_case"
272+ cleanReserved "default" = "_default"
273+
274+ cleanReserved "while" = "_while"
275+ cleanReserved "for" = "_for"
276+ cleanReserved "do" = "_do"
277+ cleanReserved "break" = "_break"
278+ cleanReserved "continue" = "_continue"
279+ cleanReserved "goto" = "_goto"
280+
281+ cleanReserved "this" = "_this"
282+ cleanReserved "super" = "_super"
283+ cleanReserved "new" = "_new"
284+ cleanReserved "return" = "_return"
285+
286+ cleanReserved "idris_initArgs" = "_idris_initArgs"
287+ cleanReserved "idris_numArgs" = "_idris_numArgs"
288+ cleanReserved "idris_getArg" = "_idris_getArg"
289+ cleanReserved "getenv" = "_getenv"
290+ cleanReserved "exit" = "_exit"
291+ cleanReserved "usleep" = "_usleep"
292+ cleanReserved "idris_sendMessage" = "_idris_sendMessage"
293+ cleanReserved "idris_checkMessage" = "_idris_checkMessage"
294+ cleanReserved "idris_recvMessage" = "_idris_recvMessage"
295+ cleanReserved "putStr" = "_putStr"
296+ cleanReserved "putchar" = "_putchar"
297+ cleanReserved "getchar" = "_getchar"
298+ cleanReserved "fileOpen" = "_fileOpen"
299+ cleanReserved "fileClose" = "_fileClose"
300+ cleanReserved "fputStr" = "_fputStr"
301+ cleanReserved "fileEOF" = "_fileEOF"
302+ cleanReserved "isNull" = "_isNull"
303+
304+ cleanReserved x = x
305+
306+mkName :: Name -> Either String J.Name
307+mkName (NS name nss) = (\ n ns -> J.Name (n:ns))
308+ <$> mkIdentifier name
309+ <*> mapM (mkIdentifier . UN) nss
310+mkName n = J.Name . (:[]) <$> mkIdentifier n
311+
312+voidType :: ClassType
313+voidType = ClassType [(Ident "Void", [])]
314+
315+objectType :: ClassType
316+objectType = ClassType [(Ident "Object", [])]
317+
318+objectArrayType :: Language.Java.Syntax.Type
319+objectArrayType = RefType . ArrayType . RefType . ClassRefType $ objectType
320+
321+idrisClosureType :: ClassType
322+idrisClosureType = ClassType [(Ident "Closure", [])]
323+
324+idrisTailCallClosureType :: ClassType
325+idrisTailCallClosureType = ClassType [(Ident "TailCallClosure", [])]
326+
327+--idrisFunctionType :: ClassType
328+--idrisFunctionType = ClassType [(Ident "IdrisFunction", [])]
329+
330+idrisObjectType :: ClassType
331+idrisObjectType = ClassType [(Ident "IdrisObject", [])]
332+
333+contextArray :: Exp
334+contextArray = ExpName $ J.Name [Ident "context"]
335+
336+charType :: ClassType
337+charType = ClassType [(Ident "Character", [])]
338+
339+byteType :: ClassType
340+byteType = ClassType [(Ident "Byte", [])]
341+
342+shortType :: ClassType
343+shortType = ClassType [(Ident "Short", [])]
344+
345+integerType :: ClassType
346+integerType = ClassType [(Ident "Integer", [])]
347+
348+longType :: ClassType
349+longType = ClassType [(Ident "Integer", [])]
350+
351+bigIntegerType :: ClassType
352+bigIntegerType = ClassType [(Ident "BigInteger", [])]
353+
354+doubleType :: ClassType
355+doubleType = ClassType [(Ident "Double", [])]
356+
357+stringType :: ClassType
358+stringType = ClassType [(Ident "String", [])]
359+
360+stringArrayType :: Language.Java.Syntax.Type
361+stringArrayType = RefType . ArrayType . RefType . ClassRefType $ stringType
362+
363+exceptionType :: ClassType
364+exceptionType = ClassType [(Ident "Throwable", [])]
365+
366+runtimeExceptionType :: ClassType
367+runtimeExceptionType = ClassType [(Ident "RuntimeException", [])]
368+
369+comparableType :: ClassType
370+comparableType = ClassType [(Ident "Comparable", [])]
371+
372+mkDecl :: (Name, SDecl) ->
373+ Either String Decl
374+mkDecl ((NS n (ns:nss)), decl) =
375+ (\ name body -> MemberDecl $ MemberClassDecl $ ClassDecl [Public, Static] name [] Nothing [] body)
376+ <$> mkIdentifier (UN ns)
377+ <*> mkClassBody [(NS n nss, decl)]
378+mkDecl (_, SFun name params stackSize body) =
379+ (\ name params cont ->
380+ MemberDecl $ MethodDecl [Public, Static]
381+ []
382+ (Just . RefType $ ClassRefType objectType)
383+ name
384+ params
385+ []
386+ (MethodBody . Just $ Block [ BlockStmt . Return . Just . MethodInv $
387+ PrimaryMethodCall cont [] (Ident "call") []])
388+ )
389+ <$> mkIdentifier name
390+ <*> mapM mkFormalParam params
391+ <*> mkClosure params stackSize body
392+
393+
394+mkClosure :: [Name] -> Int -> SExp -> Either String Exp
395+mkClosure params stackSize body =
396+ (\ paramArray body ->
397+ InstanceCreation []
398+ idrisClosureType
399+ [paramArray]
400+ (Just $ ClassBody [body])
401+ )
402+ <$> mkStackInit params stackSize
403+ <*> mkClosureCall body
404+
405+mkFormalParam :: Name -> Either String FormalParam
406+mkFormalParam name =
407+ (\ name -> FormalParam [Final] (RefType . ClassRefType $ objectType) False (VarId name))
408+ <$> mkIdentifier name
409+
410+mkClosureCall :: SExp -> Either String Decl
411+mkClosureCall body =
412+ (\ body -> MemberDecl $ MethodDecl [Public] [] (Just . RefType $ ClassRefType objectType) (Ident "call") [] [] body)
413+ <$> mkMethodBody body
414+
415+mkMethodBody :: SExp -> Either String MethodBody
416+mkMethodBody exp =
417+ (\ exp -> MethodBody . Just . Block $ [BlockStmt . Return . Just $ exp])
418+ <$> mkExp exp
419+
420+mkStackInit :: [Name] -> Int -> Either String Exp
421+mkStackInit params stackSize =
422+ (\ localVars -> ArrayCreateInit objectArrayType 0 . ArrayInit $
423+ (map (InitExp . ExpName) localVars)
424+ ++ (replicate (stackSize) (InitExp $ Lit Null)))
425+ <$> mapM mkName params
426+
427+mkAnonymousLetBinding :: LVar -> SExp -> SExp -> Either String Exp
428+mkAnonymousLetBinding var oldExp newExp =
429+ (\ bindingMethod newExp ->
430+ MethodInv $ PrimaryMethodCall
431+ ( MethodInv $ PrimaryMethodCall ( InstanceCreation []
432+ objectType
433+ []
434+ (Just $ ClassBody [MemberDecl $ bindingMethod])
435+ )
436+ []
437+ (Ident "apply")
438+ [ contextArray
439+ , newExp]
440+ )
441+ []
442+ (Ident "call")
443+ []
444+ )
445+ <$> mkLetBindingMethod var oldExp
446+ <*> mkExp newExp
447+
448+
449+mkContextParam :: FormalParam
450+mkContextParam =
451+ FormalParam [Final] (objectArrayType) False (VarId (Ident "context"))
452+
453+mkLetBindingMethod :: LVar -> SExp -> Either String MemberDecl
454+mkLetBindingMethod (Loc i) oldExp =
455+ (\ param bindingStack oldCont ->
456+ MethodDecl [Final, Public]
457+ []
458+ (Just . RefType $ ClassRefType idrisClosureType)
459+ (Ident "apply")
460+ [mkContextParam, param]
461+ []
462+ (MethodBody . Just . Block $
463+ bindingStack ++ [BlockStmt . Return $ Just oldCont]
464+ )
465+ )
466+ <$> mkFormalParam (UN "param")
467+ <*> mkBindingStack True i [UN "param"]
468+ <*> mkBindingClosure oldExp
469+
470+mkBindingClosure :: SExp -> Either String Exp
471+mkBindingClosure oldExp =
472+ (\ oldCall ->
473+ InstanceCreation []
474+ idrisClosureType
475+ [ ExpName $ J.Name [Ident "new_context"] ]
476+ (Just $ ClassBody [oldCall])
477+ )
478+ <$> mkClosureCall oldExp
479+
480+
481+mkBindingStack :: Bool -> Int -> [Name] -> Either String [BlockStmt]
482+mkBindingStack checked parentStackStart params =
483+ (\ paramNames ->
484+ ( LocalVars [Final]
485+ objectArrayType
486+ [ VarDecl (VarDeclArray . VarId $ Ident "new_context")
487+ (Just . InitExp $ mkContextCopy checked parentStackStart params)
488+ ])
489+ : ( map (\ (param, pos) ->
490+ BlockStmt . ExpStmt $
491+ Assign (ArrayLhs $ ArrayIndex (ExpName $ J.Name [Ident "new_context"])
492+ (Lit $ Int (toInteger pos)))
493+ EqualA
494+ (ExpName param)) $ zip paramNames [parentStackStart..]
495+ )
496+ )
497+ <$> mapM mkName params
498+
499+mkContextCopy :: Bool -> Int -> [Name] -> Exp
500+mkContextCopy True parentStackStart params =
501+ MethodInv $ PrimaryMethodCall (ExpName $ J.Name [Ident "context"])
502+ []
503+ (Ident "clone")
504+ []
505+mkContextCopy False parentStackStart params =
506+ MethodInv $ TypeMethodCall (J.Name [Ident "Arrays"])
507+ []
508+ (Ident "copyOf")
509+ [ ExpName $ J.Name [Ident "context"]
510+ , MethodInv
511+ $ TypeMethodCall (J.Name [Ident "Math"])
512+ []
513+ (Ident "max")
514+ [ FieldAccess $ PrimaryFieldAccess (ExpName $ J.Name [Ident "context"])
515+ (Ident "length")
516+ , Lit . Int $ toInteger (parentStackStart + length params)
517+ ]
518+ ]
519+
520+reverseNameSpace :: J.Name -> J.Name
521+reverseNameSpace (J.Name ids) =
522+ J.Name ((tail ids) ++ [head ids])
523+
524+mkCase :: Bool -> LVar -> [SAlt] -> Either String Exp
525+mkCase checked var ((SConCase parentStackPos consIndex _ params branchExpression):cases) =
526+ mkConsCase checked
527+ var
528+ parentStackPos
529+ consIndex
530+ params
531+ branchExpression
532+ (SCase var cases)
533+mkCase checked var (c@(SConstCase constant branchExpression):cases) =
534+ (\ constant branchExpression alternative ->
535+ Cond ( MethodInv $ PrimaryMethodCall (constant)
536+ []
537+ (Ident "equals")
538+ [mkVarAccess Nothing var]
539+ )
540+ branchExpression
541+ alternative
542+ )
543+ <$> mkExp (SConst constant)
544+ <*> mkExp branchExpression
545+ <*> mkCase checked var cases
546+mkCase checked var (SDefaultCase exp:cases) = mkExp exp
547+mkCase checked _ [] = mkExp (SError "Non-exhaustive pattern")
548+
549+mkConsCase :: Bool -> LVar -> Int -> Int -> [Name] -> SExp -> SExp -> Either String Exp
550+mkConsCase checked
551+ toDeconstruct
552+ parentStackStart
553+ consIndex
554+ params
555+ branchExpression
556+ alternative =
557+ (\ caseBinding alternative->
558+ Cond (BinOp (InstanceOf (mkVarAccess Nothing toDeconstruct)
559+ (ClassRefType idrisObjectType)
560+ )
561+ CAnd
562+ ( BinOp
563+ ( MethodInv $ PrimaryMethodCall (mkVarAccess (Just idrisObjectType) toDeconstruct)
564+ []
565+ (Ident "getConstructorId")
566+ []
567+ )
568+ Equal
569+ (Lit $ Int (toInteger consIndex))
570+ )
571+ )
572+ (caseBinding)
573+ alternative
574+ )
575+ <$> mkCaseBinding checked toDeconstruct parentStackStart params branchExpression
576+ <*> mkExp alternative
577+
578+
579+mkCaseBinding :: Bool -> LVar -> Int -> [Name] -> SExp -> Either String Exp
580+mkCaseBinding checked var parentStackStart params branchExpression =
581+ (\ bindingMethod ->
582+ MethodInv $ PrimaryMethodCall
583+ ( MethodInv $ PrimaryMethodCall (InstanceCreation []
584+ (ClassType [(Ident "Object", [])])
585+ []
586+ (Just $ ClassBody [MemberDecl $ bindingMethod])
587+ )
588+ []
589+ (Ident "apply")
590+ ( contextArray
591+ : (mkCaseBindingDeconstruction var params)
592+ )
593+ )
594+ []
595+ (Ident "call")
596+ []
597+ )
598+ <$> mkCaseBindingMethod checked parentStackStart params branchExpression
599+
600+
601+
602+mkCaseBindingMethod :: Bool -> Int -> [Name] -> SExp -> Either String MemberDecl
603+mkCaseBindingMethod checked parentStackStart params branchExpression =
604+ (\ formalParams caseBindingStack branchExpression ->
605+ MethodDecl [Final, Public]
606+ []
607+ (Just . RefType $ ClassRefType idrisClosureType)
608+ (Ident "apply")
609+ (mkContextParam:formalParams)
610+ []
611+ (MethodBody . Just . Block $
612+ caseBindingStack ++
613+ [BlockStmt . Return $ Just branchExpression]))
614+ <$> mapM mkFormalParam params
615+ <*> mkBindingStack checked parentStackStart params
616+ <*> mkBindingClosure branchExpression
617+
618+mkCaseBindingDeconstruction :: LVar -> [Name] -> [Exp]
619+mkCaseBindingDeconstruction var members =
620+ map (mkProjection var) ([0..(length members - 1)])
621+
622+mkProjection :: LVar -> Int -> Exp
623+mkProjection var memberNr =
624+ ArrayAccess $ ArrayIndex ( MethodInv $ PrimaryMethodCall
625+ (mkVarAccess (Just idrisObjectType) var)
626+ []
627+ (Ident "getData")
628+ []
629+ )
630+ (Lit $ Int (toInteger memberNr))
631+
632+type ClassName = String
633+
634+mkPrimitive :: ClassName -> Literal -> Exp
635+mkPrimitive className value =
636+ MethodInv $ TypeMethodCall (J.Name [Ident className])
637+ []
638+ (Ident "valueOf")
639+ [Lit $ value]
640+
641+mkClass :: ClassType -> Exp
642+mkClass classType =
643+ ClassLit . Just . RefType .ClassRefType $ classType
644+
645+mkBinOpExp :: ClassType -> Op -> [LVar] -> Exp
646+mkBinOpExp castTo op (var:vars) =
647+ foldl (\ exp -> BinOp exp op . mkVarAccess (Just castTo))
648+ (mkVarAccess (Just castTo) var)
649+ vars
650+
651+mkBinOpExpTrans :: (Exp -> Exp) -> (Exp -> Exp) -> ClassType -> Op -> [LVar] -> Exp
652+mkBinOpExpTrans opTransformation resultTransformation castTo op (var:vars) =
653+ foldl (\ exp -> resultTransformation
654+ . BinOp (opTransformation exp) op
655+ . opTransformation
656+ . mkVarAccess (Just castTo))
657+ (mkVarAccess (Just castTo) var)
658+ vars
659+
660+mkBinOpExpConv :: String -> PrimType -> ClassType -> Op -> [LVar] -> Exp
661+mkBinOpExpConv fromMethodName toType fromType@(ClassType [(cls@(Ident _), [])]) op args =
662+ mkBinOpExpTrans (\ exp -> MethodInv $ TypeMethodCall (J.Name [cls])
663+ []
664+ (Ident fromMethodName)
665+ [exp]
666+ )
667+ (\ exp -> MethodInv $ TypeMethodCall (J.Name [cls])
668+ []
669+ (Ident "valueOf")
670+ [Cast (PrimType $ toType) exp]
671+ )
672+ fromType
673+ op
674+ args
675+
676+mkLogicalBinOpExp :: ClassType -> Op -> [LVar] -> Exp
677+mkLogicalBinOpExp castTo op (var:vars) =
678+ foldl (\ exp -> mkBoolToNumber castTo . BinOp exp op . mkVarAccess (Just castTo))
679+ (mkVarAccess (Just castTo) var)
680+ vars
681+
682+mkMethodOpChain1 :: (Exp -> Exp) -> ClassType -> String -> [LVar] -> Exp
683+mkMethodOpChain1 = mkMethodOpChain id
684+
685+mkMethodOpChain :: (Exp -> Exp) -> (Exp -> Exp) -> ClassType -> String -> [LVar] -> Exp
686+mkMethodOpChain initialTransformation resultTransformation castTo method (arg:args) =
687+ foldl (\ exp arg' ->
688+ resultTransformation . MethodInv $ PrimaryMethodCall exp
689+ []
690+ (Ident method)
691+ [mkVarAccess (Just $ castTo) arg']
692+ )
693+ (initialTransformation (mkVarAccess (Just $ castTo) arg))
694+ args
695+
696+mkBoolToNumber :: ClassType -> Exp -> Exp
697+mkBoolToNumber (ClassType [(Ident name, [])]) boolExp =
698+ Cond boolExp (mkPrimitive name (Int 1)) (mkPrimitive name (Int 0))
699+
700+mkZeroExt :: String -> Int -> ClassType -> ClassType -> LVar -> Exp
701+mkZeroExt toMethod bits fromType toType@(ClassType [(toTypeName, [])]) var =
702+ MethodInv $ TypeMethodCall (J.Name [toTypeName])
703+ []
704+ (Ident "valueOf")
705+ [ Cond ( BinOp (mkVarAccess (Just $ fromType) var)
706+ LThan
707+ (Lit $ Int 0)
708+ )
709+ ( BinOp (Lit $ Int (2^bits))
710+ Add
711+ (mkSignedExt' toMethod fromType var)
712+ )
713+ (mkSignedExt' toMethod fromType var)
714+ ]
715+
716+mkSignedExt :: String -> ClassType -> ClassType -> LVar -> Exp
717+mkSignedExt toMethod fromType (ClassType [(toTypeName, [])]) var =
718+ MethodInv $ TypeMethodCall (J.Name [toTypeName])
719+ []
720+ (Ident "valueOf")
721+ [ mkSignedExt' toMethod fromType var ]
722+
723+mkSignedExt' :: String -> ClassType -> LVar -> Exp
724+mkSignedExt' toMethod fromType var =
725+ MethodInv $ PrimaryMethodCall (mkVarAccess (Just $ fromType) var)
726+ []
727+ (Ident toMethod)
728+ []
729+
730+data SPartialOrder
731+ = SLt
732+ | SLe
733+ | SEq
734+ | SGe
735+ | SGt
736+
737+mkPartialOrder :: SPartialOrder -> Exp -> Exp
738+mkPartialOrder SLt x = (BinOp (Lit $ Int (-1)) Equal x)
739+mkPartialOrder SLe x =
740+ BinOp (BinOp (Lit $ Int (-1)) Equal x)
741+ COr
742+ (BinOp (Lit $ Int 0) Equal x)
743+mkPartialOrder SEq x = BinOp (Lit $ Int 0) Equal x
744+mkPartialOrder SGe x =
745+ BinOp (BinOp (Lit $ Int 1) Equal x)
746+ COr
747+ (BinOp (Lit $ Int 0) Equal x)
748+mkPartialOrder SGt x = (BinOp (Lit $ Int 1) Equal x)
749+
750+mkVarAccess :: Maybe ClassType -> LVar -> Exp
751+mkVarAccess Nothing (Loc i) =
752+ ArrayAccess $ ArrayIndex contextArray (Lit $ Int (toInteger i))
753+mkVarAccess (Just castTo) var =
754+ Cast (RefType . ClassRefType $ castTo) (mkVarAccess Nothing var)
755+
756+mkPrimitiveCast :: ClassType -> ClassType -> LVar -> Exp
757+mkPrimitiveCast fromType (ClassType [(toType, [])]) var =
758+ MethodInv $ TypeMethodCall (J.Name [toType])
759+ []
760+ (Ident "valueOf")
761+ [mkVarAccess (Just fromType) var]
762+
763+mkToString :: ClassType -> LVar -> Exp
764+mkToString castTo var =
765+ MethodInv $ PrimaryMethodCall (mkVarAccess (Just castTo) var)
766+ []
767+ (Ident "toString")
768+ []
769+
770+data Std = In | Out | Err
771+
772+instance Show Std where
773+ show In = "in"
774+ show Out = "out"
775+ show Err = "err"
776+
777+mkSystemStd :: Std -> Exp
778+mkSystemStd std = FieldAccess $ PrimaryFieldAccess (ExpName $ J.Name [Ident "System"]) (Ident $ show std)
779+
780+mkSystemOutPrint :: Exp -> Exp
781+mkSystemOutPrint value =
782+ MethodInv $ PrimaryMethodCall (mkSystemStd Out)
783+ []
784+ (Ident "print")
785+ [value]
786+
787+mkMathFun :: String -> LVar -> Exp
788+mkMathFun funName var =
789+ MethodInv $ TypeMethodCall (J.Name [Ident "Double"])
790+ []
791+ (Ident "valueOf")
792+ [ MethodInv $ TypeMethodCall (J.Name [Ident "Math"])
793+ []
794+ (Ident funName)
795+ [mkVarAccess (Just doubleType) var]
796+ ]
797+
798+mkStringAtIndex :: LVar -> Exp -> Exp
799+mkStringAtIndex var indexExp =
800+ MethodInv $ TypeMethodCall (J.Name [Ident "Integer"])
801+ []
802+ (Ident "valueOf")
803+ [ MethodInv $ PrimaryMethodCall (mkVarAccess (Just stringType) var)
804+ []
805+ (Ident "charAt")
806+ [indexExp]
807+ ]
808+
809+mkForeignType :: FType -> Maybe ClassType
810+mkForeignType FInt = return $ integerType
811+mkForeignType FChar = return $ integerType
812+mkForeignType FString = return $ stringType
813+mkForeignType FPtr = return $ objectType
814+mkForeignType FDouble = return $ doubleType
815+mkForeignType FAny = return $ objectType
816+mkForeignType FUnit = Nothing
817+
818+mkForeignVarAccess :: FType -> LVar -> Exp
819+mkForeignVarAccess FInt var =
820+ MethodInv $ PrimaryMethodCall (mkVarAccess (Just integerType) var)
821+ []
822+ (Ident "intValue")
823+ []
824+mkForeignVarAccess FChar var = Cast (PrimType CharT) (mkForeignVarAccess FInt var)
825+mkForeignVarAccess FDouble var =
826+ MethodInv $ PrimaryMethodCall (mkVarAccess (Just doubleType) var)
827+ []
828+ (Ident "doubleValue")
829+ []
830+mkForeignVarAccess otherType var = mkVarAccess (mkForeignType otherType) var
831+
832+mkFromForeignType :: FType -> Exp -> Exp
833+mkFromForeignType FInt from =
834+ MethodInv $ TypeMethodCall (J.Name [Ident "Integer"])
835+ []
836+ (Ident "valueOf")
837+ [from]
838+mkFromForeignType FChar from = mkFromForeignType FInt from
839+mkFromForeignType FDouble from =
840+ MethodInv $ TypeMethodCall (J.Name [Ident "Double"])
841+ []
842+ (Ident "valueOf")
843+ [from]
844+mkFromForeignType _ from = from
845+
846+mkForeignInvoke :: FType -> String -> [(FType, LVar)] -> Either String Exp
847+mkForeignInvoke fType method args =
848+ (\ foreignInvokeMeth ->
849+ MethodInv $ PrimaryMethodCall (InstanceCreation []
850+ objectType
851+ []
852+ (Just $ ClassBody [ MemberDecl $ foreignInvokeMeth ])
853+ )
854+ []
855+ (Ident "foreignInvoke")
856+ []
857+ )
858+ <$> mkForeignInvokeMethod fType method args
859+
860+
861+mkForeignInvokeMethod :: FType -> String -> [(FType, LVar)] -> Either String MemberDecl
862+mkForeignInvokeMethod fType method args =
863+ (\ tryBlock ->
864+ MethodDecl [Public, Final]
865+ []
866+ (Just . RefType $ ClassRefType objectType)
867+ (Ident "foreignInvoke")
868+ []
869+ []
870+ (MethodBody . Just $ Block [ BlockStmt $
871+ Try tryBlock
872+ [ Catch (FormalParam []
873+ (RefType $ ClassRefType exceptionType)
874+ False
875+ (VarId $ Ident "ex")
876+ )
877+ (Block [ BlockStmt . Throw $
878+ InstanceCreation []
879+ runtimeExceptionType
880+ [ExpName $ J.Name [Ident "ex"]]
881+ Nothing
882+ ]
883+ )
884+ ]
885+ Nothing
886+ ]
887+ )
888+ )
889+ <$> mkForeignInvokeTryBlock fType method args
890+
891+
892+mkForeignInvokeTryBlock :: FType -> String -> [(FType, LVar)] -> Either String Block
893+mkForeignInvokeTryBlock FUnit method args =
894+ (\ method -> Block [ BlockStmt . ExpStmt . MethodInv $
895+ MethodCall method
896+ (map (uncurry mkForeignVarAccess) args)
897+ , BlockStmt $ Return (Just $ Lit Null)
898+ ]
899+ )
900+ <$> ( left (\ err -> "Error parsing name \"" ++ method ++ "\" :" ++ (show err))
901+ (parser name method)
902+ )
903+mkForeignInvokeTryBlock fType method args =
904+ (\ method -> Block [ BlockStmt . Return
905+ . Just
906+ . mkFromForeignType fType
907+ . MethodInv $
908+ MethodCall method
909+ (map (uncurry mkForeignVarAccess) args)
910+ ]
911+ )
912+ <$> ( left (\ err -> "Error parsing name \"" ++ method ++ "\" :" ++ (show err))
913+ (parser name method)
914+ )
915+
916+mkMethodClosure :: Name -> [LVar] -> Either String Exp
917+mkMethodClosure name args =
918+ (\ name args ->
919+ InstanceCreation []
920+ idrisClosureType
921+ [ (ExpName $ J.Name [Ident "context"]) ]
922+ ( Just $ ClassBody
923+ [ MemberDecl $
924+ MethodDecl [Public, Final]
925+ []
926+ (Just . RefType $ ClassRefType objectType)
927+ (Ident "call")
928+ []
929+ []
930+ ( MethodBody . Just $
931+ Block [ BlockStmt . Return . Just . MethodInv $
932+ MethodCall (reverseNameSpace name)
933+ args
934+ ]
935+ )
936+ ]
937+ )
938+ )
939+ <$> mkName name
940+ <*> mapM (mkExp . SV) args
941+
942+mkThread :: LVar -> Either String Exp
943+mkThread arg =
944+ (\ eval -> MethodInv $
945+ PrimaryMethodCall (InstanceCreation []
946+ (ClassType [(Ident "Thread", [])])
947+ [ eval ]
948+ ( Just $ ClassBody
949+ [ MemberDecl $ MethodDecl
950+ [Public, Final]
951+ []
952+ (Just . RefType $ ClassRefType objectType)
953+ (Ident "_start")
954+ []
955+ []
956+ ( MethodBody . Just $ Block
957+ [ BlockStmt . ExpStmt . MethodInv $ MethodCall
958+ (J.Name [Ident "start"])
959+ []
960+ , BlockStmt . Return . Just $ This
961+ ]
962+ )
963+ ]
964+ )
965+ )
966+ []
967+ (Ident "_start")
968+ []
969+ )
970+ <$> mkThreadBinding arg
971+
972+mkThreadBinding :: LVar -> Either String Exp
973+mkThreadBinding var =
974+ (\ bindingMethod ->
975+ MethodInv $ PrimaryMethodCall ( InstanceCreation []
976+ objectType
977+ []
978+ (Just $ ClassBody [MemberDecl $ bindingMethod])
979+ )
980+ []
981+ (Ident "apply")
982+ [ mkVarAccess Nothing var ]
983+ )
984+ <$> mkThreadBindingMethod
985+
986+
987+mkThreadBindingMethod :: Either String MemberDecl
988+mkThreadBindingMethod =
989+ (\ compute ->
990+ MethodDecl [Final, Public]
991+ []
992+ (Just . RefType $ ClassRefType idrisClosureType)
993+ (Ident "apply")
994+ [ FormalParam [Final] (RefType . ClassRefType $ objectType) False (VarId $ Ident "param") ]
995+ []
996+ (MethodBody . Just $ Block
997+ [ mkThreadBindingStack
998+ , BlockStmt . Return $ Just compute
999+ ]
1000+ )
1001+ )
1002+ <$> mkBindingClosure (SUpdate (Loc 0) (SApp False (MN 0 "EVAL") [Loc 0]))
1003+
1004+
1005+mkThreadBindingStack :: BlockStmt
1006+mkThreadBindingStack =
1007+ LocalVars [Final]
1008+ objectArrayType
1009+ [ VarDecl (VarDeclArray . VarId $ Ident "new_context")
1010+ (Just . InitArray $ ArrayInit [InitExp . ExpName $ J.Name [Ident "param"]])
1011+ ]
1012+
231013
1014+mkExp :: SExp -> Either String Exp
1015+mkExp (SV var) =
1016+ return $ mkVarAccess Nothing var
1017+mkExp (SApp False name args) =
1018+ (\ methClosure ->
1019+ MethodInv $ PrimaryMethodCall ( InstanceCreation []
1020+ idrisTailCallClosureType
1021+ [ methClosure ]
1022+ Nothing
1023+ )
1024+ []
1025+ (Ident "call")
1026+ []
1027+ )
1028+ <$> mkMethodClosure name args
1029+mkExp (SApp True name args) =
1030+ (\ methClosure ->
1031+ ( InstanceCreation []
1032+ idrisTailCallClosureType
1033+ [ methClosure ]
1034+ Nothing
1035+ )
1036+ )
1037+ <$> mkMethodClosure name args
1038+mkExp (SLet var new old) =
1039+ mkAnonymousLetBinding var old new
1040+mkExp (SUpdate (Loc i) exp) =
1041+ (\ rhs -> Assign (ArrayLhs $ ArrayIndex (contextArray) (Lit $ Int (toInteger i)))
1042+ EqualA
1043+ rhs)
1044+ <$> mkExp exp
1045+mkExp (SCon conId name args) =
1046+ (\ args -> InstanceCreation []
1047+ idrisObjectType
1048+ ((Lit $ Int (toInteger conId)):args)
1049+ Nothing)
1050+ <$> mapM (mkExp .SV) args
1051+mkExp (SCase var alts) = mkCase False var alts
1052+mkExp (SChkCase var alts) = mkCase True var alts
1053+mkExp (SProj var i) = return $ mkProjection var i
1054+mkExp (SConst (I x)) = return $ mkPrimitive "Integer" (Int (toInteger x))
1055+mkExp (SConst (BI x)) =
1056+ return $ InstanceCreation []
1057+ (ClassType [(Ident "BigInteger", [])])
1058+ [Lit $ String (show x)]
1059+ Nothing
1060+mkExp (SConst (Fl x)) = return $ mkPrimitive "Double" (Double x)
1061+mkExp (SConst (Ch x)) = return $ mkPrimitive "Integer" (Char x)
1062+mkExp (SConst (Str x)) = return $ Lit $ String x
1063+mkExp (SConst IType) = return $ mkClass integerType
1064+mkExp (SConst BIType) = return $ mkClass bigIntegerType
1065+mkExp (SConst FlType) = return $ mkClass doubleType
1066+mkExp (SConst ChType) = return $ mkClass charType
1067+mkExp (SConst StrType) = return $ mkClass stringType
1068+mkExp (SConst (B8 x)) = return $ mkPrimitive "Byte" (Int (toInteger x))
1069+mkExp (SConst (B16 x)) = return $ mkPrimitive "Short" (Int (toInteger x))
1070+mkExp (SConst (B32 x)) = return $ mkPrimitive "Integer" (Int (toInteger x))
1071+mkExp (SConst (B64 x)) = return $ mkPrimitive "Long" (Int (toInteger x))
1072+mkExp (SConst (B8Type))= return $ mkClass byteType
1073+mkExp (SConst (B16Type)) = return $ mkClass shortType
1074+mkExp (SConst (B32Type)) = return $ mkClass integerType
1075+mkExp (SConst (B64Type)) = return $ mkClass longType
1076+mkExp (SConst (PtrType)) = return $ mkClass objectType
1077+mkExp (SConst (VoidType)) = return $ mkClass voidType
1078+mkExp (SConst (Forgot)) = return $ mkClass objectType
1079+mkExp (SForeign _ fType meth args) = mkForeignInvoke fType meth args
1080+mkExp (SOp LPlus args) = return $ mkBinOpExp integerType Add args
1081+mkExp (SOp LMinus args) = return $ mkBinOpExp integerType Sub args
1082+mkExp (SOp LTimes args) = return $ mkBinOpExp integerType Mult args
1083+mkExp (SOp LDiv args) = return $ mkBinOpExp integerType Div args
1084+mkExp (SOp LMod args) = return $ mkBinOpExp integerType Rem args
1085+mkExp (SOp LAnd args) = return $ mkBinOpExp integerType And args
1086+mkExp (SOp LOr args) = return $ mkBinOpExp integerType Or args
1087+mkExp (SOp LXOr args) = return $ mkBinOpExp integerType Xor args
1088+mkExp (SOp LCompl [var]) =
1089+ return $ PreBitCompl (mkVarAccess (Just $ integerType) var)
1090+mkExp (SOp LSHL args) = return $ mkBinOpExp integerType LShift args
1091+mkExp (SOp LSHR args) = return $ mkBinOpExp integerType RShift args
1092+mkExp (SOp LEq args) =
1093+ return $ mkMethodOpChain1 (mkBoolToNumber integerType) objectType "equals" args
1094+mkExp (SOp LLt args) = return $ mkLogicalBinOpExp integerType LThan args
1095+mkExp (SOp LLe args) = return $ mkLogicalBinOpExp integerType LThanE args
1096+mkExp (SOp LGt args) = return $ mkLogicalBinOpExp integerType GThan args
1097+mkExp (SOp LGe args) = return $ mkLogicalBinOpExp integerType GThanE args
1098+mkExp (SOp LFPlus args) = return $ mkBinOpExp doubleType Add args
1099+mkExp (SOp LFMinus args) = return $ mkBinOpExp doubleType Sub args
1100+mkExp (SOp LFTimes args) = return $ mkBinOpExp doubleType Mult args
1101+mkExp (SOp LFDiv args) = return $ mkBinOpExp doubleType Div args
1102+mkExp (SOp LFEq args) =
1103+ return $ mkMethodOpChain1 (mkBoolToNumber doubleType) doubleType "equals" args
1104+mkExp (SOp LFLt args) = return $ mkLogicalBinOpExp integerType LThan args
1105+mkExp (SOp LFLe args) = return $ mkLogicalBinOpExp integerType LThanE args
1106+mkExp (SOp LFGt args) = return $ mkLogicalBinOpExp integerType GThan args
1107+mkExp (SOp LFGe args) = return $ mkLogicalBinOpExp integerType GThanE args
1108+mkExp (SOp LBPlus args) = return $ mkMethodOpChain1 id bigIntegerType "add" args
1109+mkExp (SOp LBMinus args) = return $ mkMethodOpChain1 id bigIntegerType "subtract" args
1110+mkExp (SOp LBTimes args) = return $ mkMethodOpChain1 id bigIntegerType "multiply" args
1111+mkExp (SOp LBDiv args) = return $ mkMethodOpChain1 id bigIntegerType "divide" args
1112+mkExp (SOp LBMod args) = return $ mkMethodOpChain1 id bigIntegerType "mod" args
1113+mkExp (SOp LBEq args) =
1114+ return $ mkMethodOpChain1 (mkBoolToNumber bigIntegerType) bigIntegerType "equals" args
1115+mkExp (SOp LBLt args) =
1116+ return $ mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1117+ . mkPartialOrder SLt
1118+ )
1119+ bigIntegerType
1120+ "compare"
1121+ args
1122+mkExp (SOp LBLe args) =
1123+ return $ mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1124+ . mkPartialOrder SLe
1125+ )
1126+ bigIntegerType
1127+ "compare"
1128+ args
1129+mkExp (SOp LBGt args) =
1130+ return $ mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1131+ . mkPartialOrder SGt
1132+ )
1133+ bigIntegerType
1134+ "compare"
1135+ args
1136+mkExp (SOp LBGe args) =
1137+ return $ mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1138+ . mkPartialOrder SGe
1139+ )
1140+ bigIntegerType
1141+ "compare"
1142+ args
1143+mkExp (SOp LStrConcat args) =
1144+ return $ mkMethodOpChain (\ exp ->
1145+ InstanceCreation []
1146+ (ClassType [(Ident "StringBuilder", [])])
1147+ [exp]
1148+ Nothing
1149+ )
1150+ (\ exp -> MethodInv $ PrimaryMethodCall exp [] (Ident "toString") [])
1151+ stringType
1152+ "append"
1153+ args
1154+mkExp (SOp LStrLt args@[_, _]) =
1155+ return $ mkMethodOpChain1 ( mkBoolToNumber integerType
1156+ . mkPartialOrder SLt
1157+ )
1158+ stringType
1159+ "compare"
1160+ args
1161+mkExp (SOp LStrEq args@[_, _]) =
1162+ return $ mkMethodOpChain1 ( mkBoolToNumber integerType)
1163+ stringType
1164+ "equals"
1165+ args
1166+mkExp (SOp LStrLen [arg]) =
1167+ return . MethodInv $ PrimaryMethodCall (mkVarAccess (Just stringType) arg) [] (Ident "length") []
1168+mkExp (SOp LIntFloat [arg]) =
1169+ return $ mkPrimitiveCast integerType doubleType arg
1170+mkExp (SOp LFloatInt [arg]) =
1171+ return $ mkPrimitiveCast doubleType integerType arg
1172+mkExp (SOp LIntStr [arg]) =
1173+ return $ mkToString integerType arg
1174+mkExp (SOp LStrInt [arg]) =
1175+ return $ mkPrimitiveCast stringType integerType arg
1176+mkExp (SOp LFloatStr [arg]) =
1177+ return $ mkToString doubleType arg
1178+mkExp (SOp LStrFloat [arg]) =
1179+ return $ mkPrimitiveCast doubleType stringType arg
1180+mkExp (SOp LIntBig [arg]) =
1181+ return $ mkPrimitiveCast integerType bigIntegerType arg
1182+mkExp (SOp LBigInt [arg]) =
1183+ return $ mkPrimitiveCast bigIntegerType integerType arg
1184+mkExp (SOp LStrBig [arg]) =
1185+ return $ InstanceCreation [] bigIntegerType [mkVarAccess (Just stringType) arg] Nothing
1186+mkExp (SOp LBigStr [arg]) =
1187+ return $ mkToString bigIntegerType arg
1188+mkExp (SOp LChInt [arg]) =
1189+ return $ mkVarAccess (Just integerType) arg
1190+mkExp (SOp LIntCh [arg]) =
1191+ return $ mkVarAccess (Just integerType) arg
1192+mkExp (SOp LPrintNum [arg]) =
1193+ return $ mkSystemOutPrint (mkVarAccess Nothing arg)
1194+mkExp (SOp LPrintStr [arg]) =
1195+ return $ mkSystemOutPrint (mkVarAccess (Just stringType) arg)
1196+mkExp (SOp LReadStr [arg]) = mkExp (SForeign LANG_C FString "idris_readStr" [(FPtr, arg)])
1197+mkExp (SOp LB8Lt args) = return $ mkLogicalBinOpExp byteType LThan args
1198+mkExp (SOp LB8Lte args) = return $ mkLogicalBinOpExp byteType LThanE args
1199+mkExp (SOp LB8Eq args) =
1200+ return $ mkMethodOpChain1 (mkBoolToNumber byteType) byteType "equals" args
1201+mkExp (SOp LB8Gt args) = return $ mkLogicalBinOpExp byteType GThan args
1202+mkExp (SOp LB8Gte args) = return $ mkLogicalBinOpExp byteType GThanE args
1203+mkExp (SOp LB8Plus args) = return $ mkBinOpExp byteType Add args
1204+mkExp (SOp LB8Minus args) = return $ mkBinOpExp byteType Sub args
1205+mkExp (SOp LB8Times args) = return $ mkBinOpExp byteType Mult args
1206+mkExp (SOp LB8UDiv args) = return $ mkBinOpExpConv "shortValue" ShortT byteType Div args
1207+mkExp (SOp LB8SDiv args) = return $ mkBinOpExp byteType Div args
1208+mkExp (SOp LB8URem args) = return $ mkBinOpExpConv "shortValue" ShortT byteType Rem args
1209+mkExp (SOp LB8SRem args) = return $ mkBinOpExp byteType Rem args
1210+mkExp (SOp LB8Shl args) = return $ mkBinOpExp byteType LShift args
1211+mkExp (SOp LB8LShr args) = return $ mkBinOpExp byteType RRShift args
1212+mkExp (SOp LB8AShr args) = return $ mkBinOpExp byteType RShift args
1213+mkExp (SOp LB8And args) = return $ mkBinOpExp byteType And args
1214+mkExp (SOp LB8Or args) = return $ mkBinOpExp byteType Or args
1215+mkExp (SOp LB8Xor args) = return $ mkBinOpExp byteType Xor args
1216+mkExp (SOp LB8Compl [var]) =
1217+ return $ PreBitCompl (mkVarAccess (Just $ byteType) var)
1218+mkExp (SOp LB8Z16 [var]) = return $ mkZeroExt "shortValue" 8 byteType shortType var
1219+mkExp (SOp LB8Z32 [var]) = return $ mkZeroExt "intValue" 8 byteType integerType var
1220+mkExp (SOp LB8Z64 [var]) = return $ mkZeroExt "longValue" 8 byteType longType var
1221+mkExp (SOp LB8S16 [var]) = return $ mkSignedExt "shortValue" byteType shortType var
1222+mkExp (SOp LB8S32 [var]) = return $ mkSignedExt "intValue" byteType integerType var
1223+mkExp (SOp LB8S64 [var]) = return $ mkSignedExt "longValue" byteType longType var
1224+mkExp (SOp LB16Lt args) = return $ mkLogicalBinOpExp shortType LThan args
1225+mkExp (SOp LB16Lte args) = return $ mkLogicalBinOpExp shortType LThanE args
1226+mkExp (SOp LB16Eq args) =
1227+ return $ mkMethodOpChain1 (mkBoolToNumber shortType) shortType "equals" args
1228+mkExp (SOp LB16Gt args) = return $ mkLogicalBinOpExp shortType GThan args
1229+mkExp (SOp LB16Gte args) = return $ mkLogicalBinOpExp shortType GThanE args
1230+mkExp (SOp LB16Plus args) = return $ mkBinOpExp shortType Add args
1231+mkExp (SOp LB16Minus args) = return $ mkBinOpExp shortType Sub args
1232+mkExp (SOp LB16Times args) = return $ mkBinOpExp shortType Mult args
1233+mkExp (SOp LB16UDiv args) = return $ mkBinOpExpConv "intValue" IntT shortType Div args
1234+mkExp (SOp LB16SDiv args) = return $ mkBinOpExp shortType Div args
1235+mkExp (SOp LB16URem args) = return $ mkBinOpExpConv "intValue" IntT shortType Rem args
1236+mkExp (SOp LB16SRem args) = return $ mkBinOpExp shortType Rem args
1237+mkExp (SOp LB16Shl args) = return $ mkBinOpExp shortType LShift args
1238+mkExp (SOp LB16LShr args) = return $ mkBinOpExp shortType RRShift args
1239+mkExp (SOp LB16AShr args) = return $ mkBinOpExp shortType RShift args
1240+mkExp (SOp LB16And args) = return $ mkBinOpExp shortType And args
1241+mkExp (SOp LB16Or args) = return $ mkBinOpExp shortType Or args
1242+mkExp (SOp LB16Xor args) = return $ mkBinOpExp shortType Xor args
1243+mkExp (SOp LB16Compl [var]) =
1244+ return $ PreBitCompl (mkVarAccess (Just $ shortType) var)
1245+mkExp (SOp LB16Z32 [var]) = return $ mkZeroExt "intValue" 16 shortType integerType var
1246+mkExp (SOp LB16Z64 [var]) = return $ mkZeroExt "longValue" 16 shortType longType var
1247+mkExp (SOp LB16S32 [var]) = return $ mkSignedExt "intValue" shortType integerType var
1248+mkExp (SOp LB16S64 [var]) = return $ mkSignedExt "longValue" shortType longType var
1249+mkExp (SOp LB16T8 [var]) =
1250+ return . MethodInv $
1251+ TypeMethodCall (J.Name [Ident "Byte"])
1252+ []
1253+ (Ident "valueOf")
1254+ [ MethodInv $ PrimaryMethodCall (mkVarAccess (Just $ shortType) var) [] (Ident "byteValue") [] ]
1255+mkExp (SOp LB32Lt args) = return $ mkLogicalBinOpExp integerType LThan args
1256+mkExp (SOp LB32Lte args) = return $ mkLogicalBinOpExp integerType LThanE args
1257+mkExp (SOp LB32Eq args) =
1258+ return $ mkMethodOpChain1 (mkBoolToNumber integerType) integerType "equals" args
1259+mkExp (SOp LB32Gt args) = return $ mkLogicalBinOpExp integerType GThan args
1260+mkExp (SOp LB32Gte args) = return $ mkLogicalBinOpExp integerType GThanE args
1261+mkExp (SOp LB32Plus args) = return $ mkBinOpExp integerType Add args
1262+mkExp (SOp LB32Minus args) = return $ mkBinOpExp integerType Sub args
1263+mkExp (SOp LB32Times args) = return $ mkBinOpExp integerType Mult args
1264+mkExp (SOp LB32UDiv args) = return $ mkBinOpExpConv "longValue" LongT integerType Div args
1265+mkExp (SOp LB32SDiv args) = return $ mkBinOpExp integerType Div args
1266+mkExp (SOp LB32URem args) = return $ mkBinOpExpConv "longValue" LongT integerType Rem args
1267+mkExp (SOp LB32SRem args) = return $ mkBinOpExp integerType Rem args
1268+mkExp (SOp LB32Shl args) = return $ mkBinOpExp integerType LShift args
1269+mkExp (SOp LB32LShr args) = return $ mkBinOpExp integerType RRShift args
1270+mkExp (SOp LB32AShr args) = return $ mkBinOpExp integerType RShift args
1271+mkExp (SOp LB32And args) = return $ mkBinOpExp integerType And args
1272+mkExp (SOp LB32Or args) = return $ mkBinOpExp integerType Or args
1273+mkExp (SOp LB32Xor args) = return $ mkBinOpExp integerType Xor args
1274+mkExp (SOp LB32Compl [var]) =
1275+ return $ PreBitCompl (mkVarAccess (Just $ integerType) var)
1276+mkExp (SOp LB32Z64 [var]) = return $ mkZeroExt "longValue" 32 integerType longType var
1277+mkExp (SOp LB32S64 [var]) = return $ mkSignedExt "longValue" integerType longType var
1278+mkExp (SOp LB32T8 [var]) =
1279+ return . MethodInv $
1280+ TypeMethodCall (J.Name [Ident "Byte"])
1281+ []
1282+ (Ident "valueOf")
1283+ [ MethodInv $ PrimaryMethodCall (mkVarAccess (Just $ integerType) var) [] (Ident "byteValue") [] ]
1284+mkExp (SOp LB32T16 [var]) =
1285+ return . MethodInv $
1286+ TypeMethodCall (J.Name [Ident "Short"])
1287+ []
1288+ (Ident "valueOf")
1289+ [ MethodInv $ PrimaryMethodCall (mkVarAccess (Just $ integerType) var) [] (Ident "shortValue") [] ]
1290+mkExp (SOp LB64Lt args) = return $ mkLogicalBinOpExp longType LThan args
1291+mkExp (SOp LB64Lte args) = return $ mkLogicalBinOpExp longType LThanE args
1292+mkExp (SOp LB64Eq args) =
1293+ return $ mkMethodOpChain1 (mkBoolToNumber longType) longType "equals" args
1294+mkExp (SOp LB64Gt args) = return $ mkLogicalBinOpExp longType GThan args
1295+mkExp (SOp LB64Gte args) = return $ mkLogicalBinOpExp longType GThanE args
1296+mkExp (SOp LB64Plus args) = return $ mkBinOpExp longType Add args
1297+mkExp (SOp LB64Minus args) = return $ mkBinOpExp longType Sub args
1298+mkExp (SOp LB64Times args) = return $ mkBinOpExp longType Mult args
1299+mkExp (SOp LB64UDiv (arg:args)) =
1300+ return $ foldl (\ exp arg ->
1301+ MethodInv $ PrimaryMethodCall
1302+ ( MethodInv $ PrimaryMethodCall
1303+ ( MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1304+ []
1305+ (Ident "valueOf")
1306+ [ exp ]
1307+ )
1308+ []
1309+ (Ident "divide")
1310+ [ MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1311+ []
1312+ (Ident "valueOf")
1313+ [ (mkVarAccess (Just longType) arg) ]
1314+ ]
1315+ )
1316+ []
1317+ (Ident "longValue")
1318+ []
1319+ )
1320+ (mkVarAccess (Just longType) arg)
1321+ args
1322+mkExp (SOp LB64SDiv args) = return $ mkBinOpExp longType Div args
1323+mkExp (SOp LB64URem (arg:args)) =
1324+ return $ foldl (\ exp arg ->
1325+ MethodInv $ PrimaryMethodCall
1326+ ( MethodInv $ PrimaryMethodCall
1327+ ( MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1328+ []
1329+ (Ident "valueOf")
1330+ [ exp ]
1331+ )
1332+ []
1333+ (Ident "remainder")
1334+ [ MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1335+ []
1336+ (Ident "valueOf")
1337+ [ (mkVarAccess (Just longType) arg) ]
1338+ ]
1339+ )
1340+ []
1341+ (Ident "longValue")
1342+ []
1343+ )
1344+ (mkVarAccess (Just longType) arg)
1345+ args
1346+mkExp (SOp LB64SRem args) = return $ mkBinOpExp longType Rem args
1347+mkExp (SOp LB64Shl args) = return $ mkBinOpExp longType LShift args
1348+mkExp (SOp LB64LShr args) = return $ mkBinOpExp longType RRShift args
1349+mkExp (SOp LB64AShr args) = return $ mkBinOpExp longType RShift args
1350+mkExp (SOp LB64And args) = return $ mkBinOpExp longType And args
1351+mkExp (SOp LB64Or args) = return $ mkBinOpExp longType Or args
1352+mkExp (SOp LB64Xor args) = return $ mkBinOpExp longType Xor args
1353+mkExp (SOp LB64Compl [var]) =
1354+ return $ PreBitCompl (mkVarAccess (Just $ longType) var)
1355+mkExp (SOp LB64T8 [var]) =
1356+ return . MethodInv $
1357+ TypeMethodCall (J.Name [Ident "Byte"])
1358+ []
1359+ (Ident "valueOf")
1360+ [ MethodInv $ PrimaryMethodCall (mkVarAccess (Just $ longType) var) [] (Ident "byteValue") [] ]
1361+mkExp (SOp LB64T16 [var]) =
1362+ return . MethodInv $
1363+ TypeMethodCall (J.Name [Ident "Short"])
1364+ []
1365+ (Ident "valueOf")
1366+ [ MethodInv $ PrimaryMethodCall (mkVarAccess (Just $ longType) var) [] (Ident "shortValue") [] ]
1367+mkExp (SOp LB64T32 [var]) =
1368+ return . MethodInv $
1369+ TypeMethodCall (J.Name [Ident "Integer"])
1370+ []
1371+ (Ident "valueOf")
1372+ [ MethodInv $ PrimaryMethodCall (mkVarAccess (Just $ longType) var) [] (Ident "intValue") [] ]
1373+mkExp (SOp LIntB8 [arg]) = mkExp (SOp LB32T8 [arg])
1374+mkExp (SOp LIntB16 [arg]) = mkExp (SOp LB32T16 [arg])
1375+mkExp (SOp LIntB32 [arg]) = mkExp (SV arg)
1376+mkExp (SOp LIntB64 [arg]) = mkExp (SOp LB32S64 [arg])
1377+mkExp (SOp LB32Int [arg]) = mkExp (SV arg)
1378+mkExp (SOp LFExp [arg]) = return $ mkMathFun "exp" arg
1379+mkExp (SOp LFLog [arg]) = return $ mkMathFun "log" arg
1380+mkExp (SOp LFSin [arg]) = return $ mkMathFun "sin" arg
1381+mkExp (SOp LFCos [arg]) = return $ mkMathFun "cos" arg
1382+mkExp (SOp LFTan [arg]) = return $ mkMathFun "tan" arg
1383+mkExp (SOp LFASin [arg]) = return $ mkMathFun "asin" arg
1384+mkExp (SOp LFACos [arg]) = return $ mkMathFun "acos" arg
1385+mkExp (SOp LFATan [arg]) = return $ mkMathFun "atan" arg
1386+mkExp (SOp LFSqrt [arg]) = return $ mkMathFun "sqrt" arg
1387+mkExp (SOp LFFloor [arg]) = return $ mkMathFun "floor" arg
1388+mkExp (SOp LFCeil [arg]) = return $ mkMathFun "ceil" arg
1389+mkExp (SOp LStrHead [arg]) = return $ mkStringAtIndex arg (Lit $ Int 0)
1390+mkExp (SOp LStrTail [arg]) =
1391+ return . MethodInv $ PrimaryMethodCall (mkVarAccess (Just stringType) arg)
1392+ []
1393+ (Ident "substring")
1394+ [Lit $ Int 1]
1395+mkExp (SOp LStrCons [c, cs]) =
1396+ return . MethodInv $
1397+ PrimaryMethodCall ( MethodInv $ PrimaryMethodCall (InstanceCreation []
1398+ (ClassType [(Ident "StringBuilder", [])])
1399+ [mkVarAccess (Just stringType) cs]
1400+ Nothing
1401+ )
1402+ []
1403+ (Ident "insert")
1404+ [ Lit $ Int 0,
1405+ Cast (PrimType CharT)
1406+ (MethodInv $ PrimaryMethodCall
1407+ (mkVarAccess (Just integerType) c)
1408+ []
1409+ (Ident "intValue")
1410+ []
1411+ )
1412+ ]
1413+ )
1414+ []
1415+ (Ident "toString")
1416+ []
1417+mkExp (SOp LStrIndex [str, i]) = return $ mkStringAtIndex str (mkVarAccess (Just integerType) i)
1418+mkExp (SOp LStrRev [str]) =
1419+ return . MethodInv $
1420+ PrimaryMethodCall ( MethodInv $ PrimaryMethodCall (InstanceCreation []
1421+ (ClassType [(Ident "StringBuffer", [])])
1422+ [mkVarAccess (Just stringType) str]
1423+ Nothing
1424+ )
1425+ []
1426+ (Ident "reverse")
1427+ []
1428+ )
1429+ []
1430+ (Ident "toString")
1431+ []
1432+mkExp (SOp LStdIn []) = return $ mkSystemStd In
1433+mkExp (SOp LStdOut []) = return $ mkSystemStd Out
1434+mkExp (SOp LStdErr []) = return $ mkSystemStd Err
1435+mkExp (SOp LFork [arg]) = mkThread arg
1436+mkExp (SOp LPar [arg]) = mkExp (SV arg)
1437+mkExp (SOp LVMPtr []) =
1438+ return . MethodInv $ TypeMethodCall (J.Name [Ident "Thread"]) [] (Ident "currentThread") []
1439+mkExp (SOp LNoOp args) = mkExp . SV $ last args
1440+mkExp (SNothing) = return $ Lit Null
1441+mkExp (SError err) =
1442+ return . MethodInv $
1443+ PrimaryMethodCall (InstanceCreation []
1444+ runtimeExceptionType
1445+ [Lit $ String err]
1446+ ( Just $ ClassBody
1447+ [ MemberDecl $ MethodDecl [Public, Final]
1448+ []
1449+ (Just . RefType $ ClassRefType objectType)
1450+ (Ident "throwSelf")
1451+ []
1452+ []
1453+ ( MethodBody . Just $
1454+ Block [ BlockStmt (Throw This) ]
1455+ )
1456+ ]
1457+ )
1458+ )
1459+ []
1460+ (Ident "throwSelf")
1461+ []
1462+mkExp other = error (show other)
test/Makefile+4−1
@@ -1,6 +1,9 @@
11test:
22 perl ./runtest.pl all
33
4+test_java:
5+ perl ./runtest.pl all --java
6+
47update:
58 perl ./runtest.pl all -u
69
@@ -9,4 +12,4 @@ diff:
912
1013distclean:
1114 rm -f *~
12− rm -f */output
15+ rm -f */output
test/mkjavatest.plnew file+24
@@ -0,0 +1,24 @@
1+#!/usr/bin/perl
2+
3+if ($#ARGV>=0) {
4+ $test=shift(@ARGV);
5+} else {
6+ print "What's its name?\n";
7+ exit;
8+}
9+
10+mkdir($test);
11+
12+chdir($test);
13+open(FOO,">run_java");
14+
15+print FOO "#!/bin/bash\n";
16+print FOO "idris \$@ $test.idr -o $test.java --target Java\n";
17+print FOO "export CLASSPATH=../../java/idris.jar:\$CLASSPATH\n";
18+print FOO "javac $test.java\n";
19+print FOO "java $test\n";
20+print FOO "rm -f $test.java *.class\n";
21+
22+close(FOO);
23+
24+system("chmod +x run_java");
test/reg002/run_javanew file+6
@@ -0,0 +1,6 @@
1+#!/bin/bash
2+idris $@ reg002.idr -o reg002.java --target Java
3+export CLASSPATH=../../java/idris.jar:$CLASSPATH
4+javac reg002.java
5+java reg002
6+rm -f reg002.java *.class
test/reg004/run_javanew file+6
@@ -0,0 +1,6 @@
1+#!/bin/bash
2+idris $@ reg004.idr -o reg004.java --target Java
3+export CLASSPATH=../../java/idris.jar:$CLASSPATH
4+javac reg004.java
5+java reg004
6+rm -f reg004.java *.class
test/reg005/run_javanew file+6
@@ -0,0 +1,6 @@
1+#!/bin/bash
2+idris $@ reg005.idr -o reg005.java --target Java
3+export CLASSPATH=../../java/idris.jar:$CLASSPATH
4+javac reg005.java
5+java reg005
6+rm -f reg005.java *.class
test/reg006/run_javanew file+3
@@ -0,0 +1,3 @@
1+#!/bin/bash
2+idris $@ reg006.idr -o reg006.java --target Java
3+rm -f reg006.java *.class
test/runtest.pl+14−4
@@ -3,12 +3,16 @@
33my $exitstatus = 0;
44
55sub runtest {
6− my ($test, $update) = @_;
6+ my ($test, $update, $usejava) = @_;
77
88 chdir($test);
99
1010 print "Running $test...";
11− $got = `sh ./run @idrOpts`;
11+ if ($usejava == 1) {
12+ $got = `sh ./run_java @idrOpts`;
13+ } else {
14+ $got = `sh ./run @idrOpts`;
15+ }
1216 $exp = `cat expected`;
1317
1418 open(OUT,">output");
@@ -69,18 +73,24 @@ if ($#ARGV>=0) {
6973$update=0;
7074$diff=0;
7175$show=0;
76+$usejava = 0;
7277@idrOpts=();
7378
7479while ($opt=shift(@opts)) {
7580 if ($opt eq "-u") { $update = 1; }
7681 if ($opt eq "-d") { $diff = 1; }
7782 if ($opt eq "-s") { $show = 1; }
83+ if ($opt eq "--java") { $usejava = 1; }
7884}
7985
8086foreach $test (@tests) {
8187
88+ if ($usejava == 1 && !(-e "$test/run_java")) {
89+ next;
90+ }
91+
8292 if ($diff == 0 && $show == 0) {
83− runtest($test,$update);
93+ runtest($test,$update, $usejava);
8494 }
8595 else {
8696 chdir($test);
@@ -97,6 +107,6 @@ foreach $test (@tests) {
97107 }
98108 chdir("..");
99109 }
100−
110+
101111}
102112exit $exitstatus;
test/test001/run_javanew file+6
@@ -0,0 +1,6 @@
1+#!/bin/bash
2+idris $@ test001.idr -o test001.java --target Java
3+export CLASSPATH=../../java/idris.jar:$CLASSPATH
4+javac test001.java
5+java test001
6+rm -f test001.java *.class
test/test003/run_javanew file+7
@@ -0,0 +1,7 @@
1+#!/bin/bash
2+idris $@ test003a.lidr -o test003a.java --target Java
3+idris $@ test003.lidr -o test003.java --target Java
4+export CLASSPATH=../../java/idris.jar:$CLASSPATH
5+javac test003.java
6+java test003
7+rm -f test003.java *.class
test/test004/run_javanew file+6
@@ -0,0 +1,6 @@
1+#!/bin/bash
2+idris $@ test004.idr -o test004.java --target Java
3+export CLASSPATH=../../java/idris.jar:$CLASSPATH
4+javac test004.java
5+java test004
6+rm -f test004.java *.class
test/test005/run_javanew file+6
@@ -0,0 +1,6 @@
1+#!/bin/bash
2+idris $@ test005.idr -o test005.java --target Java
3+export CLASSPATH=../../java/idris.jar:$CLASSPATH
4+javac test005.java
5+java test005
6+rm -f test005.java *.class
test/test006/run_javanew file+6
@@ -0,0 +1,6 @@
1+#!/bin/bash
2+idris $@ test006.idr -o test006.java --target Java
3+export CLASSPATH=../../java/idris.jar:$CLASSPATH
4+javac test006.java
5+java test006
6+rm -f test006.java *.class
test/test007/run_javanew file+6
@@ -0,0 +1,6 @@
1+#!/bin/bash
2+idris $@ test007.idr -o test007.java --target Java
3+export CLASSPATH=../../java/idris.jar:$CLASSPATH
4+javac test007.java
5+java test007
6+rm -f test007.java *.class
test/test008/run_javanew file+6
@@ -0,0 +1,6 @@
1+#!/bin/bash
2+idris $@ test008.idr -o test008.java --target Java
3+export CLASSPATH=../../java/idris.jar:$CLASSPATH
4+javac test008.java
5+java test008
6+rm -f test008.java *.class
test/test009/run_javanew file+6
@@ -0,0 +1,6 @@
1+#!/bin/bash
2+idris $@ test009.idr -o test009.java --target Java
3+export CLASSPATH=../../java/idris.jar:$CLASSPATH
4+javac test009.java
5+java test009
6+rm -f test009.java *.class
test/test010/run_javanew file+5
@@ -0,0 +1,5 @@
1+#!/bin/bash
2+idris $@ test010.idr -o test010.java --target Java
3+idris $@ test010a.idr -o test010a.java --target Java
4+idris $@ test010b.idr -o test010b.java --target Java
5+rm -f test010.java *.class
test/test011/run_javanew file+6
@@ -0,0 +1,6 @@
1+#!/bin/bash
2+idris $@ test011.idr -o test011.java --target Java
3+export CLASSPATH=../../java/idris.jar:$CLASSPATH
4+javac test011.java
5+java test011
6+rm -f test011.java *.class
test/test012/run_javanew file+3
@@ -0,0 +1,3 @@
1+#!/bin/bash
2+idris $@ test012a.idr -o test012a.java --target Java
3+rm -f test012a.java *.class
test/test013/run_javanew file+6
@@ -0,0 +1,6 @@
1+#!/bin/bash
2+idris $@ test013.idr -o test013.java --target Java
3+export CLASSPATH=../../java/idris.jar:$CLASSPATH
4+javac test013.java
5+java test013
6+rm -f test013.java *.class
test/test014/run_javanew file+6
@@ -0,0 +1,6 @@
1+#!/bin/bash
2+idris $@ test014.idr -o test014.java --target Java
3+export CLASSPATH=../../java/idris.jar:$CLASSPATH
4+javac test014.java
5+java test014
6+rm -f test014.java *.class
test/test015/run_javanew file+6
@@ -0,0 +1,6 @@
1+#!/bin/bash
2+idris $@ test015.idr -o test015.java --target Java
3+export CLASSPATH=../../java/idris.jar:$CLASSPATH
4+javac test015.java
5+java test015
6+rm -f test015.java *.class
test/test016/run_javanew file+6
@@ -0,0 +1,6 @@
1+#!/bin/bash
2+idris $@ test016.idr -o test016.java --target Java
3+export CLASSPATH=../../java/idris.jar:$CLASSPATH
4+javac test016.java
5+java test016
6+rm -f test016.java *.class
test/test017/run_javanew file+4
@@ -0,0 +1,4 @@
1+#!/bin/bash
2+idris $@ test017a.idr -o test017a.java --target Java
3+idris $@ test017b.idr -o test017b.java --target Java
4+rm -f *.class
test/test018/run_javanew file+7
@@ -0,0 +1,7 @@
1+#!/bin/bash
2+idris $@ test018.idr -o test018.java --target Java
3+idris $@ test018a.idr -o test018a.java --target Java
4+export CLASSPATH=../../java/idris.jar:$CLASSPATH
5+javac test018.java
6+java test018
7+rm -f test018.java test018a.java *.class
test/test019/run_javanew file+6
@@ -0,0 +1,6 @@
1+#!/bin/bash
2+idris $@ test019.lidr -o test019.java --target Java
3+export CLASSPATH=../../java/idris.jar:$CLASSPATH
4+javac test019.java
5+java test019
6+rm -f test019.java *.class
test/test020/run_javanew file+7
@@ -0,0 +1,7 @@
1+#!/bin/bash
2+idris $@ test020.idr -o test020.java --target Java
3+idris $@ test020a.idr -o test020a.java --target Java
4+export CLASSPATH=../../java/idris.jar:$CLASSPATH
5+javac test020.java
6+java test020
7+rm -f test020.java *.class
test/test021/run_javanew file+9
@@ -0,0 +1,9 @@
1+#!/bin/bash
2+idris -p effects $@ test021.idr -o test021.java --target Java
3+idris -p effects $@ test021a.idr -o test021a.java --target Java
4+export CLASSPATH=../../java/idris.jar:$CLASSPATH
5+javac test021.java
6+java test021
7+javac test021a.java
8+java test021a
9+rm -f test021.java test021a.java *.class