b4689f4 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

Java Backend Overhaul Part 1

commitb4689f4dd3817a882db443bc233a73702a057889 authorJan Bessai <Jan.Bessai@tu-dortmund.de> dateMon 8 Jul 2013, 03:41 (13 years ago) parent1e84e48

9 files changed+2333−1412

compare with master

unifiedsplit

java/src/main/java/org/idris/rts/Closure.java+8 java/src/main/java/org/idris/rts/ForeignPrimitives.java+3−19 java/src/main/java/org/idris/rts/ForeignWrapper.java+14 java/src/main/java/org/idris/rts/PrimFn.java+1339 src/IRTS/CodegenJava.hs+414−1377 src/IRTS/Java/ASTBuilding.hs+135 src/IRTS/Java/JTypes.hs+293 src/IRTS/Java/Mangling.hs+108 src/IRTS/Lang.hs+19−16

java/src/main/java/org/idris/rts/Closure.java+8

@@ -9,9 +9,17 @@ public abstract class Closure implements Callable<Object>, Runnable {

99 this.context = context;

1010 }

1111

12+ @Override

1213 public void run() {

1314 call();

1415 }

1516

17+ @Override

1618 public abstract Object call();

19+

20+ public Thread fork() {

21+ Thread childProcess = new Thread(this);

22+ childProcess.start();

23+ return childProcess;

24+ }

1725}

java/src/main/java/org/idris/rts/ForeignPrimitives.java+3−19

@@ -241,7 +241,7 @@ public class ForeignPrimitives {

241241 return result;

242242 }

243243

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) {

245245 int i = start;

246246 for (Object var : vars) {

247247 context[i] = var;

@@ -249,23 +249,7 @@ public class ForeignPrimitives {

249249 return context;

250250 }

251251

252− public final static Object invokeOn(final Object obj, final String methodName, Object... args) throws NoSuchMethodException, IllegalAccessException, InvocationTargetException {

253− Class cls = (obj instanceof Class ? (Class)obj : obj.getClass());

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);

252+ public final static Object idris_throwException(RuntimeException ex) {

253+ throw ex;

270254 }

271255}

java/src/main/java/org/idris/rts/ForeignWrapper.javanew file+14

@@ -0,0 +1,14 @@

1+/*

2+ */

3+package org.idris.rts;

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;

5+import java.io.IOException;

6+import java.io.InputStream;

7+import java.io.OutputStream;

8+import java.math.BigInteger;

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 #-}

12module IRTS.CodegenJava (codegenJava) where

34import Core.TT

45import IRTS.BCImp

56import IRTS.CodegenCommon

7+import IRTS.Java.ASTBuilding

8+import IRTS.Java.JTypes

9+import IRTS.Java.Mangling

610import IRTS.Lang

711import IRTS.Simplified

812import Paths_idris

913import Util.System

1014

11−import Control.Applicative

15+import Control.Applicative hiding (Const)

1216import Control.Arrow

1317import Control.Monad

14−import qualified Control.Monad.Trans as T

18+import qualified Control.Monad.Trans as T

1519import Control.Monad.Trans.State

16−import Data.Char

17−import Data.Maybe (fromJust)

18−import Data.List (isPrefixOf, isSuffixOf, intercalate, foldl')

1920import Data.Int

20−import qualified Data.Text as T

21−import qualified Data.Text.IO as TIO

21+import Data.List (foldl', intercalate, isPrefixOf,

22+ isSuffixOf)

23+import Data.Maybe (fromJust)

24+import qualified Data.Text as T

25+import qualified Data.Text.IO as TIO

26+import qualified Data.Vector.Unboxed as V

2227import Language.Java.Parser

2328import Language.Java.Pretty

24−import Language.Java.Syntax hiding (Name)

25−import qualified Language.Java.Syntax as J

29+import Language.Java.Syntax hiding (Name)

30+import qualified Language.Java.Syntax as J

2631import System.Directory

2732import System.Exit

2833import System.FilePath

2934import System.IO

3035import System.Process

3136

32−data CodeGenerationEnv = CodeGenerationEnv { globalVariablePositions :: [(Name, Integer)] }

37+data CodeGenerationEnv = CodeGenerationEnv { globalVariablePositions :: [(Name, Int)] }

3338

3439type CodeGeneration = StateT (CodeGenerationEnv) (Either String)

40+type BlockResultTransformation = [BlockStmt] -> Exp -> CodeGeneration [BlockStmt]

3541

3642codegenJava :: [(Name, SExp)] -> -- initialization of globals

3743 [(Name, SDecl)] ->

@@ -44,11 +50,10 @@ codegenJava globalInit defs out hdrs libs exec = do

4450 withTempdir (takeBaseName out) $ \ tmpDir -> do

4551 let srcdir = tmpDir </> "src" </> "main" </> "java"

4652 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)

4954 let outjava = srcdir </> clsName <.> "java"

5055 let jout = either error

51− (flatIndent . prettyPrint)

56+ (prettyPrint)-- flatIndent . prettyPrint)

5257 (evalStateT (mkCompilationUnit globalInit defs hdrs out) (mkCodeGenEnv globalInit))

5358 writeFile outjava jout

5459 if (exec == Raw)

@@ -58,8 +63,8 @@ codegenJava globalInit defs out hdrs libs exec = do

5863 execPomTemplate <- TIO.readFile execPom

5964 let execPom = T.replace (T.pack "$MAIN-CLASS$")

6065 (T.pack clsName)

61− (T.replace (T.pack "$ARTIFACT-NAME$")

62− (T.pack $ takeBaseName out)

66+ (T.replace (T.pack "$ARTIFACT-NAME$")

67+ (T.pack $ takeBaseName out)

6368 (T.replace (T.pack "$DEPENDENCIES$")

6469 (mkPomDependencies libs)

6570 execPomTemplate

@@ -72,11 +77,11 @@ codegenJava globalInit defs out hdrs libs exec = do

7277 when (exit /= ExitSuccess) $ error ("FAILURE: " ++ mvnCmd ++ " compile\n" ++ err ++ mvout)

7378 if (exec == Object)

7479 then do

75− classFiles <-

80+ classFiles <-

7681 map (\ clsFile -> tmpDir </> "target" </> "classes" </> clsFile)

77− . filter ((".class" ==) . takeExtension)

82+ . filter ((".class" ==) . takeExtension)

7883 <$> getDirectoryContents (tmpDir </> "target" </> "classes")

79− mapM_ (\ clsFile -> copyFile clsFile (takeDirectory out </> takeFileName clsFile))

84+ mapM_ (\ clsFile -> copyFile clsFile (takeDirectory out </> takeFileName clsFile))

8085 classFiles

8186 else do

8287 (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ ["package"]) ""

@@ -94,8 +99,11 @@ codegenJava globalInit defs out hdrs libs exec = do

9499 readProcess mvnCmd (args ++ ["clean"]) ""

95100 removeFile (tmpDir </> "pom.xml")

96101

102+-----------------------------------------------------------------------

103+-- Jar and Pom infrastructure

104+

97105jarHeader :: String

98−jarHeader =

106+jarHeader =

99107 "#!/bin/sh\n"

100108 ++ "MYSELF=`which \"$0\" 2>/dev/null`\n"

101109 ++ "[ $? -gt 0 -a -f \"$0\" ] && MYSELF=\"./$0\"\n"

@@ -110,7 +118,7 @@ mkPomDependencies :: [String] -> T.Text

110118mkPomDependencies deps =

111119 T.concat $ map (T.concat . map (T.append (T.pack " ")) . mkDependency . T.pack) deps

112120 where

113− mkDependency s =

121+ mkDependency s =

114122 case T.splitOn (T.pack ":") s of

115123 [g, a, v] ->

116124 [ T.pack $ "<dependency>\n"

@@ -124,136 +132,127 @@ mkPomDependencies deps =

124132 mkArtifactId a = T.append (T.pack $ "<artifactId>") (T.append a $ T.pack "</artifactId>\n")

125133 mkVersion v = T.append (T.pack $ "<version>") (T.append v $ T.pack "</version>\n")

126134

135+-----------------------------------------------------------------------

136+-- Code generation environment

137+

127138mkCodeGenEnv :: [(Name, SExp)] -> CodeGenerationEnv

128−mkCodeGenEnv globalInit =

139+mkCodeGenEnv globalInit =

129140 CodeGenerationEnv $ zipWith (\ (name, _) pos -> (name, pos)) globalInit [0..]

130141

142+flatIndent :: String -> String

143+flatIndent (' ' : ' ' : xs) = flatIndent xs

144+flatIndent (x:xs) = x:flatIndent xs

145+flatIndent [] = []

146+

147+-----------------------------------------------------------------------

148+-- File structure

149+

131150mkCompilationUnit :: [(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

133153 CompilationUnit Nothing ( [ ImportDecl False idrisRts True

134154 , ImportDecl True idrisForeign True

155+ , ImportDecl False idrisForeignWrapper False

156+ , ImportDecl False idrisPrimFn False

135157 , ImportDecl False bigInteger False

136158 , ImportDecl False stringBuffer False

137159 , ImportDecl False runtimeException False

138160 , ImportDecl False scanner False

139161 , ImportDecl False arrays False

162+ , ImportDecl False callable False

140163 ] ++ otherHdrs

141164 )

142− <$> mkTypeDecl globalInit defs out

165+ <$> mkTypeDecl clsName globalInit defs

143166 where

144167 idrisRts = J.Name $ map Ident ["org", "idris", "rts"]

145168 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"]

146171 bigInteger = J.Name $ map Ident ["java", "math", "BigInteger"]

147172 stringBuffer = J.Name $ map Ident ["java", "lang", "StringBuffer"]

148173 runtimeException = J.Name $ map Ident ["java", "lang", "RuntimeException"]

149174 scanner = J.Name $ map Ident ["java", "util", "Scanner"]

150175 arrays = J.Name $ map Ident ["java", "util", "Arrays"]

176+ callable = J.Name $ map Ident ["java", "util", "concurrent", "Callable"]

151177 otherHdrs = map ( (\ name -> ImportDecl False name False)

152− . J.Name

153− . map (Ident . T.unpack)

154− . T.splitOn (T.pack ".")

155− . T.pack)

178+ . J.Name

179+ . map (Ident . T.unpack)

180+ . T.splitOn (T.pack ".")

181+ . T.pack)

156182 $ filter (not . isSuffixOf ".h") hdrs

157183

158−flatIndent :: String -> String

159−flatIndent (' ' : ' ' : xs) = flatIndent xs

160−flatIndent (x:xs) = x:flatIndent xs

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]

180−mkTypeDecl globalInit defs out =

181− (\ name body -> [ClassTypeDecl $ ClassDecl [ Public

182− , Annotation $ SingleElementAnnotation

183− (J.Name [Ident "SuppressWarnings"])

184− (EVVal . InitExp . Lit $ String "unchecked")

185− ]

186− name

187− []

188− Nothing

189− []

190− body])

191− <$> mkClassName out

192− <*> ( mkClassName out

193− >>= (\ ident -> mkClassBody globalInit (map (second (prefixCallNamespacesDecl ident)) 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)

184+-----------------------------------------------------------------------

185+-- Main class

186+

187+mkTypeDecl :: Ident -> [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration [TypeDecl]

188+mkTypeDecl name globalInit defs =

189+ (\ body -> [ClassTypeDecl $ ClassDecl [ Public

190+ , Annotation $ SingleElementAnnotation

191+ (jName "SuppressWarnings")

192+ (EVVal . InitExp $ jString "unchecked")

193+ ]

194+ name

195+ []

196+ Nothing

197+ []

198+ body])

199+ <$> mkClassBody globalInit (map (second (prefixCallNamespaces name)) defs)

200200

201201mkClassBody :: [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration ClassBody

202−mkClassBody globalInit defs =

202+mkClassBody globalInit defs =

203203 (\ globals defs -> ClassBody . (globals++) . addMainMethod . mergeInnerClasses $ defs)

204204 <$> mkGlobalContext globalInit

205205 <*> mapM mkDecl defs

206206

207207mkGlobalContext :: [(Name, SExp)] -> CodeGeneration [Decl]

208208mkGlobalContext [] = return []

209−mkGlobalContext initExps =

210− (\ exps -> [ MemberDecl $ FieldDecl [Private, Static, Final]

211− objectArrayType

212− [VarDecl (VarId $ Ident "globalContext")

213− (Just . InitArray $ ArrayInit exps)

209+mkGlobalContext initExps =

210+ (\ exps -> [ MemberDecl $ FieldDecl [Private, Static, Final]

211+ (array objectType)

212+ [ VarDecl (VarId $ globalContextID). Just . InitExp

213+ $ ArrayCreate objectType [jInt $ length initExps] 0

214214 ]

215+ , InitDecl True (Block $ concat exps)

215216 ]

216217 )

217− <$> mapM (\ (_, exp) -> InitExp <$> mkExp exp) initExps

218−

219−

218+ <$> mapM

219+ (\ (name, exp) ->

220+ mkUpdate (Glob name) exp (\ b e -> return $ addToBlock b e)

221+ )

222+ initExps

220223

221224addMainMethod :: [Decl] -> [Decl]

222225addMainMethod decls

223226 | findMain decls = mkMainMethod : decls

224227 | otherwise = decls

225228 where

226− findMain ((MemberDecl (MemberClassDecl (ClassDecl _ (Ident "Main") _ _ _ (ClassBody body)))):_) =

227− findMainMethod body

229+ findMain ((MemberDecl (MemberClassDecl (ClassDecl _ name _ _ _ (ClassBody body)))):_)

230+ | name == mangle' (UN "Main") = findMainMethod body

228231 findMain (_:decls) = findMain decls

229232 findMain [] = False

230233

231− findMainMethod ((MemberDecl (MethodDecl _ _ _ (Ident "main") [] _ _)):_) = True

234+ innerMainMethod = (either error id $ mangle (UN "main"))

235+ findMainMethod ((MemberDecl (MethodDecl _ _ _ name [] _ _)):_)

236+ | name == mangle' (UN "main") = True

232237 findMainMethod (_:decls) = findMainMethod decls

233238 findMainMethod [] = False

234239

235240mkMainMethod :: Decl

236−mkMainMethod =

237− MemberDecl $ MethodDecl [Public, Static]

238− []

239− Nothing

240− (Ident "main")

241− [FormalParam [] stringArrayType False (VarId $ Ident "args")]

242− []

243− (MethodBody . Just $ Block [ BlockStmt . ExpStmt . MethodInv $

244− MethodCall (J.Name [Ident "idris_initArgs"])

245− [ MethodInv $ TypeMethodCall

246− (J.Name [Ident "Thread"])

247− []

248− (Ident "currentThread")

249− []

250− , ExpName $ J.Name [Ident "args"]

251− ]

252− , BlockStmt . ExpStmt . MethodInv $

253− MethodCall (J.Name [Ident "runMain_0"])

254− []

255− ]

256− )

241+mkMainMethod =

242+ simpleMethod

243+ [Public, Static]

244+ Nothing

245+ "main"

246+ [FormalParam [] (array stringType) False (VarId $ Ident "args")]

247+ $ Block [ BlockStmt . ExpStmt

248+ $ call "idris_initArgs" [ (threadType ~> "currentThread") []

249+ , jConst "args"

250+ ]

251+ , BlockStmt . ExpStmt $ call (mangle' (MN 0 "runMain")) []

252+ ]

253+

254+-----------------------------------------------------------------------

255+-- Inner classes (idris namespaces)

257256

258257mergeInnerClasses :: [Decl] -> [Decl]

259258mergeInnerClasses = foldl' mergeInner []

@@ -274,1305 +273,343 @@ mergeInnerClasses = foldl' mergeInner []

274273 mergeInner [] decl' = [decl']

275274

276275

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", [])]

526276

527277mkDecl :: (Name, SDecl) -> CodeGeneration Decl

528278mkDecl ((NS n (ns:nss)), decl) =

529− (\ name body -> MemberDecl $ MemberClassDecl $ ClassDecl [Public, Static] name [] Nothing [] body)

530− <$> mkIdentifier (UN ns)

279+ (\ name body ->

280+ MemberDecl $ MemberClassDecl $ ClassDecl [Public, Static] name [] Nothing [] body)

281+ <$> mangle (UN ns)

531282 <*> mkClassBody [] [(NS n nss, decl)]

532283mkDecl (_, SFun name params stackSize body) =

533− (\ name params paramNames methodBody ->

534− MemberDecl $ MethodDecl [Public, Static]

535− []

536− (Just . RefType $ ClassRefType objectType)

537− name

538− params

539− []

540− (MethodBody . Just $ Block

541− [ LocalVars [Final]

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

549− ]

550− )

284+ (\ (Ident name) params paramNames methodBody ->

285+ simpleMethod

286+ [Public, Static]

287+ (Just objectType)

288+ name

289+ params

290+ ( Block $ ( declareFinalObjectArray

291+ localContextID

292+ (Just (arrayInitExps $ extendWithNull paramNames stackSize))

293+ ) : methodBody

294+ )

551295 )

552− <$> mkIdentifier name

296+ <$> mangle name

553297 <*> mapM mkFormalParam params

554− <*> mapM (\ p -> (InitExp . ExpName) <$> mkName p) params

555− <*> mkExp body

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

298+ <*> mapM (\ p -> (ExpName) <$> mangleFull p) params

299+ <*> mkExp body (\ block res -> return $ block ++ [jReturn res])

568300

569301mkFormalParam :: Name -> CodeGeneration FormalParam

570302mkFormalParam name =

571− (\ name -> FormalParam [Final] (RefType . ClassRefType $ objectType) False (VarId name))

572− <$> mkIdentifier name

573−

574−mkClosureCall :: SExp -> CodeGeneration Decl

575−mkClosureCall body =

576− (\ body -> MemberDecl $ MethodDecl [Public] [] (Just . RefType $ ClassRefType objectType) (Ident "call") [] [] body)

577− <$> mkMethodBody body

578−

579−mkMethodBody :: SExp -> CodeGeneration MethodBody

580−mkMethodBody exp =

581− (\ exp -> MethodBody . Just . Block $ [BlockStmt . Return . Just $ exp])

582− <$> mkExp exp

583−

584−mkStackInit :: [Name] -> Int -> CodeGeneration Exp

585−mkStackInit params stackSize =

586− (\ localVars -> ArrayCreateInit objectArrayType 0 . ArrayInit $

587− (map (InitExp . ExpName) localVars)

588− ++ (replicate (stackSize) (InitExp $ Lit Null)))

589− <$> mapM mkName params

590−

591−mkK :: Exp -> Exp -> Exp

592−mkK result drop =

593− MethodInv $ MethodCall (J.Name [Ident "idris_K"]) [ result, drop ]

594−

595−mkFlipK :: Exp -> Exp -> Exp

596−mkFlipK drop result =

597− MethodInv $ MethodCall (J.Name [Ident "idris_flipK"]) [ drop, result ]

598−

599−mkLet :: LVar -> SExp -> SExp -> CodeGeneration Exp

600−mkLet (Loc pos) oldExp newExp =

601− (\ oldExp newExp ->

602− mkFlipK ( Assign ( ArrayLhs $ ArrayIndex (ExpName $ J.Name [Ident "context"])

603− (Lit $ Int (toInteger pos)))

604− EqualA

605− newExp

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)

637− <*> mkExp branchExpression

638− <*> mkCase checked var cases

639− <*> mkVarAccess Nothing var

640−mkCase checked var (SDefaultCase exp:cases) = mkExp exp

641−mkCase checked _ [] = mkExp (SError "Non-exhaustive pattern")

642−

643−mkConsCase :: Bool -> LVar -> Int -> Int -> [Name] -> SExp -> SExp -> CodeGeneration Exp

644−mkConsCase checked

645− toDeconstruct

646− parentStackStart

647− consIndex

648− params

649− branchExpression

650− alternative =

651− (\ caseBinding alternative var varCasted->

652− Cond (BinOp (InstanceOf (var)

653− (ClassRefType idrisObjectType)

654− )

655− CAnd

656− ( BinOp

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]

707−mkCaseBindingDeconstruction var members =

708− mapM (mkProjection var) ([0..(length members - 1)])

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

807− start <- mkVarAccess (Just castTo) var

808− foldM (\ exp var -> BinOp exp op <$> mkVarAccess (Just castTo) var) start vars

809−

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)

303+ (\ name -> FormalParam [Final] objectType False (VarId name))

304+ <$> mangle name

305+

306+-----------------------------------------------------------------------

307+-- Expressions

308+

309+-- | Compile a simple expression and use the given continuation to postprocess

310+-- the resulting value.

311+mkExp :: SExp -> BlockResultTransformation -> CodeGeneration [BlockStmt]

312+-- Variables

313+mkExp (SV var) cont = Nothing <>@! var >>= cont []

314+

315+-- Applications

316+mkExp (SApp True name args) cont =

317+ ((\ name args -> call name args) <$> mangleFull name <*> mapM (Nothing <>@!) args) >>= cont []

318+ --mkTailCallClosure name args >>= cont []

319+mkExp (SApp False name args) cont =

320+ ((\ name args -> call name args) <$> mangleFull name <*> mapM (Nothing <>@!) args) >>= cont []

321+ --((\ closure -> (closure ~> "call") []) <$> mkTailCallClosure name args) >>= cont []

322+

323+-- Bindings

324+mkExp (SLet var newExp inExp) cont = mkLet var newExp inExp cont

325+mkExp (SUpdate var newExp) cont = mkUpdate var newExp cont

326+

327+-- Objects

328+mkExp (SCon conId _ args) cont = (mkIdrisObject conId args) >>= cont []

329+

330+-- Case expressions

331+mkExp (SCase var alts) cont = mkCase True var alts cont

332+mkExp (SChkCase var alts) cont = mkCase False var alts cont

333+

334+-- Projections

335+mkExp (SProj var i) cont = (mkProjection var i) >>= cont []

336+

337+-- Constants

338+mkExp (SConst c) cont = cont [] $ mkConstant c

339+

340+-- Foreign function calls

341+mkExp (SForeign lang resTy text params) cont =

342+ (mkForeign lang resTy text params) >>= cont []

343+

344+-- Primitive functions

345+mkExp (SOp LFork [arg]) cont = (mkThread arg) >>= cont []

346+mkExp (SOp LPar [arg]) cont = (Nothing <>@! arg) >>= cont []

347+mkExp (SOp LNoOp args) cont = (Nothing <>@! (last args)) >>= cont []

348+mkExp (SOp op args) cont = (mkPrimitiveFunction op args) >>= cont []

349+

350+-- Empty expressions

351+mkExp (SNothing) cont = cont [] $ Lit Null

352+

353+-- Errors

354+mkExp (SError err) cont = mkException err

355+

356+-----------------------------------------------------------------------

357+-- Variable access

358+

359+(<>@!) :: Maybe J.Type -> LVar -> CodeGeneration Exp

360+(<>@!) Nothing var =

361+ (ArrayAccess . ((contextArray var) @!)) <$> varPos var

362+(<>@!) (Just castTo) var =

363+ (castTo <>) <$> (Nothing <>@! var)

364+

365+varPos :: LVar -> CodeGeneration Int

366+varPos (Loc i) = return i

923367varPos (Glob name) = do

924368 positions <- globalVariablePositions <$> get

925369 case lookup name positions of

926370 (Just pos) -> return pos

927371 Nothing -> T.lift . Left $ "Invalid global variable id: " ++ show name

928372

929−mkVarAccess :: Maybe ClassType -> LVar -> CodeGeneration Exp

930−mkVarAccess Nothing var =

931− (\ pos -> ArrayAccess $ ArrayIndex (contextArray var) (Lit $ Int pos))

932− <$> varPos var

933−mkVarAccess (Just castTo) var =

934− Cast (RefType . ClassRefType $ castTo) <$> (mkVarAccess Nothing var)

935−

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− []

373+-----------------------------------------------------------------------

374+-- Application (wrap method calls in tail call closures)

375+

376+mkTailCallClosure :: Name -> [LVar] -> CodeGeneration Exp

377+mkTailCallClosure name args =

378+ (\ methClosure ->

379+ InstanceCreation [] (toClassType idrisTailCallClosureType) [methClosure] Nothing

1049380 )

1050− <$> mkForeignInvokeMethod fType method args

1051−

1052−

1053−mkForeignInvokeMethod :: FType -> String -> [(FType, LVar)] -> CodeGeneration MemberDecl

1054−mkForeignInvokeMethod fType method args =

1055− (\ tryBlock ->

1056− MethodDecl [Public, Final]

1057− []

1058− (Just . RefType $ ClassRefType objectType)

1059− (Ident "foreignInvoke")

1060− []

1061− []

1062− (MethodBody . Just $ Block

1063− [ BlockStmt

1064− $ Try tryBlock

1065− [ Catch (FormalParam []

1066− (RefType $ ClassRefType exceptionType)

1067− False

1068− (VarId $ Ident "ex")

1069− )

1070− (Block [ BlockStmt

1071− . Throw

1072− $ InstanceCreation []

1073− runtimeExceptionType

1074− [ExpName $ J.Name [Ident "ex"]]

1075− Nothing

1076− ]

1077− )

1078− ]

1079− Nothing

1080− ]

1081− )

381+ <$> mkMethodCallClosure name args

382+

383+mkMethodCallClosure :: Name -> [LVar] -> CodeGeneration Exp

384+mkMethodCallClosure name args =

385+ (\ name args -> closure [localContext] (call name args))

386+ <$> mangleFull name

387+ <*> mapM (Nothing <>@!) args

388+

389+-----------------------------------------------------------------------

390+-- Updates (change context array) and Let bindings (Update, execute)

391+

392+mkUpdate :: LVar -> SExp -> BlockResultTransformation -> CodeGeneration [BlockStmt]

393+mkUpdate var exp cont = do

394+ pos <- varPos var

395+ mkExp exp (\ blk rhs -> cont blk $ ((contextArray var) @! pos) @:= rhs )

396+

397+mkLet :: LVar -> SExp -> SExp -> BlockResultTransformation -> CodeGeneration [BlockStmt]

398+mkLet var@(Loc pos) newExp inExp cont = do

399+ inBlk <- mkExp inExp cont

400+ upd <- mkUpdate var newExp (\ blk exp -> return $ addToBlock blk exp)

401+ return $ upd ++ inBlk

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 ->

410+ InstanceCreation [] (toClassType idrisObjectType) ((jInt conId):args) Nothing

1082411 )

1083− <$> mkForeignInvokeTryBlock fType method args

412+ <$> mapM (Nothing <>@!) args

1084413

414+-----------------------------------------------------------------------

415+-- Case expressions

1085416

1086−mkForeignInvokeTryBlock :: FType -> String -> [(FType, LVar)] -> CodeGeneration Block

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

417+mkCase :: Bool -> LVar -> [SAlt] -> BlockResultTransformation -> CodeGeneration [BlockStmt]

1139418

1140−mkThread :: LVar -> CodeGeneration Exp

1141−mkThread arg =

1142− (\ eval ->

1143− MethodInv

1144− $ PrimaryMethodCall (InstanceCreation []

1145− (ClassType [(Ident "Thread", [])])

1146− [ eval ]

1147− ( Just

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− []

419+mkCase checked var cases cont

420+ | isConstCase cases = do

421+ defaultStmts <- mkDefaultMatch cases cont

422+ ifte <- mkConstMatch var defaultStmts cases cont

423+ return [BlockStmt ifte]

424+mkCase checked var cases cont =

425+ (\ switchExp blocks defaultStmts ->

426+ [BlockStmt $ Switch switchExp (blocks ++ [SwitchBlock Default defaultStmts])]

1174427 )

1175− <$> mkThreadBinding arg

1176−

1177−mkThreadBinding :: LVar -> CodeGeneration Exp

1178−mkThreadBinding var =

1179− (\ bindingMethod var ->

1180− MethodInv $ PrimaryMethodCall ( InstanceCreation []

1181− objectType

1182− []

1183− (Just $ ClassBody [MemberDecl $ bindingMethod])

1184− )

1185− []

1186− (Ident "apply")

1187− [ var ]

428+ <$> mkGetConstructorId checked var

429+ <*> mkConsMatch var cases cont

430+ <*> mkDefaultMatch cases cont

431+

432+isConstCase :: [SAlt] -> Bool

433+isConstCase ((SConstCase _ _):_) = True

434+isConstCase ((SDefaultCase _):cases) = isConstCase cases

435+isConstCase _ = False

436+

437+mkDefaultMatch :: [SAlt] -> BlockResultTransformation -> CodeGeneration [BlockStmt]

438+mkDefaultMatch (x@(SDefaultCase branchExpression):_) cont = mkExp branchExpression cont

439+mkDefaultMatch (x:xs) cont = mkDefaultMatch xs cont

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))

1188476 )

1189− <$> mkThreadBindingMethod

1190− <*> mkVarAccess Nothing var

1191−

1192−

1193−mkThreadBindingMethod :: CodeGeneration MemberDecl

1194−mkThreadBindingMethod =

1195− (\ compute ->

1196− MethodDecl [Final, Public]

1197− []

1198− (Just . RefType $ ClassRefType idrisClosureType)

1199− (Ident "apply")

1200− [ FormalParam [Final] (RefType . ClassRefType $ objectType) False (VarId $ Ident "param") ]

1201− []

1202− (MethodBody . Just $ Block

1203− [ mkThreadBindingStack

1204− , BlockStmt . Return $ Just compute

1205− ]

1206− )

477+ <$> (Nothing <>@! var)

478+ <*> mkGetConstructorId True var

479+

480+mkConsMatch :: LVar -> [SAlt] -> BlockResultTransformation -> CodeGeneration [SwitchBlock]

481+mkConsMatch var ((SConCase parentStackPos consIndex _ params branchExpression):cases) cont =

482+ (\ block others -> (SwitchBlock (SwitchCase $ jInt consIndex) block):others)

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 =

565+ MemberDecl . MethodDecl

566+ [Protected, Final] [] (Just objectType) (Ident $ "wrappedInvoke") [] [toRefType exceptionType]

567+ . MethodBody . Just . Block

568+

569+

570+ wrapReturn FUnit exp = [ BlockStmt $ ExpStmt exp, jReturn (Lit Null) ]

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") []

1207585 )

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

1209588

589+-----------------------------------------------------------------------

590+-- Primitive functions

1210591

1211−mkThreadBindingStack :: BlockStmt

1212−mkThreadBindingStack =

1213− LocalVars [Final]

1214− objectArrayType

1215− [ VarDecl (VarDeclArray . VarId $ Ident "new_context")

1216− (Just . InitArray $ ArrayInit [InitExp . ExpName $ J.Name [Ident "param"]])

1217− ]

1218−

592+mkPrimitiveFunction :: PrimFn -> [LVar] -> CodeGeneration Exp

593+mkPrimitiveFunction op args =

594+ (\ args -> (primFnType ~> opName op) args)

595+ <$> sequence (zipWith (\ a t -> (Just t) <>@! a) args (sourceTypes op))

596+

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

609+ []

610+ (toClassType runtimeExceptionType)

611+ [Lit $ String err]

612+ Nothing

613+ )

614+ ]

1219615

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

3+import IRTS.Java.JTypes

5+import Language.Java.Syntax hiding (Name)

6+import qualified Language.Java.Syntax as J

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

4+import Core.TT

5+import IRTS.Lang

6+import Language.Java.Syntax

7+import qualified Language.Java.Syntax as J

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 #-}

4+module IRTS.Java.Mangling where

6+import Core.TT

7+import IRTS.Lang

8+import IRTS.Simplified

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 @@

11module IRTS.Lang where

3−import Core.TT

4−import Control.Monad.State hiding(lift)

5−import Data.List

6−import Debug.Trace

3+import Control.Monad.State hiding (lift)

4+import Core.TT

5+import Data.List

6+import Debug.Trace

88data LVar = Loc Int | Glob Name

99 deriving (Show, Eq)

@@ -48,16 +48,19 @@ data PrimFn = LPlus ArithTy | LMinus ArithTy | LTimes ArithTy

4949 | LStdIn | LStdOut | LStdErr

5050

51− | LFork

51+ | LFork

5252 | LPar -- evaluate argument anywhere, possibly on another

5353 -- core or another machine. 'id' is a valid implementation

54− | LVMPtr

54+ | LVMPtr

5555 | LNoOp

5656 deriving (Show, Eq)

5757

5858-- Supported target languages for foreign calls

5959

60−data FLang = LANG_C

60+data FCallType = FStatic | FObject | FConstructor

61+ deriving (Show, Eq)

62+

63+data FLang = LANG_C | LANG_JAVA FCallType

6164 deriving (Show, Eq)

6265

6366data FType = FArith ArithTy

@@ -87,9 +90,9 @@ data LOpt = Inline | NoInline

8790addTags :: Int -> [(Name, LDecl)] -> (Int, [(Name, LDecl)])

8891addTags i ds = tag i ds []

8992 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)

9194 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)

9396 tag i (x : as) acc = tag i as (x : acc)

9497 tag i [] acc = (i, reverse acc)

9598

@@ -103,7 +106,7 @@ liftAll :: [(Name, LDecl)] -> [(Name, LDecl)]

103106liftAll xs = concatMap (\ (x, d) -> lambdaLift x d) xs

104107

105108lambdaLift :: Name -> LDecl -> [(Name, LDecl)]

106−lambdaLift n (LFun _ _ args e)

109+lambdaLift n (LFun _ _ args e)

107110 = let (e', (LS _ _ decls)) = runState (lift args e) (LS n 0 []) in

108111 (n, LFun [] n args e') : decls

109112lambdaLift n x = [(n, x)]

@@ -129,7 +132,7 @@ lift env (LApp tc f args) = do f' <- lift env f

129132lift env (LLazyApp n args) = do args' <- mapM (lift env) args

130133 return (LLazyApp n args')

131134lift 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))

133136-- = lift env (LLazyApp f args)

134137lift env (LLazyExp e) = do e' <- lift env e

135138 let usedArgs = nub $ usedIn env e'

@@ -137,7 +140,7 @@ lift env (LLazyExp e) = do e' <- lift env e

137140 addFn fn (LFun [NoInline] fn usedArgs e')

138141 return (LLazyApp fn (map (LV . Glob) usedArgs))

139142lift env (LForce e) = do e' <- lift env e

140− return (LForce e')

143+ return (LForce e')

141144lift env (LLet n v e) = do v' <- lift env v

142145 e' <- lift (env ++ [n]) e

143146 return (LLet n v' e')

@@ -177,8 +180,8 @@ usedArg env n | n `elem` env = [n]

177180 | otherwise = []

178181

179182usedIn :: [Name] -> LExp -> [Name]

180−usedIn env (LV (Glob n)) = usedArg env n

181−usedIn env (LApp _ e args) = usedIn env e ++ concatMap (usedIn env) args

183+usedIn env (LV (Glob n)) = usedArg env n

184+usedIn env (LApp _ e args) = usedIn env e ++ concatMap (usedIn env) args

182185usedIn env (LLazyApp n args) = concatMap (usedIn env) args ++ usedArg env n

183186usedIn env (LLazyExp e) = usedIn env e

184187usedIn env (LForce e) = usedIn env e

@@ -202,7 +205,7 @@ instance Show LExp where

202205 showSep ", " (map (show' env) args) ++")"

203206 show' env (LApp _ e args) = show' env e ++ "(" ++

204207 showSep ", " (map (show' env) args) ++")"

205− show' env (LLazyExp e) = "%lazy(" ++ show' env e ++ ")"

208+ show' env (LLazyExp e) = "%lazy(" ++ show' env e ++ ")"

206209 show' env (LForce e) = "%force(" ++ show' env e ++ ")"

207210 show' env (LLet n v e) = "let " ++ show n ++ " = " ++ show' env v ++ " in " ++

208211 show' (env ++ [show n]) e

@@ -219,7 +222,7 @@ instance Show LExp where

219222 show' env (LError str) = "error " ++ show str

220223 show' env LNothing = "____"

221224

222− showAlt env (LConCase _ n args e)

225+ showAlt env (LConCase _ n args e)

223226 = show n ++ "(" ++ showSep ", " (map show args) ++ ") => "

224227 ++ show' env e

225228 showAlt env (LConstCase c e) = show c ++ " => " ++ show' env e