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