git.iko.soy/Idris-dev
on master help sign in
Merge pull request #384 from JanBessai/JavaRepairs
6a300afEdwin Brady
.travis.yml+4−2
compare with master
unifiedsplit
@@ -10,6 +10,8 @@ before_script:
10 - tar -xf edwinb/Idris-dev/dist/idris*.tar.gz
10 - tar -xf edwinb/Idris-dev/dist/idris*.tar.gz
11 - cd idris*
11 - cd idris*
12script:
12script:
13− - cabal configure
13+ - cabal configure -f Java
14− - cabal install
14+ - cabal install -f Java
15 - make test
15 - make test
16+ - make test_java
17+
Makefile+3
@@ -16,6 +16,9 @@ build: dist/setup-config
16test:
16test:
17 make -C test IDRIS=../dist/build/idris
17 make -C test IDRIS=../dist/build/idris
18
18
19+test_java:
20+ make -C test IDRIS=../dist/build/idris test_java
21+
19relib:
22relib:
20 make -C lib IDRIS=../dist/build/idris/idris RTS=../dist/build/rts/libidris_rts clean
23 make -C lib IDRIS=../dist/build/idris/idris RTS=../dist/build/rts/libidris_rts clean
21 make -C effects IDRIS=../dist/build/idris/idris RTS=../dist/build/rts/libidris_rts DIST=../dist/build clean
24 make -C effects IDRIS=../dist/build/idris/idris RTS=../dist/build/rts/libidris_rts DIST=../dist/build clean
idris.cabal+2−1
@@ -265,7 +265,8 @@ Executable idris
265
265
266 IRTS.Lang, IRTS.LParser, IRTS.Bytecode, IRTS.Simplified,
266 IRTS.Lang, IRTS.LParser, IRTS.Bytecode, IRTS.Simplified,
267 IRTS.CodegenC, IRTS.Defunctionalise, IRTS.Inliner,
267 IRTS.CodegenC, IRTS.Defunctionalise, IRTS.Inliner,
268− IRTS.Compiler, IRTS.CodegenJava, IRTS.BCImp,
268+ IRTS.Compiler, IRTS.CodegenJava, IRTS.Java.ASTBuilding,
269+ IRTS.Java.JTypes, IRTS.Java.Mangling, IRTS.BCImp,
269 IRTS.CodegenJavaScript, IRTS.CodegenLLVM,
270 IRTS.CodegenJavaScript, IRTS.CodegenLLVM,
270 IRTS.CodegenCommon, IRTS.DumpBC
271 IRTS.CodegenCommon, IRTS.DumpBC
271
272
java/src/main/java/org/idris/rts/Closure.java+17−8
@@ -3,15 +3,24 @@ package org.idris.rts;
3import java.util.concurrent.Callable;
3import java.util.concurrent.Callable;
4
4
5public abstract class Closure implements Callable<Object>, Runnable {
5public abstract class Closure implements Callable<Object>, Runnable {
6− protected final Object [] context;
6+ @Override
7−
7+ public abstract Object call();
8− protected Closure(final Object ... context) {
8+
9− this.context = context;
9+ public static Object unwrapTailCall(Object o) {
10+ while (o instanceof Closure) {
11+ o = ((Closure)o).call();
12+ }
13+ return o;
10 }
14 }
11−
15+
16+ @Override
12 public void run() {
17 public void run() {
13− call();
18+ unwrapTailCall(call());
19+ }
20+
21+ public Thread fork() {
22+ Thread childProcess = new Thread(this);
23+ childProcess.start();
24+ return childProcess;
14 }
25 }
15−
16− public abstract Object call();
17}
26}
java/src/main/java/org/idris/rts/ForeignPrimitives.java+3−19
@@ -241,7 +241,7 @@ public class ForeignPrimitives {
241 return result;
241 return result;
242 }
242 }
243
243
244− public final static Object idris_assignStack(final Object[] context, final int start, final Object... vars) {
244+ public final static Object[] idris_assignStack(final Object[] context, final int start, final Object... vars) {
245 int i = start;
245 int i = start;
246 for (Object var : vars) {
246 for (Object var : vars) {
247 context[i] = var;
247 context[i] = var;
@@ -249,23 +249,7 @@ public class ForeignPrimitives {
249 return context;
249 return context;
250 }
250 }
251
251
252− public final static Object invokeOn(final Object obj, final String methodName, Object... args) throws NoSuchMethodException, IllegalAccessException, InvocationTargetException {
252+ public final static Object idris_throwException(RuntimeException ex) {
253− Class cls = (obj instanceof Class ? (Class)obj : obj.getClass());
253+ throw ex;
254− Class argClasses[] = new Class[args.length];
255− int i = 0;
256− for (Object arg : args) {
257− argClasses[i] = arg.getClass();
258− }
259− return cls.getMethod(methodName, argClasses).invoke(obj, args);
260− }
261−
262− public final static Object newObject(final Object cls, Object... args) throws NoSuchMethodException, IllegalAccessException, InvocationTargetException, InstantiationException {
263− Class clazz = (cls instanceof Class ? (Class)cls : cls.getClass());
264− Class argClasses[] = new Class[args.length];
265− int i = 0;
266− for (Object arg : args) {
267− argClasses[i] = arg.getClass();
268− }
269− return clazz.getConstructor(argClasses).newInstance(args);
270 }
254 }
271}
255}
java/src/main/java/org/idris/rts/PrimFn.javanew file+1464
@@ -0,0 +1,1464 @@
1+/*
2+ */
3+package org.idris.rts;
4+
5+import java.io.IOException;
6+import java.io.InputStream;
7+import java.io.OutputStream;
8+import java.math.BigInteger;
9+
10+public class PrimFn {
11+ public static byte LPlus(byte x, byte y) {
12+ return (byte)(x + y);
13+ }
14+ public static char LPlus(char x, char y) {
15+ return (char)(x + y);
16+ }
17+ public static short LPlus(short x, short y) {
18+ return (short)(x + y);
19+ }
20+ public static int LPlus(int x, int y) {
21+ return x + y;
22+ }
23+ public static long LPlus(long x, long y) {
24+ return x + y;
25+ }
26+ public static double LPlus(double x, double y) {
27+ return x + y;
28+ }
29+ public static BigInteger LPlus(BigInteger x, BigInteger y) {
30+ return x.add(y);
31+ }
32+ public static byte[] LPlus(byte[] x, byte[] y) {
33+ byte[] res = x.clone();
34+ for (int i = 0; i < res.length; ++i) {
35+ res[i] += y[i];
36+ }
37+ return res;
38+ }
39+ public static short[] LPlus(short[] x, short[] y) {
40+ short[] res = x.clone();
41+ for (int i = 0; i < res.length; ++i) {
42+ res[i] += y[i];
43+ }
44+ return res;
45+ }
46+ public static int[] LPlus(int[] x, int[] y) {
47+ int[] res = x.clone();
48+ for (int i = 0; i < res.length; ++i) {
49+ res[i] += y[i];
50+ }
51+ return res;
52+ }
53+ public static long[] LPlus(long[] x, long[] y) {
54+ long[] res = x.clone();
55+ for (int i = 0; i < res.length; ++i) {
56+ res[i] += y[i];
57+ }
58+ return res;
59+ }
60+
61+ public static byte LMinus(byte x, byte y) {
62+ return (byte)(x - y);
63+ }
64+ public static char LMinus(char x, char y) {
65+ return (char)(x - y);
66+ }
67+ public static short LMinus(short x, short y) {
68+ return (short)(x - y);
69+ }
70+ public static int LMinus(int x, int y) {
71+ return x - y;
72+ }
73+ public static long LMinus(long x, long y) {
74+ return x - y;
75+ }
76+ public static double LMinus(double x, double y) {
77+ return x - y;
78+ }
79+ public static BigInteger LMinus(BigInteger x, BigInteger y) {
80+ return x.subtract(y);
81+ }
82+ public static byte[] LMinus(byte[] x, byte[] y) {
83+ byte[] res = x.clone();
84+ for (int i = 0; i < res.length; ++i) {
85+ res[i] -= y[i];
86+ }
87+ return res;
88+ }
89+ public static short[] LMinus(short[] x, short[] y) {
90+ short[] res = x.clone();
91+ for (int i = 0; i < res.length; ++i) {
92+ res[i] -= y[i];
93+ }
94+ return res;
95+ }
96+ public static int[] LMinus(int[] x, int[] y) {
97+ int[] res = x.clone();
98+ for (int i = 0; i < res.length; ++i) {
99+ res[i] -= y[i];
100+ }
101+ return res;
102+ }
103+ public static long[] LMinus(long[] x, long[] y) {
104+ long[] res = x.clone();
105+ for (int i = 0; i < res.length; ++i) {
106+ res[i] -= y[i];
107+ }
108+ return res;
109+ }
110+
111+ public static byte LTimes(byte x, byte y) {
112+ return (byte)(x * y);
113+ }
114+ public static char LTimes(char x, char y) {
115+ return (char)(x * y);
116+ }
117+ public static short LTimes(short x, short y) {
118+ return (short)(x * y);
119+ }
120+ public static int LTimes(int x, int y) {
121+ return x * y;
122+ }
123+ public static long LTimes(long x, long y) {
124+ return x * y;
125+ }
126+ public static double LTimes(double x, double y) {
127+ return x * y;
128+ }
129+ public static BigInteger LTimes(BigInteger x, BigInteger y) {
130+ return x.multiply(y);
131+ }
132+ public static byte[] LTimes(byte[] x, byte[] y) {
133+ byte[] res = x.clone();
134+ for (int i = 0; i < res.length; ++i) {
135+ res[i] *= y[i];
136+ }
137+ return res;
138+ }
139+ public static short[] LTimes(short[] x, short[] y) {
140+ short[] res = x.clone();
141+ for (int i = 0; i < res.length; ++i) {
142+ res[i] *= y[i];
143+ }
144+ return res;
145+ }
146+ public static int[] LTimes(int[] x, int[] y) {
147+ int[] res = x.clone();
148+ for (int i = 0; i < res.length; ++i) {
149+ res[i] *= y[i];
150+ }
151+ return res;
152+ }
153+ public static long[] LTimes(long[] x, long[] y) {
154+ long[] res = x.clone();
155+ for (int i = 0; i < res.length; ++i) {
156+ res[i] *= y[i];
157+ }
158+ return res;
159+ }
160+
161+ public static byte LUDiv(byte x, byte y) {
162+ return (byte)(((short)x) / ((short)y));
163+ }
164+ public static char LUDiv(char x, char y) {
165+ return (char)(((long)x) / ((long)y));
166+ }
167+ public static short LUDiv(short x, short y) {
168+ return (short)(((int)x) / ((int)y));
169+ }
170+ public static int LUDiv(int x, int y) {
171+ return (int)(((long)x) / ((long)y));
172+ }
173+ public static long LUDiv(long x, long y) {
174+ return BigInteger.valueOf(x).divide(BigInteger.valueOf(y)).longValue();
175+ }
176+ public static byte[] LUDiv(byte[] x, byte[] y) {
177+ byte[] res = x.clone();
178+ for (int i = 0; i < res.length; ++i) {
179+ res[i] = (byte)(((short)res[i]) / ((short)y[i]));
180+ }
181+ return res;
182+ }
183+ public static short[] LUDiv(short[] x, short[] y) {
184+ short[] res = x.clone();
185+ for (int i = 0; i < res.length; ++i) {
186+ res[i] = (short)(((int)res[i]) / ((int)y[i]));
187+ }
188+ return res;
189+ }
190+ public static int[] LUDiv(int[] x, int[] y) {
191+ int[] res = x.clone();
192+ for (int i = 0; i < res.length; ++i) {
193+ res[i] = (int)(((long)res[i]) / ((long)y[i]));
194+ }
195+ return res;
196+ }
197+ public static long[] LUDiv(long[] x, long[] y) {
198+ long[] res = x.clone();
199+ for (int i = 0; i < res.length; ++i) {
200+ res[i] = BigInteger.valueOf(res[i]).divide(BigInteger.valueOf(y[i])).longValue();
201+ }
202+ return res;
203+ }
204+
205+ public static byte LSDiv(byte x, byte y) {
206+ return (byte)(x / y);
207+ }
208+ public static char LSDiv(char x, char y) {
209+ return (char)(x / y);
210+ }
211+ public static short LSDiv(short x, short y) {
212+ return (short)(x / y);
213+ }
214+ public static int LSDiv(int x, int y) {
215+ return x / y;
216+ }
217+ public static long LSDiv(long x, long y) {
218+ return x / y;
219+ }
220+ public static double LSDiv(double x, double y) {
221+ return x / y;
222+ }
223+ public static BigInteger LSDiv(BigInteger x, BigInteger y) {
224+ return x.divide(y);
225+ }
226+ public static byte[] LSDiv(byte[] x, byte[] y) {
227+ byte[] res = x.clone();
228+ for (int i = 0; i < res.length; ++i) {
229+ res[i] /= y[i];
230+ }
231+ return res;
232+ }
233+ public static short[] LSDiv(short[] x, short[] y) {
234+ short[] res = x.clone();
235+ for (int i = 0; i < res.length; ++i) {
236+ res[i] /= y[i];
237+ }
238+ return res;
239+ }
240+ public static int[] LSDiv(int[] x, int[] y) {
241+ int[] res = x.clone();
242+ for (int i = 0; i < res.length; ++i) {
243+ res[i] /= y[i];
244+ }
245+ return res;
246+ }
247+ public static long[] LSDiv(long[] x, long[] y) {
248+ long[] res = x.clone();
249+ for (int i = 0; i < res.length; ++i) {
250+ res[i] /= y[i];
251+ }
252+ return res;
253+ }
254+
255+ public static byte LURem(byte x, byte y) {
256+ return (byte)(((short)x) % ((short)y));
257+ }
258+ public static char LURem(char x, char y) {
259+ return (char)(((long)x) % ((long)y));
260+ }
261+ public static short LURem(short x, short y) {
262+ return (short)(((int)x) % ((int)y));
263+ }
264+ public static int LURem(int x, int y) {
265+ return (int)(((long)x) % ((long)y));
266+ }
267+ public static long LURem(long x, long y) {
268+ return BigInteger.valueOf(x).divide(BigInteger.valueOf(y)).longValue();
269+ }
270+ public static byte[] LURem(byte[] x, byte[] y) {
271+ byte[] res = x.clone();
272+ for (int i = 0; i < res.length; ++i) {
273+ res[i] = (byte)(((short)res[i]) % ((short)y[i]));
274+ }
275+ return res;
276+ }
277+ public static short[] LURem(short[] x, short[] y) {
278+ short[] res = x.clone();
279+ for (int i = 0; i < res.length; ++i) {
280+ res[i] = (short)(((int)res[i]) % ((int)y[i]));
281+ }
282+ return res;
283+ }
284+ public static int[] LURem(int[] x, int[] y) {
285+ int[] res = x.clone();
286+ for (int i = 0; i < res.length; ++i) {
287+ res[i] = (int)(((long)res[i]) % ((long)y[i]));
288+ }
289+ return res;
290+ }
291+ public static long[] LURem(long[] x, long[] y) {
292+ long[] res = x.clone();
293+ for (int i = 0; i < res.length; ++i) {
294+ res[i] = BigInteger.valueOf(res[i]).divide(BigInteger.valueOf(y[i])).longValue();
295+ }
296+ return res;
297+ }
298+
299+ public static byte LSRem(byte x, byte y) {
300+ return (byte)(x % y);
301+ }
302+ public static char LSRem(char x, char y) {
303+ return (char)(x % y);
304+ }
305+ public static short LSRem(short x, short y) {
306+ return (short)(x % y);
307+ }
308+ public static int LSRem(int x, int y) {
309+ return x % y;
310+ }
311+ public static long LSRem(long x, long y) {
312+ return x % y;
313+ }
314+ public static double LSRem(double x, double y) {
315+ return x % y;
316+ }
317+ public static BigInteger LSRem(BigInteger x, BigInteger y) {
318+ return x.remainder(y);
319+ }
320+ public static byte[] LSRem(byte[] x, byte[] y) {
321+ byte[] res = x.clone();
322+ for (int i = 0; i < res.length; ++i) {
323+ res[i] %= y[i];
324+ }
325+ return res;
326+ }
327+ public static short[] LSRem(short[] x, short[] y) {
328+ short[] res = x.clone();
329+ for (int i = 0; i < res.length; ++i) {
330+ res[i] %= y[i];
331+ }
332+ return res;
333+ }
334+ public static int[] LSRem(int[] x, int[] y) {
335+ int[] res = x.clone();
336+ for (int i = 0; i < res.length; ++i) {
337+ res[i] %= y[i];
338+ }
339+ return res;
340+ }
341+ public static long[] LSRem(long[] x, long[] y) {
342+ long[] res = x.clone();
343+ for (int i = 0; i < res.length; ++i) {
344+ res[i] %= y[i];
345+ }
346+ return res;
347+ }
348+
349+
350+ public static byte LAnd(byte x, byte y) {
351+ return (byte)(x & y);
352+ }
353+ public static char LAnd(char x, char y) {
354+ return (char)(x & y);
355+ }
356+ public static short LAnd(short x, short y) {
357+ return (short)(x & y);
358+ }
359+ public static int LAnd(int x, int y) {
360+ return x & y;
361+ }
362+ public static long LAnd(long x, long y) {
363+ return x & y;
364+ }
365+ public static BigInteger LAnd(BigInteger x, BigInteger y) {
366+ return x.and(y);
367+ }
368+ public static byte[] LAnd(byte[] x, byte[] y) {
369+ byte[] res = x.clone();
370+ for (int i = 0; i < res.length; ++i) {
371+ res[i] &= y[i];
372+ }
373+ return res;
374+ }
375+ public static short[] LAnd(short[] x, short[] y) {
376+ short[] res = x.clone();
377+ for (int i = 0; i < res.length; ++i) {
378+ res[i] &= y[i];
379+ }
380+ return res;
381+ }
382+ public static int[] LAnd(int[] x, int[] y) {
383+ int[] res = x.clone();
384+ for (int i = 0; i < res.length; ++i) {
385+ res[i] &= y[i];
386+ }
387+ return res;
388+ }
389+ public static long[] LAnd(long[] x, long[] y) {
390+ long[] res = x.clone();
391+ for (int i = 0; i < res.length; ++i) {
392+ res[i] &= y[i];
393+ }
394+ return res;
395+ }
396+
397+ public static byte LOr(byte x, byte y) {
398+ return (byte)(x | y);
399+ }
400+ public static char LOr(char x, char y) {
401+ return (char)(x | y);
402+ }
403+ public static short LOr(short x, short y) {
404+ return (short)(x | y);
405+ }
406+ public static int LOr(int x, int y) {
407+ return x | y;
408+ }
409+ public static long LOr(long x, long y) {
410+ return x | y;
411+ }
412+ public static BigInteger LOr(BigInteger x, BigInteger y) {
413+ return x.or(y);
414+ }
415+ public static byte[] LOr(byte[] x, byte[] y) {
416+ byte[] res = x.clone();
417+ for (int i = 0; i < res.length; ++i) {
418+ res[i] |= y[i];
419+ }
420+ return res;
421+ }
422+ public static short[] LOr(short[] x, short[] y) {
423+ short[] res = x.clone();
424+ for (int i = 0; i < res.length; ++i) {
425+ res[i] |= y[i];
426+ }
427+ return res;
428+ }
429+ public static int[] LOr(int[] x, int[] y) {
430+ int[] res = x.clone();
431+ for (int i = 0; i < res.length; ++i) {
432+ res[i] |= y[i];
433+ }
434+ return res;
435+ }
436+ public static long[] LOr(long[] x, long[] y) {
437+ long[] res = x.clone();
438+ for (int i = 0; i < res.length; ++i) {
439+ res[i] |= y[i];
440+ }
441+ return res;
442+ }
443+
444+ public static byte LXOr(byte x, byte y) {
445+ return (byte)(x ^ y);
446+ }
447+ public static char LXOr(char x, char y) {
448+ return (char)(x ^ y);
449+ }
450+ public static short LXOr(short x, short y) {
451+ return (short)(x ^ y);
452+ }
453+ public static int LXOr(int x, int y) {
454+ return x ^ y;
455+ }
456+ public static long LXOr(long x, long y) {
457+ return x ^ y;
458+ }
459+ public static BigInteger LXOr(BigInteger x, BigInteger y) {
460+ return x.xor(y);
461+ }
462+ public static byte[] LXOr(byte[] x, byte[] y) {
463+ byte[] res = x.clone();
464+ for (int i = 0; i < res.length; ++i) {
465+ res[i] ^= y[i];
466+ }
467+ return res;
468+ }
469+ public static short[] LXOr(short[] x, short[] y) {
470+ short[] res = x.clone();
471+ for (int i = 0; i < res.length; ++i) {
472+ res[i] ^= y[i];
473+ }
474+ return res;
475+ }
476+ public static int[] LXOr(int[] x, int[] y) {
477+ int[] res = x.clone();
478+ for (int i = 0; i < res.length; ++i) {
479+ res[i] ^= y[i];
480+ }
481+ return res;
482+ }
483+ public static long[] LXOr(long[] x, long[] y) {
484+ long[] res = x.clone();
485+ for (int i = 0; i < res.length; ++i) {
486+ res[i] ^= y[i];
487+ }
488+ return res;
489+ }
490+
491+ public static byte LCompl(byte x) {
492+ return (byte)~x;
493+ }
494+ public static char LCompl(char x) {
495+ return (char)~x;
496+ }
497+ public static short LCompl(short x) {
498+ return (short)(~x);
499+ }
500+ public static int LCompl(int x) {
501+ return ~x;
502+ }
503+ public static long LCompl(long x) {
504+ return ~x;
505+ }
506+ public static BigInteger LCompl(BigInteger x) {
507+ return x.not();
508+ }
509+ public static byte[] LCompl(byte[] x) {
510+ byte[] res = new byte[x.length];
511+ for (int i = 0; i < res.length; ++i) {
512+ res[i] = (byte)~(x[i]);
513+ }
514+ return res;
515+ }
516+ public static short[] LCompl(short[] x) {
517+ short[] res = new short[x.length];
518+ for (int i = 0; i < res.length; ++i) {
519+ res[i] = (short)~(x[i]);
520+ }
521+ return res;
522+ }
523+ public static int[] LCompl(int[] x) {
524+ int[] res = new int[x.length];
525+ for (int i = 0; i < res.length; ++i) {
526+ res[i] = (int)~(x[i]);
527+ }
528+ return res;
529+ }
530+ public static long[] LCompl(long[] x) {
531+ long[] res = new long[x.length];
532+ for (int i = 0; i < res.length; ++i) {
533+ res[i] = (long)~(x[i]);
534+ }
535+ return res;
536+ }
537+
538+ public static byte LSHL(byte x, byte y) {
539+ return (byte)(x << y);
540+ }
541+ public static char LSHL(char x, char y) {
542+ return (char)(x << y);
543+ }
544+ public static short LSHL(short x, short y) {
545+ return (short)(x << y);
546+ }
547+ public static int LSHL(int x, int y) {
548+ return x << y;
549+ }
550+ public static long LSHL(long x, long y) {
551+ return x << y;
552+ }
553+ public static BigInteger LSHL(BigInteger x, BigInteger y) {
554+ return x.shiftLeft(y.intValue());
555+ }
556+ public static byte[] LSHL(byte[] x, byte[] y) {
557+ byte[] res = x.clone();
558+ for (int i = 0; i < res.length; ++i) {
559+ res[i] <<= y[i];
560+ }
561+ return res;
562+ }
563+ public static short[] LSHL(short[] x, short[] y) {
564+ short[] res = x.clone();
565+ for (int i = 0; i < res.length; ++i) {
566+ res[i] <<= y[i];
567+ }
568+ return res;
569+ }
570+ public static int[] LSHL(int[] x, int[] y) {
571+ int[] res = x.clone();
572+ for (int i = 0; i < res.length; ++i) {
573+ res[i] <<= y[i];
574+ }
575+ return res;
576+ }
577+ public static long[] LSHL(long[] x, long[] y) {
578+ long[] res = x.clone();
579+ for (int i = 0; i < res.length; ++i) {
580+ res[i] <<= y[i];
581+ }
582+ return res;
583+ }
584+
585+ public static byte LLSHR(byte x, byte y) {
586+ return (byte)(x >>> y);
587+ }
588+ public static char LLSHR(char x, char y) {
589+ return (char)(x >>> y);
590+ }
591+ public static short LLSHR(short x, short y) {
592+ return (short)(x >>> y);
593+ }
594+ public static int LLSHR(int x, int y) {
595+ return x >>> y;
596+ }
597+ public static long LLSHR(long x, long y) {
598+ return x >>> y;
599+ }
600+ public static byte[] LLSHR(byte[] x, byte[] y) {
601+ byte[] res = x.clone();
602+ for (int i = 0; i < res.length; ++i) {
603+ res[i] >>>= y[i];
604+ }
605+ return res;
606+ }
607+ public static short[] LLSHR(short[] x, short[] y) {
608+ short[] res = x.clone();
609+ for (int i = 0; i < res.length; ++i) {
610+ res[i] >>>= y[i];
611+ }
612+ return res;
613+ }
614+ public static int[] LLSHR(int[] x, int[] y) {
615+ int[] res = x.clone();
616+ for (int i = 0; i < res.length; ++i) {
617+ res[i] >>>= y[i];
618+ }
619+ return res;
620+ }
621+ public static long[] LLSHR(long[] x, long[] y) {
622+ long[] res = x.clone();
623+ for (int i = 0; i < res.length; ++i) {
624+ res[i] >>>= y[i];
625+ }
626+ return res;
627+ }
628+
629+ public static byte LASHR(byte x, byte y) {
630+ return (byte)(x >> y);
631+ }
632+ public static char LASHR(char x, char y) {
633+ return (char)(x >> y);
634+ }
635+ public static short LASHR(short x, short y) {
636+ return (short)(x >> y);
637+ }
638+ public static int LASHR(int x, int y) {
639+ return x >> y;
640+ }
641+ public static long LASHR(long x, long y) {
642+ return x >> y;
643+ }
644+ public static BigInteger LASHR(BigInteger x, BigInteger y) {
645+ return x.shiftRight(y.intValue());
646+ }
647+ public static byte[] LASHR(byte[] x, byte[] y) {
648+ byte[] res = x.clone();
649+ for (int i = 0; i < res.length; ++i) {
650+ res[i] >>= y[i];
651+ }
652+ return res;
653+ }
654+ public static short[] LASHR(short[] x, short[] y) {
655+ short[] res = x.clone();
656+ for (int i = 0; i < res.length; ++i) {
657+ res[i] >>= y[i];
658+ }
659+ return res;
660+ }
661+ public static int[] LASHR(int[] x, int[] y) {
662+ int[] res = x.clone();
663+ for (int i = 0; i < res.length; ++i) {
664+ res[i] >>= y[i];
665+ }
666+ return res;
667+ }
668+ public static long[] LASHR(long[] x, long[] y) {
669+ long[] res = x.clone();
670+ for (int i = 0; i < res.length; ++i) {
671+ res[i] >>= y[i];
672+ }
673+ return res;
674+ }
675+
676+ public static int LEq(byte x, byte y) {
677+ return (x == y ? 1 : 0);
678+ }
679+ public static int LEq(char x, char y) {
680+ return (x == y ? 1 : 0);
681+ }
682+ public static int LEq(short x, short y) {
683+ return (x == y ? 1 : 0);
684+ }
685+ public static int LEq(int x, int y) {
686+ return (x == y ? 1 : 0);
687+ }
688+ public static int LEq(long x, long y) {
689+ return (x == y ? 1 : 0);
690+ }
691+ public static int LEq(double x, double y) {
692+ return (x == y ? 1 : 0);
693+ }
694+ public static int LEq(BigInteger x, BigInteger y) {
695+ return (x.equals(y) ? 1 : 0);
696+ }
697+ public static byte[] LEq(byte[] x, byte[] y) {
698+ byte[] res = new byte[x.length];
699+ for (int i = 0; i < x.length; ++i) {
700+ res[i] = (byte)(x[i] == y[i] ? -1 : 0);
701+ }
702+ return res;
703+ }
704+ public static short[] LEq(short[] x, short[] y) {
705+ short[] res = new short[x.length];
706+ for (int i = 0; i < x.length; ++i) {
707+ res[i] = (short)(x[i] == y[i] ? -1 : 0);
708+ }
709+ return res;
710+ }
711+ public static int[] LEq(int[] x, int[] y) {
712+ int[] res = new int[x.length];
713+ for (int i = 0; i < x.length; ++i) {
714+ res[i] = (x[i] == y[i] ? -1 : 0);
715+ }
716+ return res;
717+ }
718+ public static long[] LEq(long[] x, long[] y) {
719+ long[] res = new long[x.length];
720+ for (int i = 0; i < x.length; ++i) {
721+ res[i] = (x[i] == y[i] ? -1 : 0);
722+ }
723+ return res;
724+ }
725+
726+ public static int LLt(byte x, byte y) {
727+ return (x < y ? 1 : 0);
728+ }
729+ public static int LLt(char x, char y) {
730+ return (x < y ? 1 : 0);
731+ }
732+ public static int LLt(short x, short y) {
733+ return (x < y ? 1 : 0);
734+ }
735+ public static int LLt(int x, int y) {
736+ return (x < y ? 1 : 0);
737+ }
738+ public static int LLt(long x, long y) {
739+ return (x < y ? 1 : 0);
740+ }
741+ public static double LLt(double x, double y) {
742+ return (x < y ? 1 : 0);
743+ }
744+ public static int LLt(BigInteger x, BigInteger y) {
745+ return (x.compareTo(y) < 0 ? 1 : 0);
746+ }
747+ public static byte[] LLt(byte[] x, byte[] y) {
748+ byte[] res = new byte[x.length];
749+ for (int i = 0; i < x.length; ++i) {
750+ res[i] = (byte)(x[i] < y[i] ? -1 : 0);
751+ }
752+ return res;
753+ }
754+ public static short[] LLt(short[] x, short[] y) {
755+ short[] res = new short[x.length];
756+ for (int i = 0; i < x.length; ++i) {
757+ res[i] = (short)(x[i] < y[i] ? -1 : 0);
758+ }
759+ return res;
760+ }
761+ public static int[] LLt(int[] x, int[] y) {
762+ int[] res = new int[x.length];
763+ for (int i = 0; i < x.length; ++i) {
764+ res[i] = (x[i] < y[i] ? -1 : 0);
765+ }
766+ return res;
767+ }
768+ public static long[] LLt(long[] x, long[] y) {
769+ long[] res = new long[x.length];
770+ for (int i = 0; i < x.length; ++i) {
771+ res[i] = (x[i] < y[i] ? -1 : 0);
772+ }
773+ return res;
774+ }
775+
776+ public static int LLe(byte x, byte y) {
777+ return (x <= y ? 1 : 0);
778+ }
779+ public static int LLe(char x, char y) {
780+ return (x <= y ? 1 : 0);
781+ }
782+ public static int LLe(short x, short y) {
783+ return (x <= y ? 1 : 0);
784+ }
785+ public static int LLe(int x, int y) {
786+ return (x <= y ? 1 : 0);
787+ }
788+ public static int LLe(long x, long y) {
789+ return (x <= y ? 1 : 0);
790+ }
791+ public static double LLe(double x, double y) {
792+ return (x <= y ? 1 : 0);
793+ }
794+ public static int LLe(BigInteger x, BigInteger y) {
795+ return (x.compareTo(y) <= 0 ? 1 : 0);
796+ }
797+ public static byte[] LLe(byte[] x, byte[] y) {
798+ byte[] res = new byte[x.length];
799+ for (int i = 0; i < x.length; ++i) {
800+ res[i] = (byte)(x[i] <= y[i] ? -1 : 0);
801+ }
802+ return res;
803+ }
804+ public static short[] LLe(short[] x, short[] y) {
805+ short[] res = new short[x.length];
806+ for (int i = 0; i < x.length; ++i) {
807+ res[i] = (short)(x[i] <= y[i] ? -1 : 0);
808+ }
809+ return res;
810+ }
811+ public static int[] LLe(int[] x, int[] y) {
812+ int[] res = new int[x.length];
813+ for (int i = 0; i < x.length; ++i) {
814+ res[i] = (x[i] <= y[i] ? -1 : 0);
815+ }
816+ return res;
817+ }
818+ public static long[] LLe(long[] x, long[] y) {
819+ long[] res = new long[x.length];
820+ for (int i = 0; i < x.length; ++i) {
821+ res[i] = (x[i] <= y[i] ? -1 : 0);
822+ }
823+ return res;
824+ }
825+
826+ public static int LGt(byte x, byte y) {
827+ return (x > y ? 1 : 0);
828+ }
829+ public static int LGt(char x, char y) {
830+ return (x > y ? 1 : 0);
831+ }
832+ public static int LGt(short x, short y) {
833+ return (x > y ? 1 : 0);
834+ }
835+ public static int LGt(int x, int y) {
836+ return (x > y ? 1 : 0);
837+ }
838+ public static int LGt(long x, long y) {
839+ return (x > y ? 1 : 0);
840+ }
841+ public static double LGt(double x, double y) {
842+ return (x > y ? 1 : 0);
843+ }
844+ public static int LGt(BigInteger x, BigInteger y) {
845+ return (x.compareTo(y) > 0 ? 1 : 0);
846+ }
847+ public static byte[] LGt(byte[] x, byte[] y) {
848+ byte[] res = new byte[x.length];
849+ for (int i = 0; i < x.length; ++i) {
850+ res[i] = (byte)(x[i] > y[i] ? -1 : 0);
851+ }
852+ return res;
853+ }
854+ public static short[] LGt(short[] x, short[] y) {
855+ short[] res = new short[x.length];
856+ for (int i = 0; i < x.length; ++i) {
857+ res[i] = (short)(x[i] > y[i] ? -1 : 0);
858+ }
859+ return res;
860+ }
861+ public static int[] LGt(int[] x, int[] y) {
862+ int[] res = new int[x.length];
863+ for (int i = 0; i < x.length; ++i) {
864+ res[i] = (x[i] > y[i] ? -1 : 0);
865+ }
866+ return res;
867+ }
868+ public static long[] LGt(long[] x, long[] y) {
869+ long[] res = new long[x.length];
870+ for (int i = 0; i < x.length; ++i) {
871+ res[i] = (x[i] > y[i] ? -1 : 0);
872+ }
873+ return res;
874+ }
875+
876+ public static int LGe(byte x, byte y) {
877+ return (x >= y ? 1 : 0);
878+ }
879+ public static int LGe(char x, char y) {
880+ return (x >= y ? 1 : 0);
881+ }
882+ public static int LGe(short x, short y) {
883+ return (x >= y ? 1 : 0);
884+ }
885+ public static int LGe(int x, int y) {
886+ return (x >= y ? 1 : 0);
887+ }
888+ public static int LGe(long x, long y) {
889+ return (x >= y ? 1 : 0);
890+ }
891+ public static double LGe(double x, double y) {
892+ return (x >= y ? 1 : 0);
893+ }
894+ public static int LGe(BigInteger x, BigInteger y) {
895+ return (x.compareTo(y) >= 0 ? 1 : 0);
896+ }
897+ public static byte[] LGe(byte[] x, byte[] y) {
898+ byte[] res = new byte[x.length];
899+ for (int i = 0; i < x.length; ++i) {
900+ res[i] = (byte)(x[i] >= y[i] ? -1 : 0);
901+ }
902+ return res;
903+ }
904+ public static short[] LGe(short[] x, short[] y) {
905+ short[] res = new short[x.length];
906+ for (int i = 0; i < x.length; ++i) {
907+ res[i] = (short)(x[i] >= y[i] ? -1 : 0);
908+ }
909+ return res;
910+ }
911+ public static int[] LGe(int[] x, int[] y) {
912+ int[] res = new int[x.length];
913+ for (int i = 0; i < x.length; ++i) {
914+ res[i] = (x[i] >= y[i] ? -1 : 0);
915+ }
916+ return res;
917+ }
918+ public static long[] LGe(long[] x, long[] y) {
919+ long[] res = new long[x.length];
920+ for (int i = 0; i < x.length; ++i) {
921+ res[i] = (x[i] >= y[i] ? -1 : 0);
922+ }
923+ return res;
924+ }
925+
926+
927+ public static short LSExtIT16(byte x) {
928+ return (short)x;
929+ }
930+ public static int LSExtIT32(byte x) {
931+ return (int)x;
932+ }
933+ public static long LSExtIT64(byte x) {
934+ return (long)x;
935+ }
936+ public static BigInteger LSExtITBig(byte x) {
937+ return BigInteger.valueOf(x);
938+ }
939+ public static short[] LSExtITVec16(byte[] x) {
940+ short[] res = new short[x.length];
941+ for (int i = 0; i < res.length; ++i) {
942+ res[i] = (short)x[i];
943+ }
944+ return res;
945+ }
946+ public static int[] LSExtITVec32(byte[] x) {
947+ int[] res = new int[x.length];
948+ for (int i = 0; i < res.length; ++i) {
949+ res[i] = (int)x[i];
950+ }
951+ return res;
952+ }
953+ public static long[] LSExtITVec64(byte[] x) {
954+ long[] res = new long[x.length];
955+ for (int i = 0; i < res.length; ++i) {
956+ res[i] = (long)x[i];
957+ }
958+ return res;
959+ }
960+
961+ public static short LSExtIT16(char x) {
962+ return (short)x;
963+ }
964+ public static int LSExtIT32(char x) {
965+ return (int)x;
966+ }
967+ public static long LSExtIT64(char x) {
968+ return (long)x;
969+ }
970+ public static BigInteger LSExtITBig(char x) {
971+ return BigInteger.valueOf(x);
972+ }
973+
974+ public static int LSExtIT32(short x) {
975+ return (int)x;
976+ }
977+ public static long LSExtIT64(short x) {
978+ return (long)x;
979+ }
980+ public static BigInteger LSExtITBig(short x) {
981+ return BigInteger.valueOf(x);
982+ }
983+ public static int[] LSExtITVec32(short[] x) {
984+ int[] res = new int[x.length];
985+ for (int i = 0; i < res.length; ++i) {
986+ res[i] = (int)x[i];
987+ }
988+ return res;
989+ }
990+ public static long[] LSExtITVec64(short[] x) {
991+ long[] res = new long[x.length];
992+ for (int i = 0; i < res.length; ++i) {
993+ res[i] = (long)x[i];
994+ }
995+ return res;
996+ }
997+
998+ public static long LSExtIT64(int x) {
999+ return (long)x;
1000+ }
1001+ public static BigInteger LSExtITBig(int x) {
1002+ return BigInteger.valueOf(x);
1003+ }
1004+ public static long[] LSExtITVec64(int[] x) {
1005+ long[] res = new long[x.length];
1006+ for (int i = 0; i < res.length; ++i) {
1007+ res[i] = (long)x[i];
1008+ }
1009+ return res;
1010+ }
1011+ public static BigInteger LSExtITBig(long x) {
1012+ return BigInteger.valueOf(x);
1013+ }
1014+
1015+
1016+ public static short LZExtIT16(byte x) {
1017+ return (short)(x < 0 ? x + (2 << 7) : x);
1018+ }
1019+ public static int LZExtIT32(byte x) {
1020+ return (int)(x < 0 ? x + (2 << 7) : x);
1021+ }
1022+ public static long LZExtIT64(byte x) {
1023+ return (long)(x < 0 ? x + (2 << 7) : x);
1024+ }
1025+ public static BigInteger LZExtITBig(byte x) {
1026+ return BigInteger.valueOf(x < 0 ? x + (2 << 7) : x);
1027+ }
1028+ public static char LZExtITChar(byte x) {
1029+ return (char)(x < 0 ? x + (2 << 7) : x);
1030+ }
1031+ public static short[] LZExtITVec16(byte[] x) {
1032+ short[] res = new short[x.length];
1033+ for (int i = 0; i < res.length; ++i) {
1034+ res[i] = (short)(x[i] < 0 ? x[i] + (2 << 7) : x[i]);
1035+ }
1036+ return res;
1037+ }
1038+ public static int[] LZExtITVec32(byte[] x) {
1039+ int[] res = new int[x.length];
1040+ for (int i = 0; i < res.length; ++i) {
1041+ res[i] = (int)(x[i] < 0 ? x[i] + (2 << 7) : x[i]);
1042+ }
1043+ return res;
1044+ }
1045+ public static long[] LZExtITVec64(byte[] x) {
1046+ long[] res = new long[x.length];
1047+ for (int i = 0; i < res.length; ++i) {
1048+ res[i] = (long)(x[i] < 0 ? x[i] + (2 << 7) : x[i]);
1049+ }
1050+ return res;
1051+ }
1052+
1053+ public static int LZExtIT32(short x) {
1054+ return (int)(x < 0 ? x + (2 << 15) : x);
1055+ }
1056+ public static long LZExtIT64(short x) {
1057+ return (long)(x < 0 ? x + (2 << 15) : x);
1058+ }
1059+ public static BigInteger LZExtITBig(short x) {
1060+ return BigInteger.valueOf(x < 0 ? x + (2 << 15) : x);
1061+ }
1062+ public static char LZExtITChar(short x) {
1063+ return (char)(x < 0 ? x + (2 << 15) : x);
1064+ }
1065+ public static int[] LZExtITVec32(short[] x) {
1066+ int[] res = new int[x.length];
1067+ for (int i = 0; i < res.length; ++i) {
1068+ res[i] = (int)(x[i] < 0 ? x[i] + (2 << 15) : x[i]);
1069+ }
1070+ return res;
1071+ }
1072+ public static long[] LZExtITVec64(short[] x) {
1073+ long[] res = new long[x.length];
1074+ for (int i = 0; i < res.length; ++i) {
1075+ res[i] = (long)(x[i] < 0 ? x[i] + (2 << 15) : x[i]);
1076+ }
1077+ return res;
1078+ }
1079+
1080+ public static long LZExtIT64(int x) {
1081+ return (long)(x < 0 ? ((long)x) + (2l << 31) : x);
1082+ }
1083+ public static BigInteger LZExtITBig(int x) {
1084+ return BigInteger.valueOf(x < 0 ? ((long)x) + (2l << 31) : x);
1085+ }
1086+ public static char LZExtITChar(int x) {
1087+ return (char)(x < 0 ? ((long)x) + (2l << 31) : x);
1088+ }
1089+ public static long[] LZExtITVec64(int[] x) {
1090+ long[] res = new long[x.length];
1091+ for (int i = 0; i < res.length; ++i) {
1092+ res[i] = (long)(((long)x[i]) < 0 ? x[i] + (2l << 31) : x[i]);
1093+ }
1094+ return res;
1095+ }
1096+
1097+ public static BigInteger LZExtITBig(long x) {
1098+ return (x < 0 ? BigInteger.valueOf(x).add(BigInteger.valueOf(2).shiftLeft(61)) : BigInteger.valueOf(x));
1099+ }
1100+ public static char LZExtITChar(long x) {
1101+ return (char)((x < 0 ? BigInteger.valueOf(x).add(BigInteger.valueOf(2).shiftLeft(61)) : BigInteger.valueOf(x)).intValue());
1102+ }
1103+
1104+ public static byte LTruncIT8(short x) {
1105+ return (byte)x;
1106+ }
1107+ public static byte[] LTruncITVec8(short[] x) {
1108+ byte[] res = new byte[x.length];
1109+ for (int i = 0; i < res.length; ++i) {
1110+ res[i] = (byte)x[i];
1111+ }
1112+ return res;
1113+ }
1114+ public static char LTruncITChar(short x) {
1115+ return (char)x;
1116+ }
1117+
1118+ public static byte LTruncIT8(int x) {
1119+ return (byte)x;
1120+ }
1121+ public static short LTruncIT16(int x) {
1122+ return (short)x;
1123+ }
1124+ public static byte[] LTruncITVec8(int[] x) {
1125+ byte[] res = new byte[x.length];
1126+ for (int i = 0; i < res.length; ++i) {
1127+ res[i] = (byte)x[i];
1128+ }
1129+ return res;
1130+ }
1131+ public static short[] LTruncITVec16(int[] x) {
1132+ short[] res = new short[x.length];
1133+ for (int i = 0; i < res.length; ++i) {
1134+ res[i] = (short)x[i];
1135+ }
1136+ return res;
1137+ }
1138+ public static char LTruncITChar(int x) {
1139+ return (char)x;
1140+ }
1141+
1142+ public static byte LTruncIT8(long x) {
1143+ return (byte)x;
1144+ }
1145+ public static short LTruncIT16(long x) {
1146+ return (short)x;
1147+ }
1148+ public static int LTruncIT32(long x) {
1149+ return (int)x;
1150+ }
1151+ public static byte[] LTruncITVec8(long[] x) {
1152+ byte[] res = new byte[x.length];
1153+ for (int i = 0; i < res.length; ++i) {
1154+ res[i] = (byte)x[i];
1155+ }
1156+ return res;
1157+ }
1158+ public static short[] LTruncITVec16(long[] x) {
1159+ short[] res = new short[x.length];
1160+ for (int i = 0; i < res.length; ++i) {
1161+ res[i] = (short)x[i];
1162+ }
1163+ return res;
1164+ }
1165+ public static int[] LTruncITVec32(long[] x) {
1166+ int[] res = new int[x.length];
1167+ for (int i = 0; i < res.length; ++i) {
1168+ res[i] = (int)x[i];
1169+ }
1170+ return res;
1171+ }
1172+ public static char LTruncITChar(long x) {
1173+ return (char)x;
1174+ }
1175+
1176+ public static byte LTruncIT8(BigInteger x) {
1177+ return x.byteValue();
1178+ }
1179+ public static short LTruncIT16(BigInteger x) {
1180+ return x.shortValue();
1181+ }
1182+ public static int LTruncIT32(BigInteger x) {
1183+ return x.intValue();
1184+ }
1185+ public static long LTruncIT64(BigInteger x) {
1186+ return x.longValue();
1187+ }
1188+ public static char LTruncITChar(BigInteger x) {
1189+ return (char)x.intValue();
1190+ }
1191+
1192+ public static byte LTruncIT8(char x) {
1193+ return (byte)x;
1194+ }
1195+ public static short LTruncIT16(char x) {
1196+ return (short)x;
1197+ }
1198+ public static int LTruncIT32(char x) {
1199+ return (int)x;
1200+ }
1201+ public static long LTruncIT64(char x) {
1202+ return (int)x;
1203+ }
1204+ public static BigInteger LTruncITBig(char x) {
1205+ return BigInteger.valueOf(x);
1206+ }
1207+
1208+
1209+ public static double LFExp(double x) {
1210+ return Math.exp(x);
1211+ }
1212+ public static double LFLog(double x) {
1213+ return Math.log(x);
1214+ }
1215+ public static double LFSin(double x) {
1216+ return Math.sin(x);
1217+ }
1218+ public static double LFCos(double x) {
1219+ return Math.cos(x);
1220+ }
1221+ public static double LFTan(double x) {
1222+ return Math.tan(x);
1223+ }
1224+ public static double LFASin(double x) {
1225+ return Math.asin(x);
1226+ }
1227+ public static double LFACos(double x) {
1228+ return Math.acos(x);
1229+ }
1230+ public static double LFATan(double x) {
1231+ return Math.atan(x);
1232+ }
1233+ public static double LFSqrt(double x) {
1234+ return Math.sqrt(x);
1235+ }
1236+ public static double LFFloor(double x) {
1237+ return Math.floor(x);
1238+ }
1239+ public static double LFCeil(double x) {
1240+ return Math.ceil(x);
1241+ }
1242+
1243+ public static byte[] LMkVec(byte ... x) {
1244+ return x;
1245+ }
1246+ public static short[] LMkVec(short ... x) {
1247+ return x;
1248+ }
1249+ public static int[] LMKVec(int ... x) {
1250+ return x;
1251+ }
1252+ public static long[] LMKVec(long ... x) {
1253+ return x;
1254+ }
1255+
1256+ public static byte LIdxVec(byte[] x, int y) {
1257+ return x[y];
1258+ }
1259+ public static short LIdxVec(short[] x, int y) {
1260+ return x[y];
1261+ }
1262+ public static int LIdxVec(int[] x, int y) {
1263+ return x[y];
1264+ }
1265+ public long LIdxVec(long[] x, int y) {
1266+ return x[y];
1267+ }
1268+
1269+ public static byte[] LUpdateVec(byte[] x, int y, byte z) {
1270+ x[y] = z;
1271+ return x;
1272+ }
1273+ public static short[] LUpdateVec(short[] x, int y, short z) {
1274+ x[y] = z;
1275+ return x;
1276+ }
1277+ public static int[] LUpdateVec(int[] x, int y, int z) {
1278+ x[y] = z;
1279+ return x;
1280+ }
1281+ public long[] LUpdateVec(long[] x, int y, long z) {
1282+ x[y] = z;
1283+ return x;
1284+ }
1285+
1286+ public static String LStrConcat(String ... args) {
1287+ StringBuilder builder = new StringBuilder();
1288+ for (String arg : args) {
1289+ builder.append(arg);
1290+ }
1291+ return builder.toString();
1292+ }
1293+
1294+ public static int LStrLt(String x, String y) {
1295+ return (x.compareTo(y) < 0 ? 1 : 0);
1296+ }
1297+
1298+ public static int LStrEq(String x, String y) {
1299+ return (x.equals(y) ? 1 : 0);
1300+ }
1301+
1302+ public static int LStrLen(String x) {
1303+ return x.length();
1304+ }
1305+
1306+ public static double LIntFloat(byte x) {
1307+ return (double)x;
1308+ }
1309+ public static double LIntFloat(char x) {
1310+ return (double)x;
1311+ }
1312+ public static double LIntFloat(short x) {
1313+ return (double)x;
1314+ }
1315+ public static double LIntFloat(int x) {
1316+ return (double)x;
1317+ }
1318+ public static double LIntFloat(long x) {
1319+ return (double)x;
1320+ }
1321+ public static double LIntFloat(BigInteger x) {
1322+ return x.doubleValue();
1323+ }
1324+
1325+ public static byte LFloatIntIT8(double x) {
1326+ return (byte)x;
1327+ }
1328+ public static short LFloatIntIT16(double x) {
1329+ return (short)x;
1330+ }
1331+ public static int LFloatIntIT32(double x) {
1332+ return (int)x;
1333+ }
1334+ public static long LFloatIntIT64(double x) {
1335+ return (long)x;
1336+ }
1337+ public static BigInteger LFloatIntITBig(double x) {
1338+ return BigInteger.valueOf((long)x);
1339+ }
1340+ public static char LFloatIntITChar(double x) {
1341+ return (char)x;
1342+ }
1343+
1344+ public static String LIntStr(byte x) {
1345+ return Byte.toString(x);
1346+ }
1347+ public static String LIntStr(char x) {
1348+ return Character.toString(x);
1349+ }
1350+ public static String LIntStr(short x) {
1351+ return Short.toString(x);
1352+ }
1353+ public static String LIntStr(int x) {
1354+ return Integer.toString(x);
1355+ }
1356+ public static String LIntStr(long x) {
1357+ return Long.toString(x);
1358+ }
1359+ public static String LIntStr(BigInteger x) {
1360+ return x.toString();
1361+ }
1362+ public static byte LStrIntIT8(String x) {
1363+ return Byte.parseByte(x);
1364+ }
1365+ public static short LStrIntIT16(String x) {
1366+ return Short.parseShort(x);
1367+ }
1368+ public static int LStrIntIT32(String x) {
1369+ return Integer.parseInt(x);
1370+ }
1371+ public static long LStrIntIT64(String x) {
1372+ return Long.parseLong(x);
1373+ }
1374+ public static BigInteger LStrIntITBig(String x) {
1375+ return new BigInteger(x);
1376+ }
1377+ public static char LStrIntITChar(String x) {
1378+ return x.charAt(0);
1379+ }
1380+
1381+ public static String LFloatStr(double x) {
1382+ return Double.toString(x);
1383+ }
1384+ public static double LStrFloat(String x) {
1385+ return Double.parseDouble(x);
1386+ }
1387+
1388+ public static char LIntCh(byte x) {
1389+ return (char)x;
1390+ }
1391+ public static char LIntCh(char x) {
1392+ return x;
1393+ }
1394+ public static char LIntCh(short x) {
1395+ return (char)x;
1396+ }
1397+ public static char LIntCh(int x) {
1398+ return (char)x;
1399+ }
1400+ public static char LIntCh(long x) {
1401+ return (char)x;
1402+ }
1403+ public static char LIntCh(BigInteger x) {
1404+ return (char)(x.intValue());
1405+ }
1406+ public static byte LChIntIT8(char x) {
1407+ return (byte)x;
1408+ }
1409+ public static short LChIntIT16(char x) {
1410+ return (short)x;
1411+ }
1412+ public static int LChIntIT32(char x) {
1413+ return (int)x;
1414+ }
1415+ public static long LChIntIT64(char x) {
1416+ return (long)x;
1417+ }
1418+ public static BigInteger LChIntITBig(char x) {
1419+ return BigInteger.valueOf((long)x);
1420+ }
1421+
1422+ public static void LPrintNum(Object x) {
1423+ System.out.print(x);
1424+ }
1425+ public static void LPrintStr(String x) {
1426+ System.out.print(x);
1427+ }
1428+ public static String LReadStr(Object x) {
1429+ try {
1430+ return ForeignPrimitives.idris_readStr(x);
1431+ } catch (IOException ex) {
1432+ throw new RuntimeException(ex);
1433+ }
1434+ }
1435+
1436+ public static char LStrHead(String x) {
1437+ return x.charAt(0);
1438+ }
1439+ public static String LStrTail(String x) {
1440+ return x.substring(1);
1441+ }
1442+ public static String LStrCons(char x, String y) {
1443+ return String.format("%c%s", x, y);
1444+ }
1445+ public static char LStrIndex(String x, int y) {
1446+ return x.charAt(y);
1447+ }
1448+ public static String LStrRev(String x) {
1449+ return new StringBuffer(x).reverse().toString();
1450+ }
1451+
1452+ public static InputStream LStdIn() {
1453+ return System.in;
1454+ }
1455+ public static OutputStream LStdOut() {
1456+ return System.out;
1457+ }
1458+ public static OutputStream LStdErr() {
1459+ return System.err;
1460+ }
1461+ public static Thread LVMPtr() {
1462+ return Thread.currentThread();
1463+ }
1464+}
java/src/main/java/org/idris/rts/TailCallClosure.javadeleted−26
@@ -1,26 +0,0 @@
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−
src/IRTS/CodegenJava.hs+536−1401
@@ -1,37 +1,42 @@
1+{-# LANGUAGE PatternGuards #-}
1module IRTS.CodegenJava (codegenJava) where
2module IRTS.CodegenJava (codegenJava) where
2
3
3−import Core.TT
4+import Core.TT hiding (mkApp)
4import IRTS.BCImp
5import IRTS.BCImp
5import IRTS.CodegenCommon
6import IRTS.CodegenCommon
7+import IRTS.Java.ASTBuilding
8+import IRTS.Java.JTypes
9+import IRTS.Java.Mangling
6import IRTS.Lang
10import IRTS.Lang
7import IRTS.Simplified
11import IRTS.Simplified
8import Paths_idris
12import Paths_idris
9import Util.System
13import Util.System
10
14
11−import Control.Applicative
15+import Control.Applicative hiding (Const)
12import Control.Arrow
16import Control.Arrow
13import Control.Monad
17import Control.Monad
18+import Control.Monad.Error
14−import qualified Control.Monad.Trans as T
19+import qualified Control.Monad.Trans as T
15import Control.Monad.Trans.State
20import Control.Monad.Trans.State
16−import Data.Char
17−import Data.Maybe (fromJust)
18−import Data.List (isPrefixOf, isSuffixOf, intercalate, foldl')
19import Data.Int
21import Data.Int
22+import Data.List (foldl', intercalate, isPrefixOf,
23+ isSuffixOf)
24+import Data.Maybe (fromJust)
20−import qualified Data.Text as T
25+import qualified Data.Text as T
21−import qualified Data.Text.IO as TIO
26+import qualified Data.Text.IO as TIO
27+import qualified Data.Vector.Unboxed as V
22import Language.Java.Parser
28import Language.Java.Parser
23import Language.Java.Pretty
29import Language.Java.Pretty
24−import Language.Java.Syntax hiding (Name)
30+import Language.Java.Syntax hiding (Name)
25−import qualified Language.Java.Syntax as J
31+import qualified Language.Java.Syntax as J
26import System.Directory
32import System.Directory
27import System.Exit
33import System.Exit
28import System.FilePath
34import System.FilePath
29import System.IO
35import System.IO
30import System.Process
36import System.Process
31
37
32−data CodeGenerationEnv = CodeGenerationEnv { globalVariablePositions :: [(Name, Integer)] }
38+-----------------------------------------------------------------------
33−
39+-- Main function
34−type CodeGeneration = StateT (CodeGenerationEnv) (Either String)
35
40
36codegenJava :: [(Name, SExp)] -> -- initialization of globals
41codegenJava :: [(Name, SExp)] -> -- initialization of globals
37 [(Name, SDecl)] ->
42 [(Name, SDecl)] ->
@@ -44,12 +49,11 @@ codegenJava globalInit defs out hdrs libs exec = do
44 withTempdir (takeBaseName out) $ \ tmpDir -> do
49 withTempdir (takeBaseName out) $ \ tmpDir -> do
45 let srcdir = tmpDir </> "src" </> "main" </> "java"
50 let srcdir = tmpDir </> "src" </> "main" </> "java"
46 createDirectoryIfMissing True srcdir
51 createDirectoryIfMissing True srcdir
47− let (Ident clsName) =
48− either error id (evalStateT (mkClassName out) (mkCodeGenEnv globalInit))
52+ let (Ident clsName) = either error id (mkClassName out)
49 let outjava = srcdir </> clsName <.> "java"
53 let outjava = srcdir </> clsName <.> "java"
50 let jout = either error
54 let jout = either error
51− (flatIndent . prettyPrint)
55+ (prettyPrint)-- flatIndent . prettyPrint)
52− (evalStateT (mkCompilationUnit globalInit defs hdrs out) (mkCodeGenEnv globalInit))
56+ (evalStateT (mkCompilationUnit globalInit defs hdrs out) mkCodeGenEnv)
53 writeFile outjava jout
57 writeFile outjava jout
54 if (exec == Raw)
58 if (exec == Raw)
55 then copyFile outjava (takeDirectory out </> clsName <.> "java")
59 then copyFile outjava (takeDirectory out </> clsName <.> "java")
@@ -58,8 +62,8 @@ codegenJava globalInit defs out hdrs libs exec = do
58 execPomTemplate <- TIO.readFile execPom
62 execPomTemplate <- TIO.readFile execPom
59 let execPom = T.replace (T.pack "$MAIN-CLASS$")
63 let execPom = T.replace (T.pack "$MAIN-CLASS$")
60 (T.pack clsName)
64 (T.pack clsName)
61− (T.replace (T.pack "$ARTIFACT-NAME$")
65+ (T.replace (T.pack "$ARTIFACT-NAME$")
62− (T.pack $ takeBaseName out)
66+ (T.pack $ takeBaseName out)
63 (T.replace (T.pack "$DEPENDENCIES$")
67 (T.replace (T.pack "$DEPENDENCIES$")
64 (mkPomDependencies libs)
68 (mkPomDependencies libs)
65 execPomTemplate
69 execPomTemplate
@@ -72,11 +76,11 @@ codegenJava globalInit defs out hdrs libs exec = do
72 when (exit /= ExitSuccess) $ error ("FAILURE: " ++ mvnCmd ++ " compile\n" ++ err ++ mvout)
76 when (exit /= ExitSuccess) $ error ("FAILURE: " ++ mvnCmd ++ " compile\n" ++ err ++ mvout)
73 if (exec == Object)
77 if (exec == Object)
74 then do
78 then do
75− classFiles <-
79+ classFiles <-
76 map (\ clsFile -> tmpDir </> "target" </> "classes" </> clsFile)
80 map (\ clsFile -> tmpDir </> "target" </> "classes" </> clsFile)
77− . filter ((".class" ==) . takeExtension)
81+ . filter ((".class" ==) . takeExtension)
78 <$> getDirectoryContents (tmpDir </> "target" </> "classes")
82 <$> getDirectoryContents (tmpDir </> "target" </> "classes")
79− mapM_ (\ clsFile -> copyFile clsFile (takeDirectory out </> takeFileName clsFile))
83+ mapM_ (\ clsFile -> copyFile clsFile (takeDirectory out </> takeFileName clsFile))
80 classFiles
84 classFiles
81 else do
85 else do
82 (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ ["package"]) ""
86 (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ ["package"]) ""
@@ -94,8 +98,11 @@ codegenJava globalInit defs out hdrs libs exec = do
94 readProcess mvnCmd (args ++ ["clean"]) ""
98 readProcess mvnCmd (args ++ ["clean"]) ""
95 removeFile (tmpDir </> "pom.xml")
99 removeFile (tmpDir </> "pom.xml")
96
100
101+-----------------------------------------------------------------------
102+-- Jar and Pom infrastructure
103+
97jarHeader :: String
104jarHeader :: String
98−jarHeader =
105+jarHeader =
99 "#!/bin/sh\n"
106 "#!/bin/sh\n"
100 ++ "MYSELF=`which \"$0\" 2>/dev/null`\n"
107 ++ "MYSELF=`which \"$0\" 2>/dev/null`\n"
101 ++ "[ $? -gt 0 -a -f \"$0\" ] && MYSELF=\"./$0\"\n"
108 ++ "[ $? -gt 0 -a -f \"$0\" ] && MYSELF=\"./$0\"\n"
@@ -110,7 +117,7 @@ mkPomDependencies :: [String] -> T.Text
110mkPomDependencies deps =
117mkPomDependencies deps =
111 T.concat $ map (T.concat . map (T.append (T.pack " ")) . mkDependency . T.pack) deps
118 T.concat $ map (T.concat . map (T.append (T.pack " ")) . mkDependency . T.pack) deps
112 where
119 where
113− mkDependency s =
120+ mkDependency s =
114 case T.splitOn (T.pack ":") s of
121 case T.splitOn (T.pack ":") s of
115 [g, a, v] ->
122 [g, a, v] ->
116 [ T.pack $ "<dependency>\n"
123 [ T.pack $ "<dependency>\n"
@@ -124,136 +131,236 @@ mkPomDependencies deps =
124 mkArtifactId a = T.append (T.pack $ "<artifactId>") (T.append a $ T.pack "</artifactId>\n")
131 mkArtifactId a = T.append (T.pack $ "<artifactId>") (T.append a $ T.pack "</artifactId>\n")
125 mkVersion v = T.append (T.pack $ "<version>") (T.append v $ T.pack "</version>\n")
132 mkVersion v = T.append (T.pack $ "<version>") (T.append v $ T.pack "</version>\n")
126
133
127−mkCodeGenEnv :: [(Name, SExp)] -> CodeGenerationEnv
134+-----------------------------------------------------------------------
135+-- Code generation environment
136+
137+data CodeGenerationEnv
138+ = CodeGenerationEnv
139+ { globalVariables :: [(Name, ArrayIndex)]
140+ , localVariables :: [[(Int, Ident)]]
141+ , localVarCounter :: Int
142+ }
143+
144+type CodeGeneration = StateT (CodeGenerationEnv) (Either String)
145+
128−mkCodeGenEnv globalInit =
146+mkCodeGenEnv :: CodeGenerationEnv
129− CodeGenerationEnv $ zipWith (\ (name, _) pos -> (name, pos)) globalInit [0..]
147+mkCodeGenEnv = CodeGenerationEnv [] [] 0
148+
149+varPos :: LVar -> CodeGeneration (Either ArrayIndex Ident)
150+varPos (Loc i) = do
151+ vars <- (concat . localVariables) <$> get
152+ case lookup i vars of
153+ (Just varName) -> return (Right varName)
154+ Nothing -> throwError $ "Invalid local variable id: " ++ show i
155+varPos (Glob name) = do
156+ vars <- globalVariables <$> get
157+ case lookup name vars of
158+ (Just varIdx) -> return (Left varIdx)
159+ Nothing -> throwError $ "Invalid global variable id: " ++ show name
160+
161+pushScope :: CodeGeneration ()
162+pushScope =
163+ modify (\ env -> env { localVariables = []:(localVariables env) })
164+
165+popScope :: CodeGeneration ()
166+popScope = do
167+ env <- get
168+ let lVars = tail $ localVariables env
169+ let vC = if null lVars then 0 else localVarCounter env
170+ put $ env { localVariables = tail (localVariables env)
171+ , localVarCounter = vC }
172+
173+setVariable :: LVar -> CodeGeneration (Either ArrayIndex Ident)
174+setVariable (Loc i) = do
175+ env <- get
176+ let lVars = localVariables env
177+ let getter = localVar $ localVarCounter env
178+ let lVars' = ((i, getter) : head lVars) : tail lVars
179+ put $ env { localVariables = lVars'
180+ , localVarCounter = 1 + localVarCounter env}
181+ return (Right getter)
182+setVariable (Glob n) = do
183+ env <- get
184+ let gVars = globalVariables env
185+ let getter = globalContext @! length gVars
186+ let gVars' = (n, getter):gVars
187+ put (env { globalVariables = gVars' })
188+ return (Left getter)
189+
190+pushParams :: [Ident] -> CodeGeneration ()
191+pushParams paramNames =
192+ let varMap = zipWith (flip (,)) paramNames [0..] in
193+ modify (\ env -> env { localVariables = varMap:(localVariables env)
194+ , localVarCounter = (length varMap) + (localVarCounter env) })
195+
196+flatIndent :: String -> String
197+flatIndent (' ' : ' ' : xs) = flatIndent xs
198+flatIndent (x:xs) = x:flatIndent xs
199+flatIndent [] = []
200+
201+-----------------------------------------------------------------------
202+-- Maintaining control structures over code blocks
203+
204+data BlockPostprocessor
205+ = BlockPostprocessor
206+ { ppInnerBlock :: [BlockStmt] -> Exp -> CodeGeneration [BlockStmt]
207+ , ppOuterBlock :: [BlockStmt] -> CodeGeneration [BlockStmt]
208+ }
209+
210+ppExp :: BlockPostprocessor -> Exp -> CodeGeneration [BlockStmt]
211+ppExp pp exp = ((ppInnerBlock pp) [] exp) >>= ppOuterBlock pp
212+
213+addReturn :: BlockPostprocessor
214+addReturn =
215+ BlockPostprocessor
216+ { ppInnerBlock = (\ block exp -> return $ block ++ [jReturn exp])
217+ , ppOuterBlock = return
218+ }
219+
220+ignoreResult :: BlockPostprocessor
221+ignoreResult =
222+ BlockPostprocessor
223+ { ppInnerBlock = (\ block exp -> return block)
224+ , ppOuterBlock = return
225+ }
226+
227+ignoreOuter :: BlockPostprocessor -> BlockPostprocessor
228+ignoreOuter pp = pp { ppOuterBlock = return }
229+
230+throwRuntimeException :: BlockPostprocessor -> BlockPostprocessor
231+throwRuntimeException pp =
232+ pp
233+ { ppInnerBlock =
234+ (\ blk exp -> return $
235+ blk ++ [ BlockStmt $ Throw
236+ ( InstanceCreation
237+ []
238+ (toClassType runtimeExceptionType)
239+ [exp]
240+ Nothing
241+ )
242+ ]
243+ )
244+ }
245+
246+
247+rethrowAsRuntimeException :: BlockPostprocessor -> BlockPostprocessor
248+rethrowAsRuntimeException pp =
249+ pp
250+ { ppOuterBlock =
251+ (\ blk -> do
252+ ex <- ppInnerBlock (throwRuntimeException pp) [] (ExpName $ J.Name [Ident "ex"])
253+ ppOuterBlock pp
254+ $ [ BlockStmt $ Try
255+ (Block blk)
256+ [Catch (FormalParam [] exceptionType False (VarId (Ident "ex"))) $
257+ Block ex
258+ ]
259+ Nothing
260+ ]
261+ )
262+ }
263+
264+-----------------------------------------------------------------------
265+-- File structure
130
266
131mkCompilationUnit :: [(Name, SExp)] -> [(Name, SDecl)] -> [String] -> FilePath -> CodeGeneration CompilationUnit
267mkCompilationUnit :: [(Name, SExp)] -> [(Name, SDecl)] -> [String] -> FilePath -> CodeGeneration CompilationUnit
132−mkCompilationUnit globalInit defs hdrs out =
268+mkCompilationUnit globalInit defs hdrs out = do
269+ clsName <- mkClassName out
133 CompilationUnit Nothing ( [ ImportDecl False idrisRts True
270 CompilationUnit Nothing ( [ ImportDecl False idrisRts True
134 , ImportDecl True idrisForeign True
271 , ImportDecl True idrisForeign True
272+ , ImportDecl False idrisPrimFn False
135 , ImportDecl False bigInteger False
273 , ImportDecl False bigInteger False
136− , ImportDecl False stringBuffer False
137 , ImportDecl False runtimeException False
274 , ImportDecl False runtimeException False
138− , ImportDecl False scanner False
139− , ImportDecl False arrays False
140 ] ++ otherHdrs
275 ] ++ otherHdrs
141 )
276 )
142− <$> mkTypeDecl globalInit defs out
277+ <$> mkTypeDecl clsName globalInit defs
143 where
278 where
144 idrisRts = J.Name $ map Ident ["org", "idris", "rts"]
279 idrisRts = J.Name $ map Ident ["org", "idris", "rts"]
145 idrisForeign = J.Name $ map Ident ["org", "idris", "rts", "ForeignPrimitives"]
280 idrisForeign = J.Name $ map Ident ["org", "idris", "rts", "ForeignPrimitives"]
281+ idrisPrimFn = J.Name $ map Ident ["org", "idris", "rts", "PrimFn"]
146 bigInteger = J.Name $ map Ident ["java", "math", "BigInteger"]
282 bigInteger = J.Name $ map Ident ["java", "math", "BigInteger"]
147− stringBuffer = J.Name $ map Ident ["java", "lang", "StringBuffer"]
148 runtimeException = J.Name $ map Ident ["java", "lang", "RuntimeException"]
283 runtimeException = J.Name $ map Ident ["java", "lang", "RuntimeException"]
149− scanner = J.Name $ map Ident ["java", "util", "Scanner"]
150− arrays = J.Name $ map Ident ["java", "util", "Arrays"]
151 otherHdrs = map ( (\ name -> ImportDecl False name False)
284 otherHdrs = map ( (\ name -> ImportDecl False name False)
152− . J.Name
285+ . J.Name
153− . map (Ident . T.unpack)
286+ . map (Ident . T.unpack)
154− . T.splitOn (T.pack ".")
287+ . T.splitOn (T.pack ".")
155− . T.pack)
288+ . T.pack)
156 $ filter (not . isSuffixOf ".h") hdrs
289 $ filter (not . isSuffixOf ".h") hdrs
157
290
158−flatIndent :: String -> String
291+-----------------------------------------------------------------------
159−flatIndent (' ' : ' ' : xs) = flatIndent xs
292+-- Main class
160−flatIndent (x:xs) = x:flatIndent xs
293+
161−flatIndent [] = []
162−
163−prefixCallNamespaces :: Ident -> SExp -> SExp
164−prefixCallNamespaces (Ident name) (SApp tail (NS n ns) args) = SApp tail (NS n (name:ns)) args
165−prefixCallNamespaces name (SLet var e1 e2) = SLet var (prefixCallNamespaces name e1) (prefixCallNamespaces name e2)
166−prefixCallNamespaces name (SUpdate var e) = SUpdate var (prefixCallNamespaces name e)
167−prefixCallNamespaces name (SCase var alts) = SCase var (map (prefixCallNamespacesCase name) alts)
168−prefixCallNamespaces name (SChkCase var alts) = SChkCase var (map (prefixCallNamespacesCase name) alts)
169−prefixCallNamespaces _ exp = exp
170−
171−prefixCallNamespacesCase :: Ident -> SAlt -> SAlt
172−prefixCallNamespacesCase name (SConCase x y n ns e) = SConCase x y n ns (prefixCallNamespaces name e)
173−prefixCallNamespacesCase name (SConstCase c e) = SConstCase c (prefixCallNamespaces name e)
174−prefixCallNamespacesCase name (SDefaultCase e) = SDefaultCase (prefixCallNamespaces name e)
175−
176−prefixCallNamespacesDecl :: Ident -> SDecl -> SDecl
177−prefixCallNamespacesDecl name (SFun fname args i e) = SFun fname args i (prefixCallNamespaces name e)
178−
179−mkTypeDecl :: [(Name, SExp)] -> [(Name, SDecl)] -> FilePath -> CodeGeneration [TypeDecl]
294+mkTypeDecl :: Ident -> [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration [TypeDecl]
180−mkTypeDecl globalInit defs out =
295+mkTypeDecl name globalInit defs =
181− (\ name body -> [ClassTypeDecl $ ClassDecl [ Public
296+ (\ body -> [ClassTypeDecl $ ClassDecl [ Public
182− , Annotation $ SingleElementAnnotation
297+ , Annotation $ SingleElementAnnotation
183− (J.Name [Ident "SuppressWarnings"])
298+ (jName "SuppressWarnings")
184− (EVVal . InitExp . Lit $ String "unchecked")
299+ (EVVal . InitExp $ jString "unchecked")
185− ]
300+ ]
186− name
301+ name
187− []
302+ []
188− Nothing
303+ Nothing
189− []
304+ []
190− body])
305+ body])
191− <$> mkClassName out
192− <*> ( mkClassName out
193− >>= (\ ident -> mkClassBody globalInit (map (second (prefixCallNamespacesDecl ident)) defs))
306+ <$> mkClassBody globalInit (map (second (prefixCallNamespaces name)) defs)
194− )
195−
196−mkClassName :: FilePath -> CodeGeneration Ident
197−mkClassName path =
198− T.lift $ left (\ err -> "Parser error in \"" ++ path ++ "\": " ++ (show err))
199− (parser ident . takeBaseName $ takeFileName path)
200
307
201mkClassBody :: [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration ClassBody
308mkClassBody :: [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration ClassBody
202−mkClassBody globalInit defs =
309+mkClassBody globalInit defs =
203 (\ globals defs -> ClassBody . (globals++) . addMainMethod . mergeInnerClasses $ defs)
310 (\ globals defs -> ClassBody . (globals++) . addMainMethod . mergeInnerClasses $ defs)
204 <$> mkGlobalContext globalInit
311 <$> mkGlobalContext globalInit
205 <*> mapM mkDecl defs
312 <*> mapM mkDecl defs
206
313
207mkGlobalContext :: [(Name, SExp)] -> CodeGeneration [Decl]
314mkGlobalContext :: [(Name, SExp)] -> CodeGeneration [Decl]
208mkGlobalContext [] = return []
315mkGlobalContext [] = return []
209−mkGlobalContext initExps =
316+mkGlobalContext initExps = do
317+ pushScope
318+ varInit <-
319+ mapM (\ (name, exp) -> do
320+ pos <- setVariable (Glob name)
321+ mkUpdate ignoreResult (Glob name) exp
322+ ) initExps
323+ popScope
210− (\ exps -> [ MemberDecl $ FieldDecl [Private, Static, Final]
324+ return [ MemberDecl $ FieldDecl [Private, Static, Final]
211− objectArrayType
325+ (array objectType)
212− [VarDecl (VarId $ Ident "globalContext")
326+ [ VarDecl (VarId $ globalContextID). Just . InitExp
213− (Just . InitArray $ ArrayInit exps)
327+ $ ArrayCreate objectType [jInt $ length initExps] 0
214 ]
328 ]
215− ]
329+ , InitDecl True (Block $ concat varInit)
216− )
330+ ]
217− <$> mapM (\ (_, exp) -> InitExp <$> mkExp exp) initExps
218−
219−
220
331
221addMainMethod :: [Decl] -> [Decl]
332addMainMethod :: [Decl] -> [Decl]
222addMainMethod decls
333addMainMethod decls
223 | findMain decls = mkMainMethod : decls
334 | findMain decls = mkMainMethod : decls
224 | otherwise = decls
335 | otherwise = decls
225 where
336 where
226− findMain ((MemberDecl (MemberClassDecl (ClassDecl _ (Ident "Main") _ _ _ (ClassBody body)))):_) =
337+ findMain ((MemberDecl (MemberClassDecl (ClassDecl _ name _ _ _ (ClassBody body)))):_)
227− findMainMethod body
338+ | name == mangle' (UN "Main") = findMainMethod body
228 findMain (_:decls) = findMain decls
339 findMain (_:decls) = findMain decls
229 findMain [] = False
340 findMain [] = False
230
341
342+ innerMainMethod = (either error id $ mangle (UN "main"))
231− findMainMethod ((MemberDecl (MethodDecl _ _ _ (Ident "main") [] _ _)):_) = True
343+ findMainMethod ((MemberDecl (MethodDecl _ _ _ name [] _ _)):_)
344+ | name == mangle' (UN "main") = True
232 findMainMethod (_:decls) = findMainMethod decls
345 findMainMethod (_:decls) = findMainMethod decls
233 findMainMethod [] = False
346 findMainMethod [] = False
234
347
235mkMainMethod :: Decl
348mkMainMethod :: Decl
236−mkMainMethod =
349+mkMainMethod =
350+ simpleMethod
237− MemberDecl $ MethodDecl [Public, Static]
351+ [Public, Static]
238− []
239− Nothing
352+ Nothing
240− (Ident "main")
353+ "main"
241− [FormalParam [] stringArrayType False (VarId $ Ident "args")]
354+ [FormalParam [] (array stringType) False (VarId $ Ident "args")]
242− []
243− (MethodBody . Just $ Block [ BlockStmt . ExpStmt . MethodInv $
355+ $ Block [ BlockStmt . ExpStmt
244− MethodCall (J.Name [Ident "idris_initArgs"])
245− [ MethodInv $ TypeMethodCall
246− (J.Name [Ident "Thread"])
247− []
248− (Ident "currentThread")
356+ $ call "idris_initArgs" [ (threadType ~> "currentThread") []
249− []
357+ , jConst "args"
250− , ExpName $ J.Name [Ident "args"]
251− ]
358+ ]
252− , BlockStmt . ExpStmt . MethodInv $
359+ , BlockStmt . ExpStmt $ call (mangle' (MN 0 "runMain")) []
253− MethodCall (J.Name [Ident "runMain_0"])
254− []
255− ]
360+ ]
256− )
361+
362+-----------------------------------------------------------------------
363+-- Inner classes (idris namespaces)
257
364
258mergeInnerClasses :: [Decl] -> [Decl]
365mergeInnerClasses :: [Decl] -> [Decl]
259mergeInnerClasses = foldl' mergeInner []
366mergeInnerClasses = foldl' mergeInner []
@@ -274,1308 +381,336 @@ mergeInnerClasses = foldl' mergeInner []
274 mergeInner [] decl' = [decl']
381 mergeInner [] decl' = [decl']
275
382
276
383
277−mkIdentifier :: Name -> CodeGeneration Ident
278−mkIdentifier (NS name _) = mkIdentifier name
279−mkIdentifier (MN i name) = (\ (Ident x) -> Ident $ x ++ ('_' : show i))
280− <$> mkIdentifier (UN name)
281−mkIdentifier (UN name) =
282− T.lift $ left (\ err -> "Parser error in \"" ++ name ++ "\": " ++ (show err))
283− ( parser ident
284− . cleanReserved
285− . cleanNonLetter
286− . cleanStart
287− $ cleanWs False name)
288− where
289− cleanStart (x:xs)
290− | isNumber x = '_' : (x:xs)
291− | otherwise = (x:xs)
292− cleanStart [] = []
293− cleanNonLetter (x:xs)
294− | x == '#' = "_Hash" ++ cleanNonLetter xs
295− | x == '@' = "_At" ++ cleanNonLetter xs
296− | x == '$' = "_Dollar" ++ cleanNonLetter xs
297− | x == '!' = "_Bang" ++ cleanNonLetter xs
298− | x == '.' = "_Dot" ++ cleanNonLetter xs
299− | x == '\'' = "_Prime" ++ cleanNonLetter xs
300− | x == '*' = "_Times" ++ cleanNonLetter xs
301− | x == '+' = "_Plus" ++ cleanNonLetter xs
302− | x == '/' = "_Divide" ++ cleanNonLetter xs
303− | x == '-' = "_Minus" ++ cleanNonLetter xs
304− | x == '%' = "_Mod" ++ cleanNonLetter xs
305− | x == '<' = "_LessThan" ++ cleanNonLetter xs
306− | x == '=' = "_Equals" ++ cleanNonLetter xs
307− | x == '>' = "_MoreThan" ++ cleanNonLetter xs
308− | x == '[' = "_LSBrace" ++ cleanNonLetter xs
309− | x == ']' = "_RSBrace" ++ cleanNonLetter xs
310− | x == '(' = "_LBrace" ++ cleanNonLetter xs
311− | x == ')' = "_RBrace" ++ cleanNonLetter xs
312− | x == '_' = "__" ++ cleanNonLetter xs
313− | not (isAlphaNum x) = "_" ++ (show $ ord x) ++ xs
314− | otherwise = x:cleanNonLetter xs
315− cleanNonLetter [] = []
316− cleanWs capitalize (x:xs)
317− | isSpace x = cleanWs True xs
318− | capitalize = (toUpper x) : (cleanWs False xs)
319− | otherwise = x : (cleanWs False xs)
320− cleanWs _ [] = []
321−
322−
323− cleanReserved "param" = "_param"
324− cleanReserved "globalContext" = "_globalContext"
325− cleanReserved "context" = "_context"
326− cleanReserved "newcontext" = "_newcontext"
327−
328− cleanReserved "void" = "_void"
329− cleanReserved "null" = "_null"
330− cleanReserved "int" = "_int"
331− cleanReserved "long" = "_long"
332− cleanReserved "char" = "_char"
333− cleanReserved "byte" = "_byte"
334− cleanReserved "double" = "_double"
335− cleanReserved "float" = "_float"
336− cleanReserved "boolean" = "_boolean"
337− cleanReserved "Object" = "_Object"
338− cleanReserved "String" = "_String"
339− cleanReserved "StringBuilder" = "_StringBuilder"
340− cleanReserved "StringBuffer" = "_StringBuffer"
341− cleanReserved "Scanner" = "_Scanner"
342− cleanReserved "Integer" = "_Integer"
343− cleanReserved "Double" = "_Double"
344− cleanReserved "Byte" = "_Byte"
345− cleanReserved "Character" = "_Character"
346− cleanReserved "BigInteger" = "_BigInteger"
347− cleanReserved "Boolean" = "_Boolean"
348− cleanReserved "Closure" = "_Closure"
349− cleanReserved "IdrisObject" = "_IdrisObject"
350− cleanReserved "TailCallClosure" = "_TailCallClosure"
351− cleanReserved "System" = "_System"
352− cleanReserved "Math" = "_Math"
353− cleanReserved "Arrays" = "_Arrays"
354− cleanReserved "RuntimeException" = "_RuntimeException"
355− cleanReserved "Comparable" = "_Comparable"
356−
357− cleanReserved "class" = "_class"
358− cleanReserved "enum" = "_enum"
359− cleanReserved "interface" = "_interface"
360− cleanReserved "extends" = "_extends"
361− cleanReserved "implements" = "_implements"
362− cleanReserved "public" = "_public"
363− cleanReserved "private" = "_private"
364− cleanReserved "protected" = "_protected"
365− cleanReserved "static" = "_static"
366− cleanReserved "final" = "_final"
367− cleanReserved "abstract" = "_abstract"
368− cleanReserved "strict" = "_strict"
369− cleanReserved "volatile" = "_volatile"
370− cleanReserved "transient" = "_transient"
371− cleanReserved "native" = "_native"
372− cleanReserved "const" = "_const"
373−
374− cleanReserved "import" = "_import"
375− cleanReserved "package" = "_package"
376−
377− cleanReserved "throw" = "_throw"
378− cleanReserved "throws" = "_throws"
379− cleanReserved "try" = "_try"
380− cleanReserved "catch" = "_catch"
381−
382− cleanReserved "synchronized" = "_synchronized"
383−
384− cleanReserved "if" = "_if"
385− cleanReserved "else" = "_else"
386− cleanReserved "switch" = "_switch"
387− cleanReserved "case" = "_case"
388− cleanReserved "default" = "_default"
389−
390− cleanReserved "while" = "_while"
391− cleanReserved "for" = "_for"
392− cleanReserved "do" = "_do"
393− cleanReserved "break" = "_break"
394− cleanReserved "continue" = "_continue"
395− cleanReserved "goto" = "_goto"
396−
397− cleanReserved "this" = "_this"
398− cleanReserved "super" = "_super"
399− cleanReserved "new" = "_new"
400− cleanReserved "return" = "_return"
401−
402− cleanReserved "idris_initArgs" = "_idris_initArgs"
403− cleanReserved "idris_numArgs" = "_idris_numArgs"
404− cleanReserved "idris_getArg" = "_idris_getArg"
405− cleanReserved "getenv" = "_getenv"
406− cleanReserved "exit" = "_exit"
407− cleanReserved "usleep" = "_usleep"
408− cleanReserved "idris_sendMessage" = "_idris_sendMessage"
409− cleanReserved "idris_checkMessage" = "_idris_checkMessage"
410− cleanReserved "idris_recvMessage" = "_idris_recvMessage"
411− cleanReserved "putStr" = "_putStr"
412− cleanReserved "putchar" = "_putchar"
413− cleanReserved "getchar" = "_getchar"
414− cleanReserved "fileOpen" = "_fileOpen"
415− cleanReserved "fileClose" = "_fileClose"
416− cleanReserved "fputStr" = "_fputStr"
417− cleanReserved "fileEOF" = "_fileEOF"
418− cleanReserved "isNull" = "_isNull"
419− cleanReserved "idris_K" = "_idris_K"
420− cleanReserved "idris_flipK" = "_idris_flipK"
421− cleanReserved "idris_assignStack" = "_idris_assignStack"
422− cleanReserved "free" = "_free"
423− cleanReserved "malloc" = "_malloc"
424− cleanReserved "idris_memset" = "_idris_memset"
425− cleanReserved "idris_peek" = "_idris_peek"
426− cleanReserved "idris_poke" = "_idris_poke"
427− cleanReserved "idris_memmove" = "_idris_memmove"
428−
429− cleanReserved x = x
430−
431−mkName :: Name -> CodeGeneration J.Name
432−mkName (NS name nss) = (\ n ns -> J.Name (n:ns))
433− <$> mkIdentifier name
434− <*> mapM (mkIdentifier . UN) nss
435−mkName n = J.Name . (:[]) <$> mkIdentifier n
436−
437−voidType :: ClassType
438−voidType = ClassType [(Ident "Void", [])]
439−
440−objectType :: ClassType
441−objectType = ClassType [(Ident "Object", [])]
442−
443−objectArrayType :: Language.Java.Syntax.Type
444−objectArrayType = RefType . ArrayType . RefType . ClassRefType $ objectType
445−
446−idrisClosureType :: ClassType
447−idrisClosureType = ClassType [(Ident "Closure", [])]
448−
449−idrisTailCallClosureType :: ClassType
450−idrisTailCallClosureType = ClassType [(Ident "TailCallClosure", [])]
451−
452−idrisObjectType :: ClassType
453−idrisObjectType = ClassType [(Ident "IdrisObject", [])]
454−
455−contextArray :: LVar -> Exp
456−contextArray (Loc _) = ExpName $ J.Name [Ident "context"]
457−contextArray (Glob _) = ExpName $ J.Name [Ident "globalContext"]
458−
459−charType :: ClassType
460−charType = ClassType [(Ident "Character", [])]
461−
462−byteType :: ClassType
463−byteType = ClassType [(Ident "Byte", [])]
464−
465−shortType :: ClassType
466−shortType = ClassType [(Ident "Short", [])]
467−
468−integerType :: ClassType
469−integerType = ClassType [(Ident "Integer", [])]
470−
471−longType :: ClassType
472−longType = ClassType [(Ident "Long", [])]
473−
474−nextIntTy :: IntTy -> IntTy
475−nextIntTy (ITFixed IT8) = (ITFixed IT16)
476−nextIntTy (ITFixed IT16) = (ITFixed IT32)
477−nextIntTy (ITFixed IT32) = (ITFixed IT64)
478−nextIntTy (ITFixed IT64) = (ITFixed IT64)
479−nextIntTy ITNative = (ITFixed IT64)
480−nextIntTy ITChar = (ITFixed IT64)
481−
482−intTyToIdent :: IntTy -> Ident
483−intTyToIdent (ITFixed IT8) = Ident "Byte"
484−intTyToIdent (ITFixed IT16) = Ident "Short"
485−intTyToIdent (ITFixed IT32) = Ident "Integer"
486−intTyToIdent (ITFixed IT64) = Ident "Long"
487−intTyToIdent ITNative = Ident "Integer"
488−intTyToIdent ITBig = Ident "BigInteger"
489−intTyToIdent ITChar = Ident "Integer"
490−
491−intTyToClass :: IntTy -> ClassType
492−intTyToClass ty = ClassType [(intTyToIdent ty, [])]
493−
494−intTyToMethod :: IntTy -> String
495−intTyToMethod (ITFixed IT8) = "byteValue"
496−intTyToMethod (ITFixed IT16) = "shortValue"
497−intTyToMethod (ITFixed IT32) = "intValue"
498−intTyToMethod (ITFixed IT64) = "longValue"
499−intTyToMethod ITNative = "intValue"
500−intTyToMethod ITChar = "intValue"
501−
502−intTyToPrimTy :: IntTy -> PrimType
503−intTyToPrimTy (ITFixed IT8) = ByteT
504−intTyToPrimTy (ITFixed IT16) = ShortT
505−intTyToPrimTy (ITFixed IT32) = IntT
506−intTyToPrimTy (ITFixed IT64) = LongT
507−intTyToPrimTy ITNative = IntT
508−intTyToPrimTy ITChar = IntT
509−
510−bigIntegerType :: ClassType
511−bigIntegerType = ClassType [(Ident "BigInteger", [])]
512−
513−doubleType :: ClassType
514−doubleType = ClassType [(Ident "Double", [])]
515−
516−stringType :: ClassType
517−stringType = ClassType [(Ident "String", [])]
518−
519−stringArrayType :: Language.Java.Syntax.Type
520−stringArrayType = RefType . ArrayType . RefType . ClassRefType $ stringType
521−
522−exceptionType :: ClassType
523−exceptionType = ClassType [(Ident "Throwable", [])]
524−
525−runtimeExceptionType :: ClassType
526−runtimeExceptionType = ClassType [(Ident "RuntimeException", [])]
527−
528−comparableType :: ClassType
529−comparableType = ClassType [(Ident "Comparable", [])]
530
384
531mkDecl :: (Name, SDecl) -> CodeGeneration Decl
385mkDecl :: (Name, SDecl) -> CodeGeneration Decl
532mkDecl ((NS n (ns:nss)), decl) =
386mkDecl ((NS n (ns:nss)), decl) =
387+ (\ name body ->
533− (\ name body -> MemberDecl $ MemberClassDecl $ ClassDecl [Public, Static] name [] Nothing [] body)
388+ MemberDecl $ MemberClassDecl $ ClassDecl [Public, Static] name [] Nothing [] body)
534− <$> mkIdentifier (UN ns)
389+ <$> mangle (UN ns)
535 <*> mkClassBody [] [(NS n nss, decl)]
390 <*> mkClassBody [] [(NS n nss, decl)]
536−mkDecl (_, SFun name params stackSize body) =
391+mkDecl (_, SFun name params stackSize body) = do
537− (\ name params paramNames methodBody ->
392+ (Ident methodName) <- mangle name
538− MemberDecl $ MethodDecl [Public, Static]
393+ methodParams <- mapM mkFormalParam params
539− []
394+ paramNames <- mapM mangle params
540− (Just . RefType $ ClassRefType objectType)
395+ pushParams paramNames
541− name
396+ methodBody <- mkExp addReturn body
542− params
397+ popScope
543− []
398+ return $
544− (MethodBody . Just $ Block
399+ simpleMethod [Public, Static] (Just objectType) methodName methodParams
545− [ LocalVars [Final]
546− objectArrayType
547− [ VarDecl (VarDeclArray . VarId $ Ident "context")
548− (Just . InitArray . ArrayInit $
549− paramNames
550− ++ replicate stackSize (InitExp . Lit $ Null))
551− ]
552− , BlockStmt . Return $ Just methodBody
400+ (Block methodBody)
553− ]
554− )
555− )
556− <$> mkIdentifier name
557− <*> mapM mkFormalParam params
558− <*> mapM (\ p -> (InitExp . ExpName) <$> mkName p) params
559− <*> mkExp body
560−
561−
562−mkClosure :: [Name] -> Int -> SExp -> CodeGeneration Exp
563−mkClosure params stackSize body =
564− (\ paramArray body ->
565− InstanceCreation []
566− idrisClosureType
567− [paramArray]
568− (Just $ ClassBody [body])
569− )
570− <$> mkStackInit params stackSize
571− <*> mkClosureCall body
572
401
573mkFormalParam :: Name -> CodeGeneration FormalParam
402mkFormalParam :: Name -> CodeGeneration FormalParam
574mkFormalParam name =
403mkFormalParam name =
575− (\ name -> FormalParam [Final] (RefType . ClassRefType $ objectType) False (VarId name))
404+ (\ name -> FormalParam [Final] objectType False (VarId name))
576− <$> mkIdentifier name
405+ <$> mangle name
577−
406+
578−mkClosureCall :: SExp -> CodeGeneration Decl
407+-----------------------------------------------------------------------
579−mkClosureCall body =
408+-- Expressions
580− (\ body -> MemberDecl $ MethodDecl [Public] [] (Just . RefType $ ClassRefType objectType) (Ident "call") [] [] body)
409+
581− <$> mkMethodBody body
410+-- | Compile a simple expression and use the given continuation to postprocess
582−
411+-- the resulting value.
583−mkMethodBody :: SExp -> CodeGeneration MethodBody
412+mkExp :: BlockPostprocessor -> SExp -> CodeGeneration [BlockStmt]
584−mkMethodBody exp =
413+-- Variables
585− (\ exp -> MethodBody . Just . Block $ [BlockStmt . Return . Just $ exp])
414+mkExp pp (SV var) =
586− <$> mkExp exp
415+ (Nothing <>@! var) >>= ppExp pp
587−
416+
588−mkStackInit :: [Name] -> Int -> CodeGeneration Exp
417+-- Applications
589−mkStackInit params stackSize =
418+mkExp pp (SApp pushTail name args) =
590− (\ localVars -> ArrayCreateInit objectArrayType 0 . ArrayInit $
419+ mkApp pushTail name args >>= ppExp pp
591− (map (InitExp . ExpName) localVars)
420+
592− ++ (replicate (stackSize) (InitExp $ Lit Null)))
421+-- Bindings
593− <$> mapM mkName params
422+mkExp pp (SLet var newExp inExp) =
594−
423+ mkLet pp var newExp inExp
595−mkK :: Exp -> Exp -> Exp
424+mkExp pp (SUpdate var newExp) =
596−mkK result drop =
425+ mkUpdate pp var newExp
597− MethodInv $ MethodCall (J.Name [Ident "idris_K"]) [ result, drop ]
426+
598−
427+-- Objects
599−mkFlipK :: Exp -> Exp -> Exp
428+mkExp pp (SCon conId _ args) =
600−mkFlipK drop result =
429+ mkIdrisObject conId args >>= ppExp pp
601− MethodInv $ MethodCall (J.Name [Ident "idris_flipK"]) [ drop, result ]
430+
602−
431+-- Case expressions
603−mkLet :: LVar -> SExp -> SExp -> CodeGeneration Exp
432+mkExp pp (SCase var alts) = mkCase pp True var alts
604−mkLet (Loc pos) oldExp newExp =
433+mkExp pp (SChkCase var alts) = mkCase pp False var alts
605− (\ oldExp newExp ->
434+
606− mkFlipK ( Assign ( ArrayLhs $ ArrayIndex (ExpName $ J.Name [Ident "context"])
435+-- Projections
607− (Lit $ Int (toInteger pos)))
436+mkExp pp (SProj var i) =
608− EqualA
437+ mkProjection var i >>= ppExp pp
609− newExp
438+
610− )
439+-- Constants
611− oldExp
440+mkExp pp (SConst c) =
612− )
441+ ppExp pp $ mkConstant c
613− <$> mkExp oldExp
442+
614− <*> mkExp newExp
443+-- Foreign function calls
615−mkLet (Glob _) _ _ = T.lift $ Left "Cannot let bind to global variable"
444+mkExp pp (SForeign lang resTy text params) =
616−
445+ mkForeign pp lang resTy text params
617−reverseNameSpace :: J.Name -> J.Name
446+
618−reverseNameSpace (J.Name ids) =
447+-- Primitive functions
619− J.Name ((tail ids) ++ [head ids])
448+mkExp pp (SOp LFork [arg]) =
620−
449+ (mkThread arg) >>= ppExp pp
621−mkCase :: Bool -> LVar -> [SAlt] -> CodeGeneration Exp
450+mkExp pp (SOp LPar [arg]) =
622−mkCase checked var ((SConCase parentStackPos consIndex _ params branchExpression):cases) =
451+ (Nothing <>@! arg) >>= ppExp pp
623− mkConsCase checked
452+mkExp pp (SOp LNoOp args) =
624− var
453+ (Nothing <>@! (last args)) >>= ppExp pp
625− parentStackPos
454+mkExp pp (SOp op args) =
626− consIndex
455+ (mkPrimitiveFunction op args) >>= ppExp pp
627− params
456+
628− branchExpression
457+-- Empty expressions
629− (SCase var cases)
458+mkExp pp (SNothing) = ppExp pp $ Lit Null
630−mkCase checked var (c@(SConstCase constant branchExpression):cases) =
459+
631− (\ constant branchExpression alternative var->
460+-- Errors
632− Cond ( MethodInv $ PrimaryMethodCall (constant)
461+mkExp pp (SError err) = ppExp (throwRuntimeException pp) (jString err)
633− []
462+
634− (Ident "equals")
463+-----------------------------------------------------------------------
635− [var]
464+-- Variable access
636− )
465+
637− branchExpression
638− alternative
639− )
640− <$> mkExp (SConst constant)
641− <*> mkExp branchExpression
642− <*> mkCase checked var cases
643− <*> mkVarAccess Nothing var
644−mkCase checked var (SDefaultCase exp:cases) = mkExp exp
645−mkCase checked _ [] = mkExp (SError "Non-exhaustive pattern")
646−
647−mkConsCase :: Bool -> LVar -> Int -> Int -> [Name] -> SExp -> SExp -> CodeGeneration Exp
466+(<>@!) :: Maybe J.Type -> LVar -> CodeGeneration Exp
648−mkConsCase checked
467+(<>@!) Nothing var =
649− toDeconstruct
468+ either ArrayAccess (\ n -> ExpName $ J.Name [n]) <$> varPos var
650− parentStackStart
469+(<>@!) (Just castTo) var =
651− consIndex
470+ (castTo <>) <$> (Nothing <>@! var)
652− params
471+
653− branchExpression
472+-----------------------------------------------------------------------
654− alternative =
473+-- Application (wrap method calls in tail call closures)
655− (\ caseBinding alternative var varCasted->
474+
656− Cond (BinOp (InstanceOf (var)
657− (ClassRefType idrisObjectType)
658− )
659− CAnd
660− ( BinOp
661− ( MethodInv $ PrimaryMethodCall (varCasted)
662− []
663− (Ident "getConstructorId")
664− []
665− )
666− Equal
667− (Lit $ Int (toInteger consIndex))
668− )
669− )
670− (caseBinding)
671− alternative
672− )
673− <$> mkCaseBinding checked toDeconstruct parentStackStart params branchExpression
674− <*> mkExp alternative
675− <*> mkVarAccess (Nothing) toDeconstruct
676− <*> mkVarAccess (Just idrisObjectType) toDeconstruct
677−
678−
679−mkCaseBinding :: Bool -> LVar -> Int -> [Name] -> SExp -> CodeGeneration Exp
475+mkApp :: Bool -> Name -> [LVar] -> CodeGeneration Exp
680−mkCaseBinding True var parentStackStart params branchExpression =
476+mkApp False name args =
681− (\ branchExpression deconstruction ->
477+ (\ methodName params ->
682− mkFlipK (MethodInv $ MethodCall (J.Name [Ident "idris_assignStack"])
478+ (idrisClosureType ~> "unwrapTailCall") [call methodName params]
683− ( (ExpName $ J.Name [Ident "context"])
684− : (Lit $ Int (toInteger parentStackStart))
685− : deconstruction
686− ))
687− (branchExpression)
688 )
479 )
689− <$> mkExp branchExpression
480+ <$> mangleFull name
690− <*> mkCaseBindingDeconstruction var params
481+ <*> mapM (Nothing <>@!) args
691−mkCaseBinding False var parentStackStart params branchExpression =
482+mkApp True name args = mkMethodCallClosure name args
692− (\ bindingMethod deconstruction ->
483+
693− MethodInv $ PrimaryMethodCall
484+mkMethodCallClosure :: Name -> [LVar] -> CodeGeneration Exp
694− ( MethodInv $ PrimaryMethodCall (InstanceCreation []
485+mkMethodCallClosure name args =
695− (ClassType [(Ident "Object", [])])
486+ (\ name args -> closure (call name args))
696− []
487+ <$> mangleFull name
697− (Just $ ClassBody [MemberDecl $ bindingMethod])
488+ <*> mapM (Nothing <>@!) args
489+
490+-----------------------------------------------------------------------
491+-- Updates (change context array) and Let bindings (Update, execute)
492+
493+mkUpdate :: BlockPostprocessor -> LVar -> SExp -> CodeGeneration [BlockStmt]
494+mkUpdate pp var exp =
495+ mkExp
496+ ( pp
497+ { ppInnerBlock =
498+ (\ blk rhs -> do
499+ pos <- setVariable var
500+ vExp <- Nothing <>@! var
501+ ppInnerBlock pp (blk ++ [pos @:= rhs]) vExp
698− )
502+ )
699− []
503+ }
700− (Ident "apply")
504+ ) exp
701− ( contextArray (Loc undefined) : deconstruction )
505+
702− )
506+mkLet :: BlockPostprocessor -> LVar -> SExp -> SExp -> CodeGeneration [BlockStmt]
703− []
507+mkLet pp var@(Loc pos) newExp inExp =
704− (Ident "call")
508+ mkUpdate (pp { ppInnerBlock =
705− []
509+ (\ blk _ -> do
510+ inBlk <- mkExp pp inExp
511+ return (blk ++ inBlk)
512+ )
513+ }
514+ ) var newExp
515+mkLet _ (Glob _) _ _ = T.lift $ Left "Cannot let bind to global variable"
516+
517+-----------------------------------------------------------------------
518+-- Object creation
519+
520+mkIdrisObject :: Int -> [LVar] -> CodeGeneration Exp
521+mkIdrisObject conId args =
522+ (\ args ->
523+ InstanceCreation [] (toClassType idrisObjectType) ((jInt conId):args) Nothing
706 )
524 )
707− <$> mkCaseBindingMethod parentStackStart params branchExpression
525+ <$> mapM (Nothing <>@!) args
708− <*> mkCaseBindingDeconstruction var params
526+
709−
527+-----------------------------------------------------------------------
710−mkCaseBindingDeconstruction :: LVar -> [Name] -> CodeGeneration [Exp]
528+-- Case expressions
711−mkCaseBindingDeconstruction var members =
529+
712− mapM (mkProjection var) ([0..(length members - 1)])
530+mkCase :: BlockPostprocessor -> Bool -> LVar -> [SAlt] -> CodeGeneration [BlockStmt]
713−
531+mkCase pp checked var cases
714−mkCaseBindingMethod :: Int -> [Name] -> SExp -> CodeGeneration MemberDecl
532+ | isDefaultOnlyCase cases = mkDefaultMatch pp cases
715−mkCaseBindingMethod parentStackStart params branchExpression =
533+ | isConstCase cases = do
716− (\ formalParams caseBindingStack branchExpression ->
534+ ifte <- mkConstMatch (ignoreOuter pp) (\ pp -> mkDefaultMatch pp cases) var cases
717− MethodDecl [Final, Public]
535+ ppOuterBlock pp [BlockStmt ifte]
718− []
536+ | otherwise = do
719− (Just . RefType $ ClassRefType idrisClosureType)
537+ switchExp <- mkGetConstructorId checked var
720− (Ident "apply")
538+ matchBlocks <- mkConsMatch (ignoreOuter pp) (\ pp -> mkDefaultMatch pp cases) var cases
721− (mkContextParam:formalParams)
539+ ppOuterBlock pp [BlockStmt $ Switch switchExp matchBlocks]
722− []
540+
723− (MethodBody . Just . Block $
541+isConstCase :: [SAlt] -> Bool
724− caseBindingStack ++
542+isConstCase ((SConstCase _ _):_) = True
725− [BlockStmt . Return $ Just branchExpression]))
543+isConstCase ((SDefaultCase _):cases) = isConstCase cases
726− <$> mapM mkFormalParam params
544+isConstCase _ = False
727− <*> mkBindingStack False parentStackStart params
545+
728− <*> mkBindingClosure branchExpression
546+isDefaultOnlyCase :: [SAlt] -> Bool
729−
547+isDefaultOnlyCase [SDefaultCase _] = True
730−mkContextParam :: FormalParam
548+isDefaultOnlyCase [] = True
731−mkContextParam =
549+isDefaultOnlyCase _ = False
732− FormalParam [Final] (objectArrayType) False (VarId (Ident "context"))
550+
733−
551+mkDefaultMatch :: BlockPostprocessor -> [SAlt] -> CodeGeneration [BlockStmt]
552+mkDefaultMatch pp (x@(SDefaultCase branchExpression):_) =
553+ do pushScope
554+ stmt <- mkExp pp branchExpression
555+ popScope
556+ return stmt
557+mkDefaultMatch pp (x:xs) = mkDefaultMatch pp xs
558+mkDefaultMatch pp [] =
559+ ppExp (throwRuntimeException pp) (jString "Non-exhaustive pattern")
560+
561+mkMatchConstExp :: LVar -> Const -> CodeGeneration Exp
562+mkMatchConstExp var c
563+ | isPrimitive cty =
564+ (\ var -> (primFnType ~> opName (LEq undefined)) [var, jc] ~==~ jInt 1)
565+ <$> (Just cty <>@! var)
566+ | isArray cty =
567+ (\ var -> (arraysType ~> "equals") [var, jc])
568+ <$> (Just cty <>@! var)
569+ | isString cty =
570+ (\ var -> ((primFnType ~> opName (LStrEq)) [var, jc] ~==~ jInt 1))
571+ <$> (Just cty <>@! var)
572+ | otherwise =
573+ (\ var -> (var ~> "equals") [jc])
574+ <$> (Just cty <>@! var)
575+ where
576+ cty = constType c
577+ jc = mkConstant c
578+
579+mkConstMatch :: BlockPostprocessor ->
580+ (BlockPostprocessor -> CodeGeneration [BlockStmt]) ->
581+ LVar ->
582+ [SAlt] ->
583+ CodeGeneration Stmt
584+mkConstMatch pp getDefaultStmts var ((SConstCase constant branchExpression):cases) = do
585+ matchExp <- mkMatchConstExp var constant
586+ pushScope
587+ branchBlock <- mkExp pp branchExpression
588+ popScope
589+ otherBranches <- mkConstMatch pp getDefaultStmts var cases
590+ return
591+ $ IfThenElse matchExp (StmtBlock $ Block branchBlock) otherBranches
592+mkConstMatch pp getDefaultStmts var (c:cases) = mkConstMatch pp getDefaultStmts var cases
593+mkConstMatch pp getDefaultStmts _ [] = do
594+ defaultBlock <- getDefaultStmts pp
595+ return $ StmtBlock (Block defaultBlock)
596+
734−mkBindingClosure :: SExp -> CodeGeneration Exp
597+mkGetConstructorId :: Bool -> LVar -> CodeGeneration Exp
735−mkBindingClosure oldExp =
598+mkGetConstructorId True var =
736− (\ oldCall ->
599+ (\ var -> ((idrisObjectType <> var) ~> "getConstructorId") [])
737− InstanceCreation []
600+ <$> (Nothing <>@! var)
738− idrisClosureType
601+mkGetConstructorId False var =
739− [ ExpName $ J.Name [Ident "new_context"] ]
602+ (\ var match ->
740− (Just $ ClassBody [oldCall])
603+ Cond (InstanceOf var (toRefType idrisObjectType)) match (jInt (-1))
741 )
604 )
742− <$> mkClosureCall oldExp
605+ <$> (Nothing <>@! var)
743−
606+ <*> mkGetConstructorId True var
744−
607+
745−mkBindingStack :: Bool -> Int -> [Name] -> CodeGeneration [BlockStmt]
608+mkConsMatch :: BlockPostprocessor ->
746−mkBindingStack checked parentStackStart params =
609+ (BlockPostprocessor -> CodeGeneration [BlockStmt]) ->
747− (\ paramNames ->
610+ LVar ->
748− ( LocalVars [Final]
611+ [SAlt] ->
749− objectArrayType
612+ CodeGeneration [SwitchBlock]
750− [ VarDecl (VarDeclArray . VarId $ Ident "new_context")
613+mkConsMatch pp getDefaultStmts var ((SConCase parentStackPos consIndex _ params branchExpression):cases) = do
751− (Just . InitExp $ mkContextCopy checked parentStackStart params)
614+ pushScope
752− ])
615+ caseBranch <- mkCaseBinding pp var parentStackPos params branchExpression
753− : ( map (\ (param, pos) ->
616+ popScope
754− BlockStmt . ExpStmt $
617+ otherBranches <- mkConsMatch pp getDefaultStmts var cases
755− Assign (ArrayLhs $ ArrayIndex (ExpName $ J.Name [Ident "new_context"])
618+ return $
756− (Lit $ Int (toInteger pos)))
619+ (SwitchBlock (SwitchCase $ jInt consIndex) caseBranch):otherBranches
757− EqualA
620+mkConsMatch pp getDefaultStmts var (c:cases) = mkConsMatch pp getDefaultStmts var cases
758− (ExpName param)) $ zip paramNames [parentStackStart..]
621+mkConsMatch pp getDefaultStmts _ [] = do
759− )
622+ defaultBlock <- getDefaultStmts pp
760− )
623+ return $
761− <$> mapM mkName params
624+ [SwitchBlock Default defaultBlock]
762−
625+
763−mkContextCopy :: Bool -> Int -> [Name] -> Exp
626+mkCaseBinding :: BlockPostprocessor -> LVar -> Int -> [Name] -> SExp -> CodeGeneration [BlockStmt]
764−mkContextCopy True parentStackStart params =
627+mkCaseBinding pp var stackStart params branchExpression =
765− MethodInv $ PrimaryMethodCall (ExpName $ J.Name [Ident "context"])
628+ mkExp pp (toLetIn var stackStart params branchExpression)
766− []
629+ where
767− (Ident "clone")
630+ toLetIn :: LVar -> Int -> [Name] -> SExp -> SExp
768− []
631+ toLetIn var stackStart members start =
769−mkContextCopy False parentStackStart params =
632+ foldr
770− MethodInv $ TypeMethodCall (J.Name [Ident "Arrays"])
633+ (\ pos inExp -> SLet (Loc (stackStart + pos)) (SProj var pos) inExp)
771− []
634+ start
772− (Ident "copyOf")
635+ [0.. (length members - 1)]
773− [ ExpName $ J.Name [Ident "context"]
636+
774− , MethodInv
637+-----------------------------------------------------------------------
775− $ TypeMethodCall (J.Name [Ident "Math"])
638+-- Projection (retrieve the n-th field of an object)
776− []
777− (Ident "max")
778− [ FieldAccess $ PrimaryFieldAccess (ExpName $ J.Name [Ident "context"])
779− (Ident "length")
780− , Lit . Int $ toInteger (parentStackStart + length params)
781− ]
782− ]
783
639
784mkProjection :: LVar -> Int -> CodeGeneration Exp
640mkProjection :: LVar -> Int -> CodeGeneration Exp
785mkProjection var memberNr =
641mkProjection var memberNr =
786− (\ var -> ArrayAccess $ ArrayIndex ( MethodInv $ PrimaryMethodCall
642+ (\ var -> ArrayAccess $ ((var ~> "getData") []) @! memberNr)
787− (var)
643+ <$> (Just idrisObjectType <>@! var)
788− []
644+
789− (Ident "getData")
645+-----------------------------------------------------------------------
790− []
646+-- Constants
791− )
647+
792− (Lit $ Int (toInteger memberNr))
648+mkConstantArray :: (V.Unbox a) => J.Type -> (a -> Const) -> V.Vector a -> Exp
793− )
649+mkConstantArray cty elemToConst elems =
794− <$> mkVarAccess (Just idrisObjectType) var
650+ ArrayCreateInit
795−
651+ cty
796−type ClassName = String
652+ 0
797−
653+ (ArrayInit . map (InitExp . mkConstant . elemToConst) $ V.toList elems)
798−mkPrimitive :: ClassName -> Literal -> Exp
654+
799−mkPrimitive className value =
655+mkConstant :: Const -> Exp
800− MethodInv $ TypeMethodCall (J.Name [Ident className])
656+mkConstant c@(I x) = constType c <> (Lit . Word $ toInteger x)
801− []
657+mkConstant c@(BI x) = bigInteger (show x)
802− (Ident "valueOf")
658+mkConstant c@(Fl x) = constType c <> (Lit . Double $ x)
803− [Lit $ value]
659+mkConstant c@(Ch x) = constType c <> (Lit . Char $ x)
804−
660+mkConstant c@(Str x) = constType c <> (Lit . String $ x)
805−mkClass :: ClassType -> Exp
661+mkConstant c@(B8 x) = constType c <> (Lit . Word $ toInteger x)
806−mkClass classType =
662+mkConstant c@(B16 x) = constType c <> (Lit . Word $ toInteger x)
807− ClassLit . Just . RefType .ClassRefType $ classType
663+mkConstant c@(B32 x) = constType c <> (Lit . Word $ toInteger x)
808−
664+mkConstant c@(B64 x) = (bigInteger (show c) ~> "longValue") []
809−mkBinOpExp :: ClassType -> Op -> [LVar] -> CodeGeneration Exp
665+mkConstant c@(B8V x) = mkConstantArray (constType c) B8 x
810−mkBinOpExp castTo op (var:vars) = do
666+mkConstant c@(B16V x) = mkConstantArray (constType c) B16 x
811− start <- mkVarAccess (Just castTo) var
667+mkConstant c@(B32V x) = mkConstantArray (constType c) B32 x
812− foldM (\ exp var -> BinOp exp op <$> mkVarAccess (Just castTo) var) start vars
668+mkConstant c@(B64V x) = mkConstantArray (constType c) B64 x
813−
669+mkConstant c@(AType x) = ClassLit (Just $ box (constType c))
814−mkBinOpExpTrans :: (Exp -> Exp) -> (Exp -> Exp) -> ClassType -> Op -> [LVar] -> CodeGeneration Exp
670+mkConstant c@(StrType ) = ClassLit (Just $ stringType)
815−mkBinOpExpTrans opTransformation resultTransformation castTo op (var:vars) = do
671+mkConstant c@(PtrType ) = ClassLit (Just $ objectType)
816− start <- (mkVarAccess (Just castTo) var)
672+mkConstant c@(VoidType ) = ClassLit (Just $ voidType)
817− foldM (\ exp var -> resultTransformation
673+mkConstant c@(Forgot ) = ClassLit (Just $ objectType)
818− . BinOp (opTransformation exp) op
674+
819− . opTransformation
675+-----------------------------------------------------------------------
820− <$> mkVarAccess (Just castTo) var)
676+-- Foreign function calls
821− start
677+
822− vars
678+mkForeign :: BlockPostprocessor -> FLang -> FType -> String -> [(FType, LVar)] -> CodeGeneration [BlockStmt]
823−
679+mkForeign pp (LANG_C) resTy text params = mkForeign pp (LANG_JAVA FStatic) resTy text params
824−mkBinOpExpConv :: String -> PrimType -> ClassType -> Op -> [LVar] -> CodeGeneration Exp
680+mkForeign pp (LANG_JAVA callType) resTy text params
825−mkBinOpExpConv fromMethodName toType fromType@(ClassType [(cls@(Ident _), [])]) op args =
681+ | callType <- FStatic = do
826− mkBinOpExpTrans (\ exp -> MethodInv $ TypeMethodCall (J.Name [cls])
682+ method <- liftParsed (parser name text)
827− []
683+ args <- foreignVarAccess params
828− (Ident fromMethodName)
684+ wrapReturn resTy (call method args)
829− [exp]
685+ | callType <- FObject = do
830− )
686+ method <- liftParsed (parser ident text)
831− (\ exp -> MethodInv $ TypeMethodCall (J.Name [cls])
687+ (tgt:args) <- foreignVarAccess params
832− []
688+ wrapReturn resTy ((tgt ~> (show $ pretty method)) args)
833− (Ident "valueOf")
689+ | callType <- FConstructor = do
834− [Cast (PrimType $ toType) exp]
690+ clsTy <- liftParsed (parser classType text)
835− )
691+ args <- foreignVarAccess params
836− fromType
692+ wrapReturn resTy (InstanceCreation [] clsTy args Nothing)
837− op
693+ where
838− args
694+ foreignVarAccess args =
839−
695+ mapM (\ (fty, var) -> (foreignType fty <>@! var)) args
840−mkLogicalBinOpExp :: ClassType -> Op -> [LVar] -> CodeGeneration Exp
841−mkLogicalBinOpExp castTo op (var:vars) = do
842− start <- mkVarAccess (Just castTo) var
843− foldM (\ exp var -> mkBoolToNumber castTo . BinOp exp op <$> mkVarAccess (Just castTo) var)
844− start
845− vars
846−
847−mkMethodOpChain1 :: (Exp -> Exp) -> ClassType -> String -> [LVar] -> CodeGeneration Exp
848−mkMethodOpChain1 = mkMethodOpChain id
849−
850−mkMethodOpChain :: (Exp -> Exp) -> (Exp -> Exp) -> ClassType -> String -> [LVar] -> CodeGeneration Exp
851−mkMethodOpChain initialTransformation resultTransformation castTo method (arg:args) = do
852− start <- initialTransformation <$> mkVarAccess (Just $ castTo) arg
853− foldM (\ exp arg' ->
854− resultTransformation
855− . MethodInv
856− . PrimaryMethodCall exp [] (Ident method)
857− . (:[])
858− <$> mkVarAccess (Just $ castTo) arg'
859− )
860− start
861− args
862−
863−mkBoolToNumber :: ClassType -> Exp -> Exp
864−mkBoolToNumber (ClassType [(Ident name, [])]) boolExp =
865− Cond boolExp (mkPrimitive name (Int 1)) (mkPrimitive name (Int 0))
866−
867−mkZeroExt :: String -> Int -> ClassType -> ClassType -> LVar -> CodeGeneration Exp
868−mkZeroExt toMethod bits fromType toType@(ClassType [(toTypeName, [])]) var = do
869− (\ var sext ->
870− MethodInv $ TypeMethodCall (J.Name [toTypeName])
871− []
872− (Ident "valueOf")
873− [ Cond ( BinOp (var)
874− LThan
875− (Lit $ Int 0)
876− )
877− ( BinOp (Lit $ Int (2^bits))
878− Add
879− (sext)
880− )
881− sext
882− ]
883− )
884− <$> mkVarAccess (Just $ fromType) var
885− <*> mkSignedExt' toMethod fromType var
886−
887−mkSignedExt :: String -> ClassType -> ClassType -> LVar -> CodeGeneration Exp
888−mkSignedExt toMethod fromType (ClassType [(toTypeName, [])]) var =
889− (\ sext -> MethodInv $ TypeMethodCall (J.Name [toTypeName])
890− []
891− (Ident "valueOf")
892− [ sext ]
893− )
894− <$> mkSignedExt' toMethod fromType var
895−
896−mkSignedExt' :: String -> ClassType -> LVar -> CodeGeneration Exp
897−mkSignedExt' toMethod fromType var =
898− (\ var -> MethodInv $ PrimaryMethodCall (var)
899− []
900− (Ident toMethod)
901− []
902− )
903− <$> mkVarAccess (Just $ fromType) var
904−
905−data SPartialOrder
906− = SLt
907− | SLe
908− | SEq
909− | SGe
910− | SGt
911−
912−mkPartialOrder :: SPartialOrder -> Exp -> Exp
913−mkPartialOrder SLt x = (BinOp (Lit $ Int (-1)) Equal x)
914−mkPartialOrder SLe x =
915− BinOp (BinOp (Lit $ Int (-1)) Equal x)
916− COr
917− (BinOp (Lit $ Int 0) Equal x)
918−mkPartialOrder SEq x = BinOp (Lit $ Int 0) Equal x
919−mkPartialOrder SGe x =
920− BinOp (BinOp (Lit $ Int 1) Equal x)
921− COr
922− (BinOp (Lit $ Int 0) Equal x)
923−mkPartialOrder SGt x = (BinOp (Lit $ Int 1) Equal x)
924−
925−varPos :: LVar -> CodeGeneration Integer
926−varPos (Loc i) = return (toInteger i)
927−varPos (Glob name) = do
928− positions <- globalVariablePositions <$> get
929− case lookup name positions of
930− (Just pos) -> return pos
931− Nothing -> T.lift . Left $ "Invalid global variable id: " ++ show name
932−
933−mkVarAccess :: Maybe ClassType -> LVar -> CodeGeneration Exp
934−mkVarAccess Nothing var =
935− (\ pos -> ArrayAccess $ ArrayIndex (contextArray var) (Lit $ Int pos))
936− <$> varPos var
937−mkVarAccess (Just castTo) var =
938− Cast (RefType . ClassRefType $ castTo) <$> (mkVarAccess Nothing var)
939−
940−mkPrimitiveCast :: ClassType -> ClassType -> LVar -> CodeGeneration Exp
941−mkPrimitiveCast fromType (ClassType [(toType, [])]) var =
942− (\ var ->
943− MethodInv $ TypeMethodCall (J.Name [toType])
944− []
945− (Ident "valueOf")
946− [var]
947− )
948− <$> mkVarAccess (Just fromType) var
949−
950−mkToString :: ClassType -> LVar -> CodeGeneration Exp
951−mkToString castTo var =
952− (\ var -> MethodInv $ PrimaryMethodCall (var)
953− []
954− (Ident "toString")
955− []
956− )
957− <$> mkVarAccess (Just castTo) var
958−data Std = In | Out | Err
959−
960−instance Show Std where
961− show In = "in"
962− show Out = "out"
963− show Err = "err"
964−
965−mkSystemStd :: Std -> Exp
966−mkSystemStd std = FieldAccess $ PrimaryFieldAccess (ExpName $ J.Name [Ident "System"]) (Ident $ show std)
967−
968−mkSystemOutPrint :: Exp -> Exp
969−mkSystemOutPrint value =
970− MethodInv $ PrimaryMethodCall (mkSystemStd Out)
971− []
972− (Ident "print")
973− [value]
974−
975−mkMathFun :: String -> LVar -> CodeGeneration Exp
976−mkMathFun funName var =
977− (\ var -> MethodInv $ TypeMethodCall (J.Name [Ident "Double"])
978− []
979− (Ident "valueOf")
980− [ MethodInv $ TypeMethodCall (J.Name [Ident "Math"])
981− []
982− (Ident funName)
983− [var]
984− ]
985− )
986− <$> mkVarAccess (Just doubleType) var
987−
988−mkStringAtIndex :: LVar -> Exp -> CodeGeneration Exp
989−mkStringAtIndex var indexExp =
990− (\ var -> MethodInv $ TypeMethodCall (J.Name [Ident "Integer"])
991− []
992− (Ident "valueOf")
993− [ MethodInv $ PrimaryMethodCall (var)
994− []
995− (Ident "charAt")
996− [indexExp]
997− ]
998− )
999− <$> mkVarAccess (Just stringType) var
1000−
1001−mkForeignType :: FType -> Maybe ClassType
1002−mkForeignType (FArith (ATInt ity)) = return (intTyToClass ity)
1003−mkForeignType (FArith ATFloat) = return doubleType
1004−mkForeignType FString = return stringType
1005−mkForeignType FPtr = return objectType
1006−mkForeignType FAny = return objectType
1007−mkForeignType FUnit = Nothing
1008−
1009−mkForeignVarAccess :: FType -> LVar -> CodeGeneration Exp
1010−mkForeignVarAccess (FArith (ATInt ty)) var =
1011− (\ var -> MethodInv $ PrimaryMethodCall var
1012− []
1013− (Ident (intTyToMethod ty))
1014− []
1015− )
1016− <$> mkVarAccess (Just $ intTyToClass ty) var
1017−-- mkForeignVarAccess (FArith (ATInt ITChar)) var = Cast (PrimType CharT) <$> mkForeignVarAccess (FArith (ATInt (ITFixed IT32))) var
1018−mkForeignVarAccess (FArith ATFloat) var =
1019− (\ var -> MethodInv $ PrimaryMethodCall (var)
1020− []
1021− (Ident "doubleValue")
1022− []
1023− )
1024− <$> mkVarAccess (Just doubleType) var
1025−mkForeignVarAccess otherType var = mkVarAccess (mkForeignType otherType) var
1026−
1027−mkFromForeignType :: FType -> Exp -> Exp
1028−{-mkFromForeignType (FArith (ATInt ty)) from =
1029− MethodInv $ TypeMethodCall (J.Name [intTyToIdent ty])
1030− []
1031− (Ident "valueOf")
1032− [from] -}
1033−mkFromForeignType (FArith (ATInt ITChar)) from = mkFromForeignType (FArith (ATInt (ITFixed IT32))) from
1034−mkFromForeignType (FArith ATFloat) from =
1035− MethodInv $ TypeMethodCall (J.Name [Ident "Double"])
1036− []
1037− (Ident "valueOf")
1038− [from]
1039−mkFromForeignType _ from = from
1040−
1041−mkForeignInvoke :: FType -> String -> [(FType, LVar)] -> CodeGeneration Exp
1042−mkForeignInvoke fType method args =
1043− (\ foreignInvokeMeth ->
1044− MethodInv $ PrimaryMethodCall (InstanceCreation []
1045− objectType
1046− []
1047− (Just $ ClassBody [ MemberDecl $ foreignInvokeMeth ])
1048− )
1049− []
1050− (Ident "foreignInvoke")
1051− []
1052− )
1053− <$> mkForeignInvokeMethod fType method args
1054−
1055−
1056−mkForeignInvokeMethod :: FType -> String -> [(FType, LVar)] -> CodeGeneration MemberDecl
1057−mkForeignInvokeMethod fType method args =
1058− (\ tryBlock ->
1059− MethodDecl [Public, Final]
1060− []
1061− (Just . RefType $ ClassRefType objectType)
1062− (Ident "foreignInvoke")
1063− []
1064− []
1065− (MethodBody . Just $ Block
1066− [ BlockStmt
1067− $ Try tryBlock
1068− [ Catch (FormalParam []
1069− (RefType $ ClassRefType exceptionType)
1070− False
1071− (VarId $ Ident "ex")
1072− )
1073− (Block [ BlockStmt
1074− . Throw
1075− $ InstanceCreation []
1076− runtimeExceptionType
1077− [ExpName $ J.Name [Ident "ex"]]
1078− Nothing
1079− ]
1080− )
1081− ]
1082− Nothing
1083− ]
1084− )
1085− )
1086− <$> mkForeignInvokeTryBlock fType method args
1087
696
697+ pp' = rethrowAsRuntimeException pp
1088
698
1089−mkForeignInvokeTryBlock :: FType -> String -> [(FType, LVar)] -> CodeGeneration Block
699+ wrapReturn FUnit exp =
1090−mkForeignInvokeTryBlock FUnit method args =
700+ ((ppInnerBlock pp') [BlockStmt $ ExpStmt exp] (Lit Null)) >>= ppOuterBlock pp'
1091− (\ method args -> Block [ BlockStmt . ExpStmt . MethodInv $ MethodCall method args
701+ wrapReturn _ exp =
1092− , BlockStmt $ Return (Just $ Lit Null)
702+ ((ppInnerBlock pp') [] exp) >>= ppOuterBlock pp'
1093− ]
703+
1094− )
704+-----------------------------------------------------------------------
1095− <$> ( T.lift $ left (\ err -> "Error parsing name \"" ++ method ++ "\" :" ++ (show err))
705+-- Primitive functions
1096− (parser name method)
706+
1097− )
707+mkPrimitiveFunction :: PrimFn -> [LVar] -> CodeGeneration Exp
1098− <*> mapM (uncurry mkForeignVarAccess) args
708+mkPrimitiveFunction op args =
1099−mkForeignInvokeTryBlock fType method args =
709+ (\ args -> (primFnType ~> opName op) args)
1100− (\ method args -> Block [ BlockStmt . Return
710+ <$> sequence (zipWith (\ a t -> (Just t) <>@! a) args (sourceTypes op))
1101− . Just
1102− . mkFromForeignType fType
1103− . MethodInv
1104− $ MethodCall method args
1105− ]
1106− )
1107− <$> ( T.lift $ left (\ err -> "Error parsing name \"" ++ method ++ "\" :" ++ (show err))
1108− (parser name method)
1109− )
1110− <*> mapM (uncurry mkForeignVarAccess) args
1111−
1112−mkMethodClosure :: Name -> [LVar] -> CodeGeneration Exp
1113−mkMethodClosure name args =
1114− (\ name args ->
1115− InstanceCreation []
1116− idrisClosureType
1117− [ (ExpName $ J.Name [Ident "context"]) ]
1118− ( Just
1119− $ ClassBody
1120− [ MemberDecl
1121− $ MethodDecl [Public, Final]
1122− []
1123− (Just . RefType $ ClassRefType objectType)
1124− (Ident "call")
1125− []
1126− []
1127− ( MethodBody
1128− . Just
1129− $ Block [ BlockStmt
1130− . Return
1131− . Just
1132− . MethodInv
1133− $ MethodCall (reverseNameSpace name)
1134− args
1135− ]
1136− )
1137− ]
1138− )
1139− )
1140− <$> mkName name
1141− <*> mapM (mkExp . SV) args
1142
711
1143mkThread :: LVar -> CodeGeneration Exp
712mkThread :: LVar -> CodeGeneration Exp
1144mkThread arg =
713mkThread arg =
1145− (\ eval ->
714+ (\ closure -> (closure ~> "fork") []) <$> mkMethodCallClosure (MN 0 "EVAL") [arg]
1146− MethodInv
1147− $ PrimaryMethodCall (InstanceCreation []
1148− (ClassType [(Ident "Thread", [])])
1149− [ eval ]
1150− ( Just
1151− $ ClassBody [ MemberDecl
1152− $ MethodDecl [Public, Final]
1153− []
1154− (Just . RefType $ ClassRefType objectType)
1155− (Ident "_start")
1156− []
1157− []
1158− ( MethodBody
1159− . Just
1160− $ Block [ BlockStmt
1161− . ExpStmt
1162− . MethodInv
1163− $ MethodCall (J.Name [Ident "start"])
1164− []
1165− , BlockStmt
1166− . Return
1167− . Just
1168− $ This
1169− ]
1170− )
1171− ]
1172− )
1173− )
1174− []
1175− (Ident "_start")
1176− []
1177− )
1178− <$> mkThreadBinding arg
1179−
1180−mkThreadBinding :: LVar -> CodeGeneration Exp
1181−mkThreadBinding var =
1182− (\ bindingMethod var ->
1183− MethodInv $ PrimaryMethodCall ( InstanceCreation []
1184− objectType
1185− []
1186− (Just $ ClassBody [MemberDecl $ bindingMethod])
1187− )
1188− []
1189− (Ident "apply")
1190− [ var ]
1191− )
1192− <$> mkThreadBindingMethod
1193− <*> mkVarAccess Nothing var
1194−
1195−
1196−mkThreadBindingMethod :: CodeGeneration MemberDecl
1197−mkThreadBindingMethod =
1198− (\ compute ->
1199− MethodDecl [Final, Public]
1200− []
1201− (Just . RefType $ ClassRefType idrisClosureType)
1202− (Ident "apply")
1203− [ FormalParam [Final] (RefType . ClassRefType $ objectType) False (VarId $ Ident "param") ]
1204− []
1205− (MethodBody . Just $ Block
1206− [ mkThreadBindingStack
1207− , BlockStmt . Return $ Just compute
1208− ]
1209− )
1210− )
1211− <$> mkBindingClosure (SUpdate (Loc 0) (SApp False (MN 0 "EVAL") [Loc 0]))
1212
715
1213
716
1214−mkThreadBindingStack :: BlockStmt
1215−mkThreadBindingStack =
1216− LocalVars [Final]
1217− objectArrayType
1218− [ VarDecl (VarDeclArray . VarId $ Ident "new_context")
1219− (Just . InitArray $ ArrayInit [InitExp . ExpName $ J.Name [Ident "param"]])
1220− ]
1221−
1222−
1223−mkExp :: SExp -> CodeGeneration Exp
1224−mkExp (SV var) = mkVarAccess Nothing var
1225−mkExp (SApp False name args) =
1226− (\ methClosure ->
1227− MethodInv $ PrimaryMethodCall ( InstanceCreation []
1228− idrisTailCallClosureType
1229− [ methClosure ]
1230− Nothing
1231− )
1232− []
1233− (Ident "call")
1234− []
1235− )
1236− <$> mkMethodClosure name args
1237−mkExp (SApp True name args) =
1238− (\ methClosure ->
1239− ( InstanceCreation []
1240− idrisTailCallClosureType
1241− [ methClosure ]
1242− Nothing
1243− )
1244− )
1245− <$> mkMethodClosure name args
1246−mkExp (SLet var new old) =
1247− mkLet var old new
1248−mkExp (SUpdate var exp) =
1249− (\ rhs varPos -> Assign (ArrayLhs $ ArrayIndex (contextArray var) (Lit $ Int varPos))
1250− EqualA
1251− rhs
1252− )
1253− <$> mkExp exp
1254− <*> varPos var
1255−mkExp (SCon conId name args) =
1256− (\ args -> InstanceCreation []
1257− idrisObjectType
1258− ((Lit $ Int (toInteger conId)):args)
1259− Nothing)
1260− <$> mapM (mkExp .SV) args
1261−mkExp (SCase var alts) = mkCase False var alts
1262−mkExp (SChkCase var alts) = mkCase True var alts
1263−mkExp (SProj var i) = mkProjection var i
1264−mkExp (SConst (I x)) =
1265− let x' :: Int32; x' = fromInteger (toInteger x) in
1266− return $ mkPrimitive "Integer" (Int (fromInteger (toInteger x')))
1267−mkExp (SConst (BI x)) =
1268− return $ InstanceCreation []
1269− (ClassType [(Ident "BigInteger", [])])
1270− [Lit $ String (show x)]
1271− Nothing
1272−mkExp (SConst (Fl x)) = return $ mkPrimitive "Double" (Double x)
1273−mkExp (SConst (Ch x)) = return $ mkPrimitive "Integer" (Char x)
1274−mkExp (SConst (Str x)) = return $ Lit $ String x
1275−mkExp (SConst (AType (ATInt ITNative))) = return $ mkClass integerType
1276−mkExp (SConst (AType (ATInt ITBig))) = return $ mkClass bigIntegerType
1277−mkExp (SConst (AType ATFloat)) = return $ mkClass doubleType
1278−mkExp (SConst (AType (ATInt ITChar))) = return $ mkClass charType
1279−mkExp (SConst StrType) = return $ mkClass stringType
1280−mkExp (SConst (B8 x)) = return $ mkPrimitive "Byte" (String (show x))
1281−mkExp (SConst (B16 x)) = return $ mkPrimitive "Short" (String (show x))
1282−mkExp (SConst (B32 x)) = return $ mkPrimitive "Integer" (Int (toInteger x))
1283−mkExp (SConst (B64 x)) = return $ mkPrimitive "Long" (String (show x))
1284−mkExp (SConst (AType (ATInt (ITFixed IT8)))) = return $ mkClass byteType
1285−mkExp (SConst (AType (ATInt (ITFixed IT16)))) = return $ mkClass shortType
1286−mkExp (SConst (AType (ATInt (ITFixed IT32)))) = return $ mkClass integerType
1287−mkExp (SConst (AType (ATInt (ITFixed IT64)))) = return $ mkClass longType
1288−mkExp (SConst (PtrType)) = return $ mkClass objectType
1289−mkExp (SConst (VoidType)) = return $ mkClass voidType
1290−mkExp (SConst (Forgot)) = return $ mkClass objectType
1291−mkExp (SForeign _ fType meth args) = mkForeignInvoke fType meth args
1292−mkExp (SOp (LPlus (ATInt ITNative)) args) = mkExp (SOp (LPlus (ATInt (ITFixed IT32))) args)
1293−mkExp (SOp (LMinus (ATInt ITNative)) args) = mkExp (SOp (LMinus (ATInt (ITFixed IT32))) args)
1294−mkExp (SOp (LTimes (ATInt ITNative)) args) = mkExp (SOp (LTimes (ATInt (ITFixed IT32))) args)
1295−mkExp (SOp (LSDiv (ATInt ITNative)) args) = mkExp (SOp (LSDiv (ATInt (ITFixed IT32))) args)
1296−mkExp (SOp (LSRem (ATInt ITNative)) args) = mkExp (SOp (LSRem (ATInt (ITFixed IT32))) args)
1297−mkExp (SOp (LAnd ITNative) args) = mkExp (SOp (LAnd (ITFixed IT32)) args)
1298−mkExp (SOp (LOr ITNative) args) = mkExp (SOp (LOr (ITFixed IT32)) args)
1299−mkExp (SOp (LXOr ITNative) args) = mkExp (SOp (LXOr (ITFixed IT32)) args)
1300−mkExp (SOp (LCompl ITNative) args) = mkExp (SOp (LCompl (ITFixed IT32)) args)
1301−mkExp (SOp (LSHL ITNative) args) = mkExp (SOp (LSHL (ITFixed IT32)) args)
1302−mkExp (SOp (LASHR ITNative) args) = mkExp (SOp (LASHR (ITFixed IT32)) args)
1303−mkExp (SOp (LEq (ATInt ITNative)) args) = mkExp (SOp (LEq (ATInt (ITFixed IT32))) args)
1304−mkExp (SOp (LLt (ATInt ITNative)) args) = mkExp (SOp (LLt (ATInt (ITFixed IT32))) args)
1305−mkExp (SOp (LLe (ATInt ITNative)) args) = mkExp (SOp (LLe (ATInt (ITFixed IT32))) args)
1306−mkExp (SOp (LGt (ATInt ITNative)) args) = mkExp (SOp (LGt (ATInt (ITFixed IT32))) args)
1307−mkExp (SOp (LGe (ATInt ITNative)) args) = mkExp (SOp (LGe (ATInt (ITFixed IT32))) args)
1308−mkExp (SOp (LPlus ATFloat) args) = mkBinOpExp doubleType Add args
1309−mkExp (SOp (LMinus ATFloat) args) = mkBinOpExp doubleType Sub args
1310−mkExp (SOp (LTimes ATFloat) args) = mkBinOpExp doubleType Mult args
1311−mkExp (SOp (LSDiv ATFloat) args) = mkBinOpExp doubleType Div args
1312−mkExp (SOp (LEq ATFloat) args) =
1313− mkMethodOpChain1 (mkBoolToNumber doubleType) doubleType "equals" args
1314−mkExp (SOp (LLt ATFloat) args) = mkLogicalBinOpExp integerType LThan args
1315−mkExp (SOp (LLe ATFloat) args) = mkLogicalBinOpExp integerType LThanE args
1316−mkExp (SOp (LGt ATFloat) args) = mkLogicalBinOpExp integerType GThan args
1317−mkExp (SOp (LGe ATFloat) args) = mkLogicalBinOpExp integerType GThanE args
1318−mkExp (SOp (LPlus (ATInt ITBig)) args) = mkMethodOpChain1 id bigIntegerType "add" args
1319−mkExp (SOp (LMinus (ATInt ITBig)) args) = mkMethodOpChain1 id bigIntegerType "subtract" args
1320−mkExp (SOp (LTimes (ATInt ITBig)) args) = mkMethodOpChain1 id bigIntegerType "multiply" args
1321−mkExp (SOp (LSDiv (ATInt ITBig)) args) = mkMethodOpChain1 id bigIntegerType "divide" args
1322−mkExp (SOp (LSRem (ATInt ITBig)) args) = mkMethodOpChain1 id bigIntegerType "mod" args
1323−mkExp (SOp (LEq (ATInt ITBig)) args) =
1324− mkMethodOpChain1 (mkBoolToNumber bigIntegerType) bigIntegerType "equals" args
1325−mkExp (SOp (LLt (ATInt ITBig)) args) =
1326− mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1327− . mkPartialOrder SLt
1328− )
1329− bigIntegerType
1330− "compareTo"
1331− args
1332−mkExp (SOp (LLe (ATInt ITBig)) args) =
1333− mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1334− . mkPartialOrder SLe
1335− )
1336− bigIntegerType
1337− "compareTo"
1338− args
1339−mkExp (SOp (LGt (ATInt ITBig)) args) =
1340− mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1341− . mkPartialOrder SGt
1342− )
1343− bigIntegerType
1344− "compareTo"
1345− args
1346−mkExp (SOp (LGe (ATInt ITBig)) args) =
1347− mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1348− . mkPartialOrder SGe
1349− )
1350− bigIntegerType
1351− "compareTo"
1352− args
1353−mkExp (SOp LStrConcat args) =
1354− mkMethodOpChain (\ exp -> InstanceCreation []
1355− (ClassType [(Ident "StringBuilder", [])])
1356− [exp]
1357− Nothing
1358− )
1359− (\ exp -> MethodInv $ PrimaryMethodCall exp [] (Ident "toString") [])
1360− stringType
1361− "append"
1362− args
1363−mkExp (SOp LStrLt args@[_, _]) =
1364− mkMethodOpChain1 ( mkBoolToNumber integerType
1365− . mkPartialOrder SLt
1366− )
1367− stringType
1368− "compareTo"
1369− args
1370−mkExp (SOp LStrEq args@[_, _]) =
1371− mkMethodOpChain1 ( mkBoolToNumber integerType)
1372− stringType
1373− "equals"
1374− args
1375−mkExp (SOp LStrLen [arg]) =
1376− (\ var -> MethodInv $ PrimaryMethodCall var [] (Ident "length") [])
1377− <$> mkVarAccess (Just stringType) arg
1378−mkExp (SOp (LIntFloat ity) [arg]) =
1379− mkPrimitiveCast (intTyToClass ity) doubleType arg
1380−mkExp (SOp (LFloatInt ity) [arg]) =
1381− mkSignedExt (intTyToMethod ity) doubleType (intTyToClass ity) arg
1382−mkExp (SOp (LIntStr ity) [arg]) =
1383− mkToString (intTyToClass ity) arg
1384−mkExp (SOp (LStrInt ity) [arg]) =
1385− mkPrimitiveCast stringType (intTyToClass ity) arg
1386−mkExp (SOp LFloatStr [arg]) =
1387− mkToString doubleType arg
1388−mkExp (SOp LStrFloat [arg]) =
1389− mkPrimitiveCast doubleType stringType arg
1390−mkExp (SOp (LSExt ITNative ITBig) [arg]) =
1391− mkPrimitiveCast integerType bigIntegerType arg
1392−mkExp (SOp (LTrunc ITBig ITNative) [arg]) =
1393− mkPrimitiveCast bigIntegerType integerType arg
1394−mkExp (SOp (LChInt ITNative) [arg]) =
1395− mkVarAccess (Just integerType) arg
1396−mkExp (SOp (LIntCh ITNative) [arg]) =
1397− mkVarAccess (Just integerType) arg
1398−mkExp (SOp LPrintNum [arg]) =
1399− mkSystemOutPrint <$> (mkVarAccess Nothing arg)
1400−mkExp (SOp LPrintStr [arg]) =
1401− mkSystemOutPrint <$> (mkVarAccess (Just stringType) arg)
1402−mkExp (SOp LReadStr [arg]) = mkExp (SForeign LANG_C FString "idris_readStr" [(FPtr, arg)])
1403−mkExp (SOp (LLt (ATInt ty)) args) = mkLogicalBinOpExp (intTyToClass ty) LThan args
1404−mkExp (SOp (LLe (ATInt ty)) args) = mkLogicalBinOpExp (intTyToClass ty) LThanE args
1405−mkExp (SOp (LEq (ATInt ty)) args) =
1406− mkMethodOpChain1 (mkBoolToNumber (intTyToClass ty)) (intTyToClass ty) "equals" args
1407−mkExp (SOp (LGt (ATInt ty)) args) = mkLogicalBinOpExp (intTyToClass ty) GThan args
1408−mkExp (SOp (LGe (ATInt ty)) args) = mkLogicalBinOpExp (intTyToClass ty) GThanE args
1409−mkExp (SOp (LPlus (ATInt ty)) args) = mkBinOpExp (intTyToClass ty) Add args
1410−mkExp (SOp (LMinus (ATInt ty)) args) = mkBinOpExp (intTyToClass ty) Sub args
1411−mkExp (SOp (LTimes (ATInt ty)) args) = mkBinOpExp (intTyToClass ty) Mult args
1412−mkExp (SOp (LUDiv (ITFixed IT64)) (arg:args)) = do
1413− (arg:args) <- mapM (mkVarAccess (Just longType)) (arg:args)
1414− return $ foldl (\ exp arg ->
1415− MethodInv $ PrimaryMethodCall
1416− ( MethodInv $ PrimaryMethodCall
1417− ( MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1418− []
1419− (Ident "valueOf")
1420− [ exp ]
1421− )
1422− []
1423− (Ident "divide")
1424− [ MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1425− []
1426− (Ident "valueOf")
1427− [ arg ]
1428− ]
1429− )
1430− []
1431− (Ident "longValue")
1432− []
1433− )
1434− arg
1435− args
1436−mkExp (SOp (LUDiv ty) args) =
1437− mkBinOpExpConv (intTyToMethod $ nextIntTy ty)
1438− (intTyToPrimTy $ nextIntTy ty)
1439− (intTyToClass ty)
1440− Div
1441− args
1442−mkExp (SOp (LSDiv (ATInt ty)) args) = mkBinOpExp (intTyToClass ty) Div args
1443−mkExp (SOp (LURem (ITFixed IT64)) (arg:args)) = do
1444− (arg:args) <- mapM (mkVarAccess (Just longType)) (arg:args)
1445− return $ foldl (\ exp arg ->
1446− MethodInv $ PrimaryMethodCall
1447− ( MethodInv $ PrimaryMethodCall
1448− ( MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1449− []
1450− (Ident "valueOf")
1451− [ exp ]
1452− )
1453− []
1454− (Ident "remainder")
1455− [ MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1456− []
1457− (Ident "valueOf")
1458− [ arg ]
1459− ]
1460− )
1461− []
1462− (Ident "longValue")
1463− []
1464− )
1465− arg
1466− args
1467−mkExp (SOp (LURem ty) args) =
1468− mkBinOpExpConv (intTyToMethod $ nextIntTy ty)
1469− (intTyToPrimTy $ nextIntTy ty)
1470− (intTyToClass ty)
1471− Rem
1472− args
1473−mkExp (SOp (LSRem (ATInt ty)) args) = mkBinOpExp (intTyToClass ty) Rem args
1474−mkExp (SOp (LSHL ty) args) = mkBinOpExp (intTyToClass ty) LShift args
1475−mkExp (SOp (LLSHR ty) args) = mkBinOpExp (intTyToClass ty) RRShift args
1476−mkExp (SOp (LASHR ty) args) = mkBinOpExp (intTyToClass ty) RShift args
1477−mkExp (SOp (LAnd ty) args) = mkBinOpExp (intTyToClass ty) And args
1478−mkExp (SOp (LOr ty) args) = mkBinOpExp (intTyToClass ty) Or args
1479−mkExp (SOp (LXOr ty) args) = mkBinOpExp (intTyToClass ty) Xor args
1480−mkExp (SOp (LCompl ty) [var]) = PreBitCompl <$> mkVarAccess (Just $ intTyToClass ty) var
1481−mkExp (SOp (LZExt from to) [var])
1482− | intTyWidth from < intTyWidth to
1483− = mkZeroExt (intTyToMethod to) (intTyWidth from) (intTyToClass from) (intTyToClass to) var
1484−mkExp (SOp (LSExt from to) [var])
1485− | intTyWidth from < intTyWidth to
1486− = mkSignedExt (intTyToMethod to) (intTyToClass from) (intTyToClass to) var
1487−mkExp (SOp (LTrunc from to) [var])
1488− | intTyWidth from > intTyWidth to
1489− = mkSignedExt (intTyToMethod to) (intTyToClass from) (intTyToClass to) var
1490−mkExp (SOp LFExp [arg]) = mkMathFun "exp" arg
1491−mkExp (SOp LFLog [arg]) = mkMathFun "log" arg
1492−mkExp (SOp LFSin [arg]) = mkMathFun "sin" arg
1493−mkExp (SOp LFCos [arg]) = mkMathFun "cos" arg
1494−mkExp (SOp LFTan [arg]) = mkMathFun "tan" arg
1495−mkExp (SOp LFASin [arg]) = mkMathFun "asin" arg
1496−mkExp (SOp LFACos [arg]) = mkMathFun "acos" arg
1497−mkExp (SOp LFATan [arg]) = mkMathFun "atan" arg
1498−mkExp (SOp LFSqrt [arg]) = mkMathFun "sqrt" arg
1499−mkExp (SOp LFFloor [arg]) = mkMathFun "floor" arg
1500−mkExp (SOp LFCeil [arg]) = mkMathFun "ceil" arg
1501−mkExp (SOp LStrHead [arg]) = mkStringAtIndex arg (Lit $ Int 0)
1502−mkExp (SOp LStrTail [arg]) =
1503− (\ var -> MethodInv $ PrimaryMethodCall (var)
1504− []
1505− (Ident "substring")
1506− [Lit $ Int 1]
1507− )
1508− <$> mkVarAccess (Just stringType) arg
1509−mkExp (SOp LStrCons [c, cs]) =
1510− (\ cVar csVar -> MethodInv $
1511− PrimaryMethodCall ( MethodInv $ PrimaryMethodCall (InstanceCreation []
1512− (ClassType [(Ident "StringBuilder", [])])
1513− [csVar]
1514− Nothing
1515− )
1516− []
1517− (Ident "insert")
1518− [ Lit $ Int 0,
1519− Cast (PrimType CharT)
1520− (MethodInv $ PrimaryMethodCall
1521− (cVar)
1522− []
1523− (Ident "intValue")
1524− []
1525− )
1526− ]
1527− )
1528− []
1529− (Ident "toString")
1530− []
1531− )
1532− <$> mkVarAccess (Just integerType) c
1533− <*> mkVarAccess (Just stringType) cs
1534−mkExp (SOp LStrIndex [str, i]) = mkVarAccess (Just integerType) i >>= mkStringAtIndex str
1535−mkExp (SOp LStrRev [str]) =
1536− (\ var -> MethodInv $
1537− PrimaryMethodCall ( MethodInv $ PrimaryMethodCall (InstanceCreation []
1538− (ClassType [(Ident "StringBuffer", [])])
1539− [var]
1540− Nothing
1541− )
1542− []
1543− (Ident "reverse")
1544− []
1545− )
1546− []
1547− (Ident "toString")
1548− []
1549− )
1550− <$> mkVarAccess (Just stringType) str
1551−mkExp (SOp LStdIn []) = return $ mkSystemStd In
1552−mkExp (SOp LStdOut []) = return $ mkSystemStd Out
1553−mkExp (SOp LStdErr []) = return $ mkSystemStd Err
1554−mkExp (SOp LFork [arg]) = mkThread arg
1555−mkExp (SOp LPar [arg]) = mkExp (SV arg)
1556−mkExp (SOp LVMPtr []) =
1557− return $ MethodInv $ TypeMethodCall (J.Name [Ident "Thread"]) [] (Ident "currentThread") []
1558−mkExp (SOp LNoOp args) = mkExp . SV $ last args
1559−mkExp (SNothing) = return $ Lit Null
1560−mkExp (SError err) =
1561− return . MethodInv $
1562− PrimaryMethodCall (InstanceCreation []
1563− runtimeExceptionType
1564− [Lit $ String err]
1565− ( Just $ ClassBody
1566− [ MemberDecl $ MethodDecl [Public, Final]
1567− []
1568− (Just . RefType $ ClassRefType objectType)
1569− (Ident "throwSelf")
1570− []
1571− []
1572− ( MethodBody . Just $
1573− Block [ BlockStmt (Throw This) ]
1574− )
1575− ]
1576− )
1577− )
1578− []
1579− (Ident "throwSelf")
1580− []
1581−mkExp other = error (show other)
src/IRTS/Java/ASTBuilding.hsnew file+141
@@ -0,0 +1,141 @@
1+module IRTS.Java.ASTBuilding where
2+
3+import IRTS.Java.JTypes
4+
5+import Language.Java.Syntax hiding (Name)
6+import qualified Language.Java.Syntax as J
7+
8+toClassType :: J.Type -> ClassType
9+toClassType (RefType (ClassRefType ct)) = ct
10+toClassType t = error $ "Not a class type: " ++ (show t)
11+
12+toRefType :: J.Type -> RefType
13+toRefType (RefType rt) = rt
14+toRefType t = error $ "Not a ref type: " ++ (show t)
15+
16+class InvocationTarget a where
17+ (~>) :: a -> String -> [Argument] -> Exp
18+
19+instance InvocationTarget ClassType where
20+ (~>) (ClassType ts) method args =
21+ MethodInv $ TypeMethodCall
22+ (J.Name $ map fst ts)
23+ (concatMap (map fromActType . snd) ts)
24+ (Ident method)
25+ args
26+ where
27+ fromActType (ActualType refType) = refType
28+
29+instance InvocationTarget Exp where
30+ (~>) exp method args =
31+ MethodInv $ PrimaryMethodCall
32+ exp
33+ []
34+ (Ident method)
35+ args
36+
37+instance InvocationTarget J.Type where
38+ (~>) t method args = ((toClassType t) ~> method) args
39+
40+class Callable a where
41+ call :: a -> [Argument] -> Exp
42+
43+instance Callable String where
44+ call method args =
45+ MethodInv $ MethodCall (J.Name [Ident method]) args
46+
47+instance Callable Ident where
48+ call method args =
49+ MethodInv $ MethodCall (J.Name [method]) args
50+
51+instance Callable J.Name where
52+ call method args =
53+ MethodInv $ MethodCall method args
54+
55+(<>) :: Type -> Exp -> Exp
56+(<>) = Cast
57+
58+localVar :: Int -> Ident
59+localVar i = Ident $ "loc" ++ show i
60+
61+(@!) :: Exp -> Int -> ArrayIndex
62+(@!) target pos =
63+ ArrayIndex target (Lit $ Int (toInteger pos))
64+
65+(@:=) :: Either ArrayIndex Ident -> Exp -> BlockStmt
66+(@:=) (Right lhs) rhs =
67+ LocalVars [Final] objectType [VarDecl (VarId lhs) (Just $ InitExp rhs)]
68+(@:=) (Left lhs) rhs =
69+ BlockStmt . ExpStmt $ Assign (ArrayLhs lhs) EqualA rhs
70+
71+(~&&~) :: Exp -> Exp -> Exp
72+(~&&~) e1 e2 = BinOp e1 CAnd e2
73+
74+(~==~) :: Exp -> Exp -> Exp
75+(~==~) e1 e2 = BinOp e1 Equal e2
76+
77+addToBlock :: [BlockStmt] -> Exp -> [BlockStmt]
78+addToBlock blk exp = blk ++ [BlockStmt $ ExpStmt exp]
79+
80+jName :: String -> J.Name
81+jName n = J.Name [Ident n]
82+
83+jConst :: String -> Exp
84+jConst = ExpName . jName
85+
86+jReturn :: Exp -> BlockStmt
87+jReturn = BlockStmt . Return . Just
88+
89+jInt :: Int -> Exp
90+jInt = Lit . Int . toInteger
91+
92+jString :: String -> Exp
93+jString = Lit . String
94+
95+simpleMethod :: [Modifier] -> Maybe J.Type -> String -> [FormalParam] -> Block -> Decl
96+simpleMethod mods t name params body =
97+ MemberDecl $ MethodDecl
98+ mods
99+ []
100+ t
101+ (Ident $ name)
102+ params
103+ []
104+ (MethodBody . Just $ body)
105+
106+declareFinalObjectArray :: Ident -> Maybe VarInit -> BlockStmt
107+declareFinalObjectArray name init =
108+ LocalVars [Final]
109+ (array objectType)
110+ [ VarDecl
111+ (VarDeclArray . VarId $ name)
112+ init
113+ ]
114+
115+arrayInitExps :: [Exp] -> VarInit
116+arrayInitExps = InitArray . ArrayInit . map (InitExp)
117+
118+extendWithNull :: [Exp] -> Int -> [Exp]
119+extendWithNull exps additionalZeros =
120+ exps ++ (replicate additionalZeros (Lit $ Null))
121+
122+closure :: Exp -> Exp
123+closure body =
124+ InstanceCreation
125+ []
126+ (toClassType idrisClosureType)
127+ []
128+ (Just $ ClassBody
129+ [ simpleMethod
130+ [Public, Final] (Just objectType) "call" []
131+ (Block [jReturn body])
132+ ]
133+ )
134+
135+bigInteger :: String -> Exp
136+bigInteger s =
137+ InstanceCreation
138+ []
139+ (toClassType bigIntegerType)
140+ [Lit $ String s]
141+ Nothing
src/IRTS/Java/JTypes.hsnew file+294
@@ -0,0 +1,294 @@
1+{-# LANGUAGE PatternGuards #-}
2+module IRTS.Java.JTypes where
3+
4+import Core.TT
5+import IRTS.Lang
6+import Language.Java.Syntax
7+import qualified Language.Java.Syntax as J
8+
9+import qualified Data.Vector.Unboxed as V
10+
11+-----------------------------------------------------------------------
12+-- Primitive types
13+
14+charType :: J.Type
15+charType =
16+ PrimType CharT
17+
18+byteType :: J.Type
19+byteType = PrimType ByteT
20+
21+shortType :: J.Type
22+shortType = PrimType ShortT
23+
24+integerType :: J.Type
25+integerType = PrimType IntT
26+
27+longType :: J.Type
28+longType = PrimType LongT
29+
30+doubleType :: J.Type
31+doubleType = PrimType DoubleT
32+
33+array :: J.Type -> J.Type
34+array t = RefType . ArrayType $ t
35+
36+-----------------------------------------------------------------------
37+-- Boxed types
38+
39+objectType :: J.Type
40+objectType =
41+ RefType . ClassRefType $ ClassType [(Ident "Object", [])]
42+
43+bigIntegerType :: J.Type
44+bigIntegerType =
45+ RefType . ClassRefType $ ClassType [(Ident "BigInteger", [])]
46+
47+stringType :: J.Type
48+stringType =
49+ RefType . ClassRefType $ ClassType [(Ident "String", [])]
50+
51+threadType :: J.Type
52+threadType =
53+ RefType . ClassRefType $ ClassType [(Ident "Thread", [])]
54+
55+callableType :: J.Type
56+callableType =
57+ RefType . ClassRefType $ ClassType [(Ident "Callable", [])]
58+
59+voidType :: J.Type
60+voidType =
61+ RefType . ClassRefType $ ClassType [(Ident "Void", [])]
62+
63+box :: J.Type -> J.Type
64+box (PrimType CharT ) = RefType . ClassRefType $ ClassType [(Ident "Character", [])]
65+box (PrimType ByteT ) = RefType . ClassRefType $ ClassType [(Ident "Byte", [])]
66+box (PrimType ShortT ) = RefType . ClassRefType $ ClassType [(Ident "Short", [])]
67+box (PrimType IntT ) = RefType . ClassRefType $ ClassType [(Ident "Integer", [])]
68+box (PrimType LongT ) = RefType . ClassRefType $ ClassType [(Ident "Long", [])]
69+box (PrimType DoubleT) = RefType . ClassRefType $ ClassType [(Ident "Double", [])]
70+box t = t
71+
72+isFloating :: J.Type -> Bool
73+isFloating (PrimType DoubleT) = True
74+isFloating (PrimType FloatT) = True
75+isFloating _ = False
76+
77+isPrimitive :: J.Type -> Bool
78+isPrimitive (PrimType _) = True
79+isPrimitive _ = False
80+
81+isArray :: J.Type -> Bool
82+isArray (RefType (ArrayType _)) = True
83+isArray _ = False
84+
85+isString :: J.Type -> Bool
86+isString (RefType (ClassRefType (ClassType [(Ident "String", _)]))) = True
87+isString _ = False
88+
89+-----------------------------------------------------------------------
90+-- Idris rts classes
91+
92+idrisClosureType :: J.Type
93+idrisClosureType =
94+ RefType . ClassRefType $ ClassType [(Ident "Closure", [])]
95+
96+idrisTailCallClosureType :: J.Type
97+idrisTailCallClosureType =
98+ RefType . ClassRefType $ ClassType [(Ident "TailCallClosure", [])]
99+
100+idrisObjectType :: J.Type
101+idrisObjectType =
102+ RefType . ClassRefType $ ClassType [(Ident "IdrisObject", [])]
103+
104+foreignWrapperType :: J.Type
105+foreignWrapperType =
106+ RefType . ClassRefType $ ClassType [(Ident "ForeignWrapper", [])]
107+
108+primFnType :: J.Type
109+primFnType =
110+ RefType . ClassRefType $ ClassType [(Ident "PrimFn", [])]
111+
112+-----------------------------------------------------------------------
113+-- Java utility classes
114+
115+arraysType :: J.Type
116+arraysType =
117+ RefType . ClassRefType $ ClassType [(Ident "Arrays", [])]
118+
119+mathType :: J.Type
120+mathType =
121+ RefType . ClassRefType $ ClassType [(Ident "Math", [])]
122+
123+
124+-----------------------------------------------------------------------
125+-- Exception types
126+
127+exceptionType :: J.Type
128+exceptionType =
129+ RefType . ClassRefType $ ClassType [(Ident "Exception", [])]
130+
131+runtimeExceptionType :: J.Type
132+runtimeExceptionType =
133+ RefType . ClassRefType $ ClassType [(Ident "RuntimeException", [])]
134+
135+nativeTyToJType :: NativeTy -> J.Type
136+nativeTyToJType IT8 = byteType
137+nativeTyToJType IT16 = shortType
138+nativeTyToJType IT32 = integerType
139+nativeTyToJType IT64 = longType
140+
141+intTyToJType :: IntTy -> J.Type
142+intTyToJType (ITFixed nt) = nativeTyToJType nt
143+intTyToJType (ITNative) = integerType
144+intTyToJType (ITBig) = bigIntegerType
145+intTyToJType (ITChar) = charType
146+intTyToJType (ITVec nt _) = array $ nativeTyToJType nt
147+
148+arithTyToJType :: ArithTy -> J.Type
149+arithTyToJType (ATInt it) = intTyToJType it
150+arithTyToJType (ATFloat) = doubleType
151+
152+-----------------------------------------------------------------------
153+-- Context variables
154+
155+localContextID :: Ident
156+localContextID = Ident "context"
157+
158+localContext :: Exp
159+localContext = ExpName $ Name [localContextID]
160+
161+globalContextID :: Ident
162+globalContextID = Ident "globalContext"
163+
164+globalContext :: Exp
165+globalContext = ExpName $ Name [globalContextID]
166+
167+newContextID :: Ident
168+newContextID = Ident "new_context"
169+
170+newContext :: Exp
171+newContext = ExpName $ Name [newContextID]
172+
173+contextArray :: LVar -> Exp
174+contextArray (Loc _) = localContext
175+contextArray (Glob _) = globalContext
176+
177+contextParam :: FormalParam
178+contextParam = FormalParam [Final] (array objectType) False (VarId localContextID)
179+
180+-----------------------------------------------------------------------
181+-- Constant types
182+
183+constType :: Const -> J.Type
184+constType (I _) = arithTyToJType (ATInt ITNative)
185+constType (BI _) = arithTyToJType (ATInt ITBig )
186+constType (Fl _) = arithTyToJType (ATFloat )
187+constType (Ch _) = arithTyToJType (ATInt ITChar )
188+constType (Str _) = stringType
189+constType (B8 _) = arithTyToJType (ATInt $ ITFixed IT8 )
190+constType (B16 _) = arithTyToJType (ATInt $ ITFixed IT16)
191+constType (B32 _) = arithTyToJType (ATInt $ ITFixed IT32)
192+constType (B64 _) = arithTyToJType (ATInt $ ITFixed IT64)
193+constType (B8V v) = arithTyToJType (ATInt . ITVec IT8 $ V.length v)
194+constType (B16V v) = arithTyToJType (ATInt . ITVec IT16 $ V.length v)
195+constType (B32V v) = arithTyToJType (ATInt . ITVec IT32 $ V.length v)
196+constType (B64V v) = arithTyToJType (ATInt . ITVec IT64 $ V.length v)
197+constType _ = objectType
198+
199+-----------------------------------------------------------------------
200+-- Foreign types
201+
202+foreignType :: FType -> Maybe J.Type
203+foreignType (FArith at) = Just $ arithTyToJType at
204+foreignType (FFunction ) = Just $ callableType
205+foreignType (FFunctionIO ) = Just $ callableType
206+foreignType (FString ) = Just $ stringType
207+foreignType (FUnit ) = Nothing
208+foreignType (FPtr ) = Just $ objectType
209+foreignType (FAny ) = Just $ objectType
210+
211+-----------------------------------------------------------------------
212+-- Primitive operation analysis
213+
214+opName :: PrimFn -> String
215+opName x
216+ | (LSExt _ to) <- x = "LSExt" ++ (suffixFor to)
217+ | (LZExt _ to) <- x = "LZExt" ++ (suffixFor to)
218+ | (LTrunc _ to) <- x = "LTrunc" ++ (suffixFor to)
219+ | (LFloatInt to) <- x = "LFloatInt" ++ (suffixFor to)
220+ | (LStrInt to) <- x = "LStrInt" ++ (suffixFor to)
221+ | otherwise = takeWhile ((/=) ' ') $ show x
222+ where
223+ suffixFor (ITFixed nt) = show nt
224+ suffixFor (ITNative) = show IT32
225+ suffixFor (ITBig) = show ITBig
226+ suffixFor (ITChar) = show ITChar
227+ suffixFor (ITVec nt _) = "ITVec" ++ (show $ nativeTyWidth nt)
228+
229+sourceTypes :: PrimFn -> [J.Type]
230+sourceTypes (LPlus from) = [arithTyToJType from, arithTyToJType from]
231+sourceTypes (LMinus from) = [arithTyToJType from, arithTyToJType from]
232+sourceTypes (LTimes from) = [arithTyToJType from, arithTyToJType from]
233+sourceTypes (LUDiv from) = [intTyToJType from, intTyToJType from]
234+sourceTypes (LSDiv from) = [arithTyToJType from, arithTyToJType from]
235+sourceTypes (LURem from) = [intTyToJType from, intTyToJType from]
236+sourceTypes (LSRem from) = [arithTyToJType from, arithTyToJType from]
237+sourceTypes (LAnd from) = [intTyToJType from, intTyToJType from]
238+sourceTypes (LOr from) = [intTyToJType from, intTyToJType from]
239+sourceTypes (LXOr from) = [intTyToJType from, intTyToJType from]
240+sourceTypes (LCompl from) = [intTyToJType from]
241+sourceTypes (LSHL from) = [intTyToJType from, intTyToJType from]
242+sourceTypes (LLSHR from) = [intTyToJType from, intTyToJType from]
243+sourceTypes (LASHR from) = [intTyToJType from, intTyToJType from]
244+sourceTypes (LEq from) = [arithTyToJType from, arithTyToJType from]
245+sourceTypes (LLt from) = [arithTyToJType from, arithTyToJType from]
246+sourceTypes (LLe from) = [arithTyToJType from, arithTyToJType from]
247+sourceTypes (LGt from) = [arithTyToJType from, arithTyToJType from]
248+sourceTypes (LGe from) = [arithTyToJType from, arithTyToJType from]
249+sourceTypes (LSExt from _) = [intTyToJType from]
250+sourceTypes (LZExt from _) = [intTyToJType from]
251+sourceTypes (LTrunc from _) = [intTyToJType from]
252+sourceTypes (LStrConcat) = repeat stringType
253+sourceTypes (LStrLt) = [stringType, stringType]
254+sourceTypes (LStrEq) = [stringType, stringType]
255+sourceTypes (LStrLen) = [stringType]
256+sourceTypes (LIntFloat from) = [intTyToJType from]
257+sourceTypes (LFloatInt _) = [doubleType]
258+sourceTypes (LIntStr from) = [intTyToJType from]
259+sourceTypes (LStrInt from) = [stringType]
260+sourceTypes (LFloatStr) = [doubleType]
261+sourceTypes (LStrFloat) = [stringType]
262+sourceTypes (LChInt _) = [charType]
263+sourceTypes (LIntCh from) = [intTyToJType from]
264+sourceTypes (LPrintNum) = [objectType]
265+sourceTypes (LPrintStr) = [stringType]
266+sourceTypes (LReadStr) = [objectType]
267+sourceTypes (LFExp) = [doubleType]
268+sourceTypes (LFLog) = [doubleType]
269+sourceTypes (LFSin) = [doubleType]
270+sourceTypes (LFCos) = [doubleType]
271+sourceTypes (LFTan) = [doubleType]
272+sourceTypes (LFASin) = [doubleType]
273+sourceTypes (LFACos) = [doubleType]
274+sourceTypes (LFATan) = [doubleType]
275+sourceTypes (LFSqrt) = [doubleType]
276+sourceTypes (LFFloor) = [doubleType]
277+sourceTypes (LFCeil) = [doubleType]
278+sourceTypes (LMkVec nt n) = replicate n (nativeTyToJType nt)
279+sourceTypes (LIdxVec nt _) = [array $ nativeTyToJType nt, integerType]
280+sourceTypes (LUpdateVec nt _) = [array $ nativeTyToJType nt, integerType, nativeTyToJType nt]
281+sourceTypes (LStrHead) = [stringType]
282+sourceTypes (LStrTail) = [stringType]
283+sourceTypes (LStrCons) = [charType, stringType]
284+sourceTypes (LStrIndex) = [stringType, integerType]
285+sourceTypes (LStrRev) = [stringType]
286+sourceTypes (LStdIn) = []
287+sourceTypes (LStdOut) = []
288+sourceTypes (LStdErr) = []
289+sourceTypes (LFork) = [objectType]
290+sourceTypes (LPar) = [objectType]
291+sourceTypes (LVMPtr) = []
292+sourceTypes (LNoOp) = repeat objectType
293+
294+
src/IRTS/Java/Mangling.hsnew file+108
@@ -0,0 +1,108 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE MultiParamTypeClasses #-}
3+
4+module IRTS.Java.Mangling where
5+
6+import Core.TT
7+import IRTS.Lang
8+import IRTS.Simplified
9+
10+import Control.Applicative
11+import Control.Monad
12+import Control.Monad.Error
13+import Data.Char
14+
15+import Language.Java.Parser
16+import Language.Java.Pretty
17+import Language.Java.Syntax hiding (Name)
18+import qualified Language.Java.Syntax as J
19+
20+import System.FilePath
21+
22+prefixCallNamespaces :: Ident -> SDecl -> SDecl
23+prefixCallNamespaces name (SFun fname args i e) =
24+ SFun fname args i (prefixCallNamespacesExp name e)
25+ where
26+ prefixCallNamespacesExp :: Ident -> SExp -> SExp
27+ prefixCallNamespacesExp (Ident name) (SApp tail (NS n ns) args) =
28+ SApp tail (NS n (name:ns)) args
29+ prefixCallNamespacesExp name (SLet var e1 e2) =
30+ SLet var (prefixCallNamespacesExp name e1) (prefixCallNamespacesExp name e2)
31+ prefixCallNamespacesExp name (SUpdate var e) =
32+ SUpdate var (prefixCallNamespacesExp name e)
33+ prefixCallNamespacesExp name (SCase var alts) =
34+ SCase var (map (prefixCallNamespacesCase name) alts)
35+ prefixCallNamespacesExp name (SChkCase var alts) =
36+ SChkCase var (map (prefixCallNamespacesCase name) alts)
37+ prefixCallNamespacesExp _ exp = exp
38+
39+ prefixCallNamespacesCase :: Ident -> SAlt -> SAlt
40+ prefixCallNamespacesCase name (SConCase x y n ns e) =
41+ SConCase x y n ns (prefixCallNamespacesExp name e)
42+ prefixCallNamespacesCase name (SConstCase c e) =
43+ SConstCase c (prefixCallNamespacesExp name e)
44+ prefixCallNamespacesCase name (SDefaultCase e) =
45+ SDefaultCase (prefixCallNamespacesExp name e)
46+
47+liftParsed :: (Show e, MonadError String m) => Either e a -> m a
48+liftParsed = either (\ err -> throwError $ "Parser error: " ++ (show err))
49+ (return)
50+
51+mkClassName :: (MonadError String m) => FilePath -> m Ident
52+mkClassName path =
53+ liftParsed . parser ident . takeBaseName $ takeFileName path
54+
55+mangleWithPrefix :: (Applicative m, MonadError String m) => String -> Name -> m Ident
56+mangleWithPrefix prefix (NS name _) = mangleWithPrefix prefix name
57+mangleWithPrefix prefix (MN i name) =
58+ (\ (Ident x) -> Ident $ x ++ ('_' : show i))
59+ <$> mangleWithPrefix prefix (UN name)
60+mangleWithPrefix prefix (UN name) =
61+ liftParsed
62+ . parser ident
63+ . (prefix ++)
64+ . cleanNonLetter
65+ $ cleanWs False name
66+ where
67+ cleanNonLetter (x:xs)
68+ | x == '#' = "_Hash" ++ cleanNonLetter xs
69+ | x == '@' = "_At" ++ cleanNonLetter xs
70+ | x == '$' = "_Dollar" ++ cleanNonLetter xs
71+ | x == '!' = "_Bang" ++ cleanNonLetter xs
72+ | x == '.' = "_Dot" ++ cleanNonLetter xs
73+ | x == '\'' = "_Prime" ++ cleanNonLetter xs
74+ | x == '*' = "_Times" ++ cleanNonLetter xs
75+ | x == '+' = "_Plus" ++ cleanNonLetter xs
76+ | x == '/' = "_Divide" ++ cleanNonLetter xs
77+ | x == '-' = "_Minus" ++ cleanNonLetter xs
78+ | x == '%' = "_Mod" ++ cleanNonLetter xs
79+ | x == '<' = "_LessThan" ++ cleanNonLetter xs
80+ | x == '=' = "_Equals" ++ cleanNonLetter xs
81+ | x == '>' = "_MoreThan" ++ cleanNonLetter xs
82+ | x == '[' = "_LSBrace" ++ cleanNonLetter xs
83+ | x == ']' = "_RSBrace" ++ cleanNonLetter xs
84+ | x == '(' = "_LBrace" ++ cleanNonLetter xs
85+ | x == ')' = "_RBrace" ++ cleanNonLetter xs
86+ | x == '_' = "__" ++ cleanNonLetter xs
87+ | not (isAlphaNum x) = "_" ++ (show $ ord x) ++ xs
88+ | otherwise = x:cleanNonLetter xs
89+ cleanNonLetter [] = []
90+ cleanWs capitalize (x:xs)
91+ | isSpace x = cleanWs True xs
92+ | capitalize = (toUpper x) : (cleanWs False xs)
93+ | otherwise = x : (cleanWs False xs)
94+ cleanWs _ [] = []
95+
96+mangle :: (Applicative m, MonadError String m) => Name -> m Ident
97+mangle = mangleWithPrefix "__IDRCG__"
98+
99+mangle' :: Name -> Ident
100+mangle' = either error id . mangleWithPrefix "__IDRCG__"
101+
102+mangleFull :: (Applicative m, MonadError String m) => Name -> m J.Name
103+mangleFull (NS name (rootns:nss)) =
104+ (\ r n ns -> J.Name (r:(ns ++ [n])))
105+ <$> mangleWithPrefix "" (UN rootns)
106+ <*> mangle name
107+ <*> mapM (mangle . UN) nss
108+mangleFull n = J.Name . (:[]) <$> mangle n
src/IRTS/Lang.hs+19−16
@@ -1,9 +1,9 @@
1module IRTS.Lang where
1module IRTS.Lang where
2
2
3−import Core.TT
3+import Control.Monad.State hiding (lift)
4−import Control.Monad.State hiding(lift)
4+import Core.TT
5−import Data.List
5+import Data.List
6−import Debug.Trace
6+import Debug.Trace
7
7
8data LVar = Loc Int | Glob Name
8data LVar = Loc Int | Glob Name
9 deriving (Show, Eq)
9 deriving (Show, Eq)
@@ -48,16 +48,19 @@ data PrimFn = LPlus ArithTy | LMinus ArithTy | LTimes ArithTy
48 | LStrHead | LStrTail | LStrCons | LStrIndex | LStrRev
48 | LStrHead | LStrTail | LStrCons | LStrIndex | LStrRev
49 | LStdIn | LStdOut | LStdErr
49 | LStdIn | LStdOut | LStdErr
50
50
51− | LFork
51+ | LFork
52 | LPar -- evaluate argument anywhere, possibly on another
52 | LPar -- evaluate argument anywhere, possibly on another
53 -- core or another machine. 'id' is a valid implementation
53 -- core or another machine. 'id' is a valid implementation
54− | LVMPtr
54+ | LVMPtr
55 | LNoOp
55 | LNoOp
56 deriving (Show, Eq)
56 deriving (Show, Eq)
57
57
58-- Supported target languages for foreign calls
58-- Supported target languages for foreign calls
59
59
60−data FLang = LANG_C
60+data FCallType = FStatic | FObject | FConstructor
61+ deriving (Show, Eq)
62+
63+data FLang = LANG_C | LANG_JAVA FCallType
61 deriving (Show, Eq)
64 deriving (Show, Eq)
62
65
63data FType = FArith ArithTy
66data FType = FArith ArithTy
@@ -86,9 +89,9 @@ data LOpt = Inline | NoInline
86addTags :: Int -> [(Name, LDecl)] -> (Int, [(Name, LDecl)])
89addTags :: Int -> [(Name, LDecl)] -> (Int, [(Name, LDecl)])
87addTags i ds = tag i ds []
90addTags i ds = tag i ds []
88 where tag i ((n, LConstructor n' (-1) a) : as) acc
91 where tag i ((n, LConstructor n' (-1) a) : as) acc
89− = tag (i + 1) as ((n, LConstructor n' i a) : acc)
92+ = tag (i + 1) as ((n, LConstructor n' i a) : acc)
90 tag i ((n, LConstructor n' t a) : as) acc
93 tag i ((n, LConstructor n' t a) : as) acc
91− = tag i as ((n, LConstructor n' t a) : acc)
94+ = tag i as ((n, LConstructor n' t a) : acc)
92 tag i (x : as) acc = tag i as (x : acc)
95 tag i (x : as) acc = tag i as (x : acc)
93 tag i [] acc = (i, reverse acc)
96 tag i [] acc = (i, reverse acc)
94
97
@@ -102,7 +105,7 @@ liftAll :: [(Name, LDecl)] -> [(Name, LDecl)]
102liftAll xs = concatMap (\ (x, d) -> lambdaLift x d) xs
105liftAll xs = concatMap (\ (x, d) -> lambdaLift x d) xs
103
106
104lambdaLift :: Name -> LDecl -> [(Name, LDecl)]
107lambdaLift :: Name -> LDecl -> [(Name, LDecl)]
105−lambdaLift n (LFun _ _ args e)
108+lambdaLift n (LFun _ _ args e)
106 = let (e', (LS _ _ decls)) = runState (lift args e) (LS n 0 []) in
109 = let (e', (LS _ _ decls)) = runState (lift args e) (LS n 0 []) in
107 (n, LFun [] n args e') : decls
110 (n, LFun [] n args e') : decls
108lambdaLift n x = [(n, x)]
111lambdaLift n x = [(n, x)]
@@ -128,7 +131,7 @@ lift env (LApp tc f args) = do f' <- lift env f
128lift env (LLazyApp n args) = do args' <- mapM (lift env) args
131lift env (LLazyApp n args) = do args' <- mapM (lift env) args
129 return (LLazyApp n args')
132 return (LLazyApp n args')
130lift env (LLazyExp (LConst c)) = return (LConst c)
133lift env (LLazyExp (LConst c)) = return (LConst c)
131−-- lift env (LLazyExp (LApp tc (LV (Glob f)) args))
134+-- lift env (LLazyExp (LApp tc (LV (Glob f)) args))
132-- = lift env (LLazyApp f args)
135-- = lift env (LLazyApp f args)
133lift env (LLazyExp e) = do e' <- lift env e
136lift env (LLazyExp e) = do e' <- lift env e
134 let usedArgs = nub $ usedIn env e'
137 let usedArgs = nub $ usedIn env e'
@@ -136,7 +139,7 @@ lift env (LLazyExp e) = do e' <- lift env e
136 addFn fn (LFun [NoInline] fn usedArgs e')
139 addFn fn (LFun [NoInline] fn usedArgs e')
137 return (LLazyApp fn (map (LV . Glob) usedArgs))
140 return (LLazyApp fn (map (LV . Glob) usedArgs))
138lift env (LForce e) = do e' <- lift env e
141lift env (LForce e) = do e' <- lift env e
139− return (LForce e')
142+ return (LForce e')
140lift env (LLet n v e) = do v' <- lift env v
143lift env (LLet n v e) = do v' <- lift env v
141 e' <- lift (env ++ [n]) e
144 e' <- lift (env ++ [n]) e
142 return (LLet n v' e')
145 return (LLet n v' e')
@@ -176,8 +179,8 @@ usedArg env n | n `elem` env = [n]
176 | otherwise = []
179 | otherwise = []
177
180
178usedIn :: [Name] -> LExp -> [Name]
181usedIn :: [Name] -> LExp -> [Name]
179−usedIn env (LV (Glob n)) = usedArg env n
182+usedIn env (LV (Glob n)) = usedArg env n
180−usedIn env (LApp _ e args) = usedIn env e ++ concatMap (usedIn env) args
183+usedIn env (LApp _ e args) = usedIn env e ++ concatMap (usedIn env) args
181usedIn env (LLazyApp n args) = concatMap (usedIn env) args ++ usedArg env n
184usedIn env (LLazyApp n args) = concatMap (usedIn env) args ++ usedArg env n
182usedIn env (LLazyExp e) = usedIn env e
185usedIn env (LLazyExp e) = usedIn env e
183usedIn env (LForce e) = usedIn env e
186usedIn env (LForce e) = usedIn env e
@@ -201,7 +204,7 @@ instance Show LExp where
201 showSep ", " (map (show' env) args) ++")"
204 showSep ", " (map (show' env) args) ++")"
202 show' env (LApp _ e args) = show' env e ++ "(" ++
205 show' env (LApp _ e args) = show' env e ++ "(" ++
203 showSep ", " (map (show' env) args) ++")"
206 showSep ", " (map (show' env) args) ++")"
204− show' env (LLazyExp e) = "%lazy(" ++ show' env e ++ ")"
207+ show' env (LLazyExp e) = "%lazy(" ++ show' env e ++ ")"
205 show' env (LForce e) = "%force(" ++ show' env e ++ ")"
208 show' env (LForce e) = "%force(" ++ show' env e ++ ")"
206 show' env (LLet n v e) = "let " ++ show n ++ " = " ++ show' env v ++ " in " ++
209 show' env (LLet n v e) = "let " ++ show n ++ " = " ++ show' env v ++ " in " ++
207 show' (env ++ [show n]) e
210 show' (env ++ [show n]) e
@@ -218,7 +221,7 @@ instance Show LExp where
218 show' env (LError str) = "error " ++ show str
221 show' env (LError str) = "error " ++ show str
219 show' env LNothing = "____"
222 show' env LNothing = "____"
220
223
221− showAlt env (LConCase _ n args e)
224+ showAlt env (LConCase _ n args e)
222 = show n ++ "(" ++ showSep ", " (map show args) ++ ") => "
225 = show n ++ "(" ++ showSep ", " (map show args) ++ ") => "
223 ++ show' env e
226 ++ show' env e
224 showAlt env (LConstCase c e) = show c ++ " => " ++ show' env e
227 showAlt env (LConstCase c e) = show c ++ " => " ++ show' env e