home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume21 / p2c / part10 < prev    next >
Text File  |  1990-04-05  |  34KB  |  1,202 lines
  1. Subject:  v21i055:  Pascal to C translator, Part10/32
  2. Newsgroups: comp.sources.unix
  3. Approved: rsalz@uunet.UU.NET
  4. X-Checksum-Snefru: fe92997f dac1df9a 2ff3c79f dc5efb99
  5.  
  6. Submitted-by: Dave Gillespie <daveg@csvax.caltech.edu>
  7. Posting-number: Volume 21, Issue 55
  8. Archive-name: p2c/part10
  9.  
  10. #! /bin/sh
  11. # This is a shell archive.  Remove anything before this line, then unpack
  12. # it by saving it into a file and typing "sh file".  To overwrite existing
  13. # files, type "sh file -c".  You can also feed this as standard input via
  14. # unshar, or by typing "sh <file", e.g..  If this archive is complete, you
  15. # will see the following message at the end:
  16. #        "End of archive 10 (of 32)."
  17. # Contents:  src/citmods.c
  18. # Wrapped by rsalz@litchi.bbn.com on Mon Mar 26 14:29:34 1990
  19. PATH=/bin:/usr/bin:/usr/ucb ; export PATH
  20. if test -f 'src/citmods.c' -a "${1}" != "-c" ; then 
  21.   echo shar: Will not clobber existing file \"'src/citmods.c'\"
  22. else
  23. echo shar: Extracting \"'src/citmods.c'\" \(31407 characters\)
  24. sed "s/^X//" >'src/citmods.c' <<'END_OF_FILE'
  25. X/* "p2c", a Pascal to C translator.
  26. X   Copyright (C) 1989 David Gillespie.
  27. X   Author's address: daveg@csvax.caltech.edu; 256-80 Caltech/Pasadena CA 91125.
  28. X
  29. XThis program is free software; you can redistribute it and/or modify
  30. Xit under the terms of the GNU General Public License as published by
  31. Xthe Free Software Foundation (any version).
  32. X
  33. XThis program is distributed in the hope that it will be useful,
  34. Xbut WITHOUT ANY WARRANTY; without even the implied warranty of
  35. XMERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  36. XGNU General Public License for more details.
  37. X
  38. XYou should have received a copy of the GNU General Public License
  39. Xalong with this program; see the file COPYING.  If not, write to
  40. Xthe Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
  41. X
  42. X
  43. X
  44. X#define PROTO_CITMODS_C
  45. X#include "trans.h"
  46. X
  47. X
  48. X
  49. X/* The following functions define special translations for several
  50. X * HP Pascal modules developed locally at Caltech.  For non-Caltech
  51. X * readers this file will serve mainly as a body of examples.
  52. X *
  53. X * The FuncMacro mechanism (introduced after this file was written)
  54. X * provides a simpler method for cases where the function translates
  55. X * into some fixed C equivalent.
  56. X */
  57. X
  58. X
  59. X
  60. X
  61. X/* NEWASM functions */
  62. X
  63. X
  64. X/* na_fillbyte: equivalent to memset, though convert_size is used to
  65. X * generalize the size a bit:  na_fillbyte(a, 0, 80) where a is an array
  66. X * of integers (4 bytes in HP Pascal) will be translated to
  67. X * memset(a, 0, 20 * sizeof(int)).
  68. X */
  69. X
  70. XStatic Stmt *proc_na_fillbyte(ex)
  71. XExpr *ex;
  72. X{
  73. X    ex->args[0] = gentle_cast(ex->args[0], tp_anyptr);
  74. X    ex->args[2] = convert_size(argbasetype(ex->args[0]), ex->args[2], "NA_FILLBYTE");
  75. X    return makestmt_call(makeexpr_bicall_3("memset", tp_void,
  76. X                                           ex->args[0],
  77. X                                           makeexpr_arglong(ex->args[1], 0),
  78. X                                           makeexpr_arglong(ex->args[2], (size_t_long != 0))));
  79. X}
  80. X
  81. X
  82. X
  83. X/* This function fills with a 32-bit pattern.  If all four bytes of the
  84. X * pattern are equal, memset is used, otherwise the na_fill call is
  85. X * left unchanged.
  86. X */
  87. X
  88. XStatic Stmt *proc_na_fill(ex)
  89. XExpr *ex;
  90. X{
  91. X    unsigned long ul;
  92. X    Symbol *sym;
  93. X
  94. X    ex->args[0] = gentle_cast(ex->args[0], tp_anyptr);
  95. X    ex->args[2] = convert_size(argbasetype(ex->args[0]), ex->args[2], "NA_FILL");
  96. X    if (!strcmp(((Meaning *)ex->val.i)->sym->name, "NA_FILLP")) {
  97. X        sym = findsymbol("NA_FILL");
  98. X        if (sym->mbase)
  99. X            ex->val.i = (long)sym->mbase;
  100. X    }
  101. X    if (isliteralconst(ex->args[1], NULL) != 2)
  102. X        return makestmt_call(ex);
  103. X    ul = ex->args[1]->val.i;
  104. X    if ((((ul >> 16) ^ ul) & 0xffff) ||    /* all four bytes must be the same */
  105. X        (((ul >> 8) ^ ul) & 0xff))
  106. X        return makestmt_call(ex);
  107. X    ex->args[1]->val.i &= 0xff;
  108. X    return makestmt_call(makeexpr_bicall_3("memset", tp_void,
  109. X                                           ex->args[0],
  110. X                                           makeexpr_arglong(ex->args[1], 0),
  111. X                                           makeexpr_arglong(ex->args[2], (size_t_long != 0))));
  112. X}
  113. X
  114. X
  115. X
  116. XStatic Stmt *proc_na_move(ex)
  117. XExpr *ex;
  118. X{
  119. X    ex->args[0] = gentle_cast(ex->args[0], tp_anyptr);   /* source */
  120. X    ex->args[1] = gentle_cast(ex->args[1], tp_anyptr);   /* dest */
  121. X    ex->args[2] = convert_size(choosetype(argbasetype(ex->args[0]),
  122. X                                          argbasetype(ex->args[1])), ex->args[2], "NA_MOVE");
  123. X    return makestmt_call(makeexpr_bicall_3("memmove", tp_void,
  124. X                                           ex->args[1],
  125. X                                           ex->args[0],
  126. X                                           makeexpr_arglong(ex->args[2], (size_t_long != 0))));
  127. X}
  128. X
  129. X
  130. X
  131. X/* This just generalizes the size and leaves the function call alone,
  132. X * except that na_exchp (a version using pointer args) is transformed
  133. X * to na_exch (a version using VAR args, equivalent in C).
  134. X */
  135. X
  136. XStatic Stmt *proc_na_exch(ex)
  137. XExpr *ex;
  138. X{
  139. X    Symbol *sym;
  140. X
  141. X    ex->args[0] = gentle_cast(ex->args[0], tp_anyptr);
  142. X    ex->args[1] = gentle_cast(ex->args[1], tp_anyptr);
  143. X    ex->args[2] = convert_size(choosetype(argbasetype(ex->args[0]),
  144. X                                          argbasetype(ex->args[1])), ex->args[2], "NA_EXCH");
  145. X    if (!strcmp(((Meaning *)ex->val.i)->sym->name, "NA_EXCHP")) {
  146. X        sym = findsymbol("NA_EXCH");
  147. X        if (sym->mbase)
  148. X            ex->val.i = (long)sym->mbase;
  149. X    }
  150. X    return makestmt_call(ex);
  151. X}
  152. X
  153. X
  154. X
  155. XStatic Expr *func_na_comp(ex)
  156. XExpr *ex;
  157. X{
  158. X    ex->args[0] = gentle_cast(ex->args[0], tp_anyptr);
  159. X    ex->args[1] = gentle_cast(ex->args[1], tp_anyptr);
  160. X    ex->args[2] = convert_size(choosetype(argbasetype(ex->args[0]),
  161. X                                          argbasetype(ex->args[1])), ex->args[2], "NA_COMP");
  162. X    return makeexpr_bicall_3("memcmp", tp_int,
  163. X                             ex->args[0],
  164. X                             ex->args[1],
  165. X                             makeexpr_arglong(ex->args[2], (size_t_long != 0)));
  166. X}
  167. X
  168. X
  169. X
  170. XStatic Expr *func_na_scaneq(ex)
  171. XExpr *ex;
  172. X{
  173. X    Symbol *sym;
  174. X
  175. X    ex->args[0] = gentle_cast(ex->args[0], tp_anyptr);
  176. X    ex->args[2] = convert_size(argbasetype(ex->args[0]), ex->args[2], "NA_SCANEQ");
  177. X    if (!strcmp(((Meaning *)ex->val.i)->sym->name, "NA_SCANEQP")) {
  178. X        sym = findsymbol("NA_SCANEQ");
  179. X        if (sym->mbase)
  180. X            ex->val.i = (long)sym->mbase;
  181. X    }
  182. X    return ex;
  183. X}
  184. X
  185. X
  186. X
  187. XStatic Expr *func_na_scanne(ex)
  188. XExpr *ex;
  189. X{
  190. X    Symbol *sym;
  191. X
  192. X    ex->args[0] = gentle_cast(ex->args[0], tp_anyptr);
  193. X    ex->args[2] = convert_size(argbasetype(ex->args[0]), ex->args[2], "NA_SCANNE");
  194. X    if (!strcmp(((Meaning *)ex->val.i)->sym->name, "NA_SCANNEP")) {
  195. X        sym = findsymbol("NA_SCANNE");
  196. X        if (sym->mbase)
  197. X            ex->val.i = (long)sym->mbase;
  198. X    }
  199. X    return ex;
  200. X}
  201. X
  202. X
  203. X
  204. XStatic Stmt *proc_na_new(ex)
  205. XExpr *ex;
  206. X{
  207. X    Expr *vex, *ex2, *sz = NULL;
  208. X    Stmt *sp;
  209. X
  210. X    vex = makeexpr_hat(eatcasts(ex->args[0]), 0);
  211. X    ex2 = ex->args[1];
  212. X    if (vex->val.type->kind == TK_POINTER)
  213. X        ex2 = convert_size(vex->val.type->basetype, ex2, "NA_NEW");
  214. X    if (alloczeronil)
  215. X        sz = copyexpr(ex2);
  216. X    ex2 = makeexpr_bicall_1(mallocname, tp_anyptr, ex2);
  217. X    sp = makestmt_assign(copyexpr(vex), ex2);
  218. X    if (malloccheck) {
  219. X        sp = makestmt_seq(sp, makestmt_if(makeexpr_rel(EK_EQ, copyexpr(vex), makeexpr_nil()),
  220. X                                          makestmt_call(makeexpr_bicall_1(name_ESCAPE, tp_int, 
  221. X                                                                          makeexpr_long(-2))),
  222. X                                          NULL));
  223. X    }
  224. X    if (sz && !isconstantexpr(sz)) {
  225. X        if (alloczeronil == 2)
  226. X            note("Called NA_NEW with variable argument [500]");
  227. X        sp = makestmt_if(makeexpr_rel(EK_NE, sz, makeexpr_long(0)),
  228. X                         sp,
  229. X                         makestmt_assign(vex, makeexpr_nil()));
  230. X    } else
  231. X        freeexpr(vex);
  232. X    return sp;
  233. X}
  234. X
  235. X
  236. X
  237. XStatic Stmt *proc_na_dispose(ex)
  238. XExpr *ex;
  239. X{
  240. X    Stmt *sp;
  241. X    Expr *vex;
  242. X
  243. X    vex = makeexpr_hat(eatcasts(ex->args[0]), 0);
  244. X    sp = makestmt_call(makeexpr_bicall_1(freename, tp_void, copyexpr(vex)));
  245. X    if (alloczeronil) {
  246. X        sp = makestmt_if(makeexpr_rel(EK_NE, vex, makeexpr_nil()),
  247. X                         sp, NULL);
  248. X    } else
  249. X        freeexpr(vex);
  250. X    return sp;
  251. X}
  252. X
  253. X
  254. X
  255. X/* These functions provide functionality similar to alloca; we just warn
  256. X * about them here since alloca would not have been portable enough for
  257. X * our purposes anyway.
  258. X */
  259. X
  260. XStatic Stmt *proc_na_alloc(ex)
  261. XExpr *ex;
  262. X{
  263. X    Expr *ex2;
  264. X
  265. X    note("Call to NA_ALLOC [501]");
  266. X    ex->args[0] = eatcasts(ex->args[0]);
  267. X    ex2 = ex->args[0];
  268. X    if (ex2->val.type->kind == TK_POINTER &&
  269. X    ex2->val.type->basetype->kind == TK_POINTER)
  270. X        ex->args[1] = convert_size(ex2->val.type->basetype->basetype,
  271. X                   ex->args[1], "NA_ALLOC");
  272. X    return makestmt_call(ex);
  273. X}
  274. X
  275. X
  276. X
  277. XStatic Stmt *proc_na_outeralloc(ex)
  278. XExpr *ex;
  279. X{
  280. X    note("Call to NA_OUTERALLOC [502]");
  281. X    return makestmt_call(ex);
  282. X}
  283. X
  284. X
  285. X
  286. XStatic Stmt *proc_na_free(ex)
  287. XExpr *ex;
  288. X{
  289. X    note("Call to NA_FREE [503]");
  290. X    return makestmt_call(ex);
  291. X}
  292. X
  293. X
  294. X
  295. X
  296. XStatic Expr *func_na_memavail(ex)
  297. XExpr *ex;
  298. X{
  299. X    freeexpr(ex);
  300. X    return makeexpr_bicall_0("memavail", tp_integer);
  301. X}
  302. X
  303. X
  304. X
  305. X
  306. X/* A simple collection of bitwise operations. */
  307. X
  308. XStatic Expr *func_na_and(ex)
  309. XExpr *ex;
  310. X{
  311. X    Expr *ex0, *ex1;
  312. X
  313. X    ex0 = makeexpr_unlongcast(ex->args[0]);
  314. X    ex1 = makeexpr_unlongcast(ex->args[1]);
  315. X    return makeexpr_bin(EK_BAND, tp_integer, ex0, ex1);
  316. X}
  317. X
  318. X
  319. X
  320. XStatic Expr *func_na_bic(ex)
  321. XExpr *ex;
  322. X{
  323. X    Expr *ex0, *ex1;
  324. X
  325. X    ex0 = makeexpr_unlongcast(ex->args[0]);
  326. X    ex1 = makeexpr_unlongcast(ex->args[1]);
  327. X    return makeexpr_bin(EK_BAND, tp_integer, 
  328. X                        ex0,
  329. X                        makeexpr_un(EK_BNOT, ex1->val.type, ex1));
  330. X}
  331. X
  332. X
  333. X
  334. XStatic Expr *func_na_or(ex)
  335. XExpr *ex;
  336. X{
  337. X    Expr *ex0, *ex1;
  338. X
  339. X    ex0 = makeexpr_unlongcast(ex->args[0]);
  340. X    ex1 = makeexpr_unlongcast(ex->args[1]);
  341. X    return makeexpr_bin(EK_BOR, tp_integer, ex0, ex1);
  342. X}
  343. X
  344. X
  345. X
  346. XStatic Expr *func_na_xor(ex)
  347. XExpr *ex;
  348. X{
  349. X    Expr *ex0, *ex1;
  350. X
  351. X    ex0 = makeexpr_unlongcast(ex->args[0]);
  352. X    ex1 = makeexpr_unlongcast(ex->args[1]);
  353. X    return makeexpr_bin(EK_BXOR, tp_integer, ex0, ex1);
  354. X}
  355. X
  356. X
  357. X
  358. XStatic Expr *func_na_not(ex)
  359. XExpr *ex;
  360. X{
  361. X    ex = makeexpr_unlongcast(grabarg(ex, 0));
  362. X    return makeexpr_un(EK_BNOT, ex->val.type, ex);
  363. X}
  364. X
  365. X
  366. X
  367. XStatic Expr *func_na_mask(ex)
  368. XExpr *ex;
  369. X{
  370. X    Expr *ex0, *ex1;
  371. X
  372. X    ex0 = makeexpr_unlongcast(ex->args[0]);
  373. X    ex1 = makeexpr_unlongcast(ex->args[1]);
  374. X    ex = makeexpr_bin(EK_BAND, tp_integer, ex0, ex1);
  375. X    return makeexpr_rel(EK_NE, ex, makeexpr_long(0));
  376. X}
  377. X
  378. X
  379. X
  380. XStatic int check0_31(ex)
  381. XExpr *ex;
  382. X{
  383. X    if (isliteralconst(ex, NULL) == 2)
  384. X        return (ex->val.i >= 0 && ex->val.i <= 31);
  385. X    else
  386. X        return (assumebits != 0);
  387. X}
  388. X
  389. X
  390. X
  391. X/* This function is defined to test a bit of an integer, returning false
  392. X * if the bit number is out of range.  It is only safe to use C bitwise
  393. X * ops if we can prove the bit number is always in range, or if the
  394. X * user has asked us to assume that it is.  Lacking flow analysis,
  395. X * we settle for checking constants only.
  396. X */
  397. X
  398. XStatic Expr *func_na_test(ex)
  399. XExpr *ex;
  400. X{
  401. X    Expr *ex1;
  402. X    int longness;
  403. X
  404. X    if (!check0_31(ex->args[0]))
  405. X        return ex;
  406. X    ex1 = makeexpr_unlongcast(ex->args[1]);
  407. X    longness = (exprlongness(ex1) != 0);
  408. X    return makeexpr_rel(EK_NE,
  409. X                        makeexpr_bin(EK_BAND, tp_integer,
  410. X                                     ex1,
  411. X                                     makeexpr_bin(EK_LSH, tp_integer,
  412. X                                                  makeexpr_longcast(makeexpr_long(1), longness),
  413. X                                                  makeexpr_unlongcast(ex->args[0]))),
  414. X                        makeexpr_long(0));
  415. X}
  416. X
  417. X
  418. X
  419. XStatic Stmt *proc_na_set(ex)
  420. XExpr *ex;
  421. X{
  422. X    Stmt *sp;
  423. X    Expr *vex;
  424. X    Meaning *tvar;
  425. X
  426. X    if (!check0_31(ex->args[0]))
  427. X        return makestmt_call(ex);
  428. X    if (!nosideeffects(ex->args[1], 1)) {
  429. X        tvar = makestmttempvar(ex->args[1]->val.type, name_TEMP);
  430. X        sp = makestmt_assign(makeexpr_var(tvar), ex->args[1]);
  431. X        vex = makeexpr_hat(makeexpr_var(tvar), 0);
  432. X    } else {
  433. X        sp = NULL;
  434. X        vex = makeexpr_hat(ex->args[1], 0);
  435. X    }
  436. X    sp = makestmt_seq(sp,
  437. X                      makestmt_assign(vex,
  438. X                                      makeexpr_bin(EK_BOR, tp_integer,
  439. X                                                   copyexpr(vex),
  440. X                                                   makeexpr_bin(EK_LSH, tp_integer,
  441. X                                                                makeexpr_longcast(makeexpr_long(1), 1),
  442. X                                                                makeexpr_unlongcast(ex->args[0])))));
  443. X    return sp;
  444. X}
  445. X
  446. X
  447. X
  448. XStatic Stmt *proc_na_clear(ex)
  449. XExpr *ex;
  450. X{
  451. X    Stmt *sp;
  452. X    Expr *vex;
  453. X    Meaning *tvar;
  454. X
  455. X    if (!check0_31(ex->args[0]))
  456. X        return makestmt_call(ex);
  457. X    if (!nosideeffects(ex->args[1], 1)) {
  458. X        tvar = makestmttempvar(ex->args[1]->val.type, name_TEMP);
  459. X        sp = makestmt_assign(makeexpr_var(tvar), ex->args[1]);
  460. X        vex = makeexpr_hat(makeexpr_var(tvar), 0);
  461. X    } else {
  462. X        sp = NULL;
  463. X        vex = makeexpr_hat(ex->args[1], 0);
  464. X    }
  465. X    sp = makestmt_seq(sp,
  466. X                      makestmt_assign(vex,
  467. X                                      makeexpr_bin(EK_BAND, tp_integer,
  468. X                                                   copyexpr(vex),
  469. X                                                   makeexpr_un(EK_BNOT, tp_integer,
  470. X                                                       makeexpr_bin(EK_LSH, tp_integer,
  471. X                                                                    makeexpr_longcast(makeexpr_long(1), 1),
  472. X                                                                    makeexpr_unlongcast(ex->args[0]))))));
  473. X    return sp;
  474. X}
  475. X
  476. X
  477. X
  478. XStatic Expr *func_na_po2(ex)
  479. XExpr *ex;
  480. X{
  481. X    if (!check0_31(ex->args[0]))
  482. X        return ex;
  483. X    return makeexpr_bin(EK_LSH, tp_integer,
  484. X                        makeexpr_longcast(makeexpr_long(1), 1),
  485. X                        makeexpr_unlongcast(grabarg(ex, 0)));
  486. X}
  487. X
  488. X
  489. X
  490. XStatic Expr *func_na_lobits(ex)
  491. XExpr *ex;
  492. X{
  493. X    if (!check0_31(ex->args[0]))
  494. X        return ex;
  495. X    return makeexpr_un(EK_BNOT, tp_integer,
  496. X                       makeexpr_bin(EK_LSH, tp_integer,
  497. X                                    makeexpr_longcast(makeexpr_long(-1), 1),
  498. X                                    makeexpr_unlongcast(grabarg(ex, 0))));
  499. X}
  500. X
  501. X
  502. X
  503. XStatic Expr *func_na_hibits(ex)
  504. XExpr *ex;
  505. X{
  506. X    if (!check0_31(ex->args[0]))
  507. X        return ex;
  508. X    return makeexpr_bin(EK_LSH, tp_integer,
  509. X                        makeexpr_longcast(makeexpr_long(-1), 1),
  510. X                        makeexpr_minus(makeexpr_long(32),
  511. X                                       makeexpr_unlongcast(grabarg(ex, 0))));
  512. X}
  513. X
  514. X
  515. X
  516. X/* This function does an arithmetic shift left, or right for negative shift
  517. X * count.  We translate into a C shift only if we are confident of the
  518. X * sign of the shift count.
  519. X */
  520. X
  521. XStatic Expr *func_na_asl(ex)
  522. XExpr *ex;
  523. X{
  524. X    Expr *ex2;
  525. X
  526. X    ex2 = makeexpr_unlongcast(copyexpr(ex->args[0]));
  527. X    if (expr_is_neg(ex2)) {
  528. X        if (signedshift == 0 || signedshift == 2)
  529. X            return ex;
  530. X    if (possiblesigns(ex2) & 4) {
  531. X            if (assumesigns)
  532. X                note("Assuming count for NA_ASL is negative [504]");
  533. X            else
  534. X                return ex;
  535. X        }
  536. X        if (signedshift != 1)
  537. X            note("Assuming >> is an arithmetic shift [505]");
  538. X        return makeexpr_bin(EK_RSH, tp_integer,
  539. X                grabarg(ex, 1), makeexpr_neg(ex2));
  540. X    } else {
  541. X    if (possiblesigns(ex2) & 1) {
  542. X            if (assumesigns)
  543. X                note("Assuming count for NA_ASL is positive [504]");
  544. X            else
  545. X                return ex;
  546. X        }
  547. X        return makeexpr_bin(EK_LSH, tp_integer, grabarg(ex, 1), ex2);
  548. X    }
  549. X}
  550. X
  551. X
  552. X
  553. XStatic Expr *func_na_lsl(ex)
  554. XExpr *ex;
  555. X{
  556. X    Expr *ex2;
  557. X
  558. X    ex2 = makeexpr_unlongcast(copyexpr(ex->args[0]));
  559. X    if (expr_is_neg(ex2)) {
  560. X    if (possiblesigns(ex2) & 4) {
  561. X            if (assumesigns)
  562. X                note("Assuming count for NA_LSL is negative [506]");
  563. X            else
  564. X                return ex;
  565. X        }
  566. X        return makeexpr_bin(EK_RSH, tp_integer, 
  567. X                            force_unsigned(grabarg(ex, 1)),
  568. X                makeexpr_neg(ex2));
  569. X    } else {
  570. X    if (possiblesigns(ex2) & 1) {
  571. X            if (assumesigns)
  572. X                note("Assuming count for NA_LSL is positive [506]");
  573. X            else
  574. X                return ex;
  575. X        }
  576. X        return makeexpr_bin(EK_LSH, tp_integer, grabarg(ex, 1), ex2);
  577. X    }
  578. X}
  579. X
  580. X
  581. X
  582. X/* These bit-field operations were generalized slightly on the way to C;
  583. X * they used to perform D &= S and now perform D = S1 & S2.
  584. X */
  585. X
  586. XStatic Stmt *proc_na_bfand(ex)
  587. XExpr *ex;
  588. X{
  589. X    Stmt *sp;
  590. X    Meaning *tvar;
  591. X
  592. X    if (!nosideeffects(ex->args[2], 1)) {
  593. X        tvar = makestmttempvar(ex->args[2]->val.type, name_TEMP);
  594. X        sp = makestmt_assign(makeexpr_var(tvar), ex->args[2]);
  595. X        ex->args[2] = makeexpr_var(tvar);
  596. X    } else
  597. X        sp = NULL;
  598. X    insertarg(&ex, 1, copyexpr(ex->args[2]));
  599. X    return makestmt_seq(sp, makestmt_call(ex));
  600. X}
  601. X
  602. X
  603. X
  604. XStatic Stmt *proc_na_bfbic(ex)
  605. XExpr *ex;
  606. X{
  607. X    return proc_na_bfand(ex);
  608. X}
  609. X
  610. X
  611. X
  612. XStatic Stmt *proc_na_bfor(ex)
  613. XExpr *ex;
  614. X{
  615. X    return proc_na_bfand(ex);
  616. X}
  617. X
  618. X
  619. X
  620. XStatic Stmt *proc_na_bfxor(ex)
  621. XExpr *ex;
  622. X{
  623. X    return proc_na_bfand(ex);
  624. X}
  625. X
  626. X
  627. X
  628. XStatic Expr *func_imin(ex)
  629. XExpr *ex;
  630. X{
  631. X    return makeexpr_bicall_2("P_imin2", tp_integer,
  632. X                             ex->args[0], ex->args[1]);
  633. X}
  634. X
  635. X
  636. X
  637. XStatic Expr *func_imax(ex)
  638. XExpr *ex;
  639. X{
  640. X    return makeexpr_bicall_2("P_imax2", tp_integer,
  641. X                             ex->args[0], ex->args[1]);
  642. X}
  643. X
  644. X
  645. X
  646. X/* Unsigned non-overflowing arithmetic functions in Pascal; we translate
  647. X * into plain arithmetic in C and assume C doesn't check for overflow.
  648. X * (A valid assumption in the case when this was used.)
  649. X */
  650. X
  651. XStatic Expr *func_na_add(ex)
  652. XExpr *ex;
  653. X{
  654. X    return makeexpr_plus(makeexpr_unlongcast(ex->args[0]),
  655. X                         makeexpr_unlongcast(ex->args[1]));
  656. X}
  657. X
  658. X
  659. X
  660. XStatic Expr *func_na_sub(ex)
  661. XExpr *ex;
  662. X{
  663. X    return makeexpr_minus(makeexpr_unlongcast(ex->args[0]),
  664. X                          makeexpr_unlongcast(ex->args[1]));
  665. X}
  666. X
  667. X
  668. X
  669. Xextern Stmt *proc_exit();    /* from funcs.c */
  670. X
  671. XStatic Stmt *proc_return()
  672. X{
  673. X    return proc_exit();
  674. X}
  675. X
  676. X
  677. X
  678. XStatic Expr *func_charupper(ex)
  679. XExpr *ex;
  680. X{
  681. X    return makeexpr_bicall_1("toupper", tp_char,
  682. X                             grabarg(ex, 0));
  683. X}
  684. X
  685. X
  686. X
  687. XStatic Expr *func_charlower(ex)
  688. XExpr *ex;
  689. X{
  690. X    return makeexpr_bicall_1("tolower", tp_char,
  691. X                             grabarg(ex, 0));
  692. X}
  693. X
  694. X
  695. X
  696. X/* Convert an integer to its string representation.  We produce a sprintf
  697. X * into a temporary variable; the temporary will probably be eliminated
  698. X * as the surrounding code is translated.
  699. X */
  700. X
  701. XStatic Expr *func_strint(ex)
  702. XExpr *ex;
  703. X{
  704. X    Expr *ex2;
  705. X
  706. X    ex2 = makeexpr_forcelongness(ex->args[1]);
  707. X    return makeexpr_bicall_3("sprintf", ex->val.type,
  708. X                             ex->args[0],
  709. X                             makeexpr_string((exprlongness(ex2) > 0) ? "%ld" : "%d"),
  710. X                             ex2);
  711. X}
  712. X
  713. X
  714. X
  715. XStatic Expr *func_strint2(ex)
  716. XExpr *ex;
  717. X{
  718. X    Expr *ex2, *len, *fmt;
  719. X
  720. X    if (checkconst(ex->args[2], 0) || checkconst(ex->args[2], 1))
  721. X        return func_strint(ex);
  722. X    if (expr_is_neg(ex->args[2])) {
  723. X    if (possiblesigns(ex->args[2]) & 4) {
  724. X            if (assumesigns)
  725. X                note("Assuming width for STRINT2 is negative [507]");
  726. X            else
  727. X                return ex;
  728. X        }
  729. X        ex2 = makeexpr_forcelongness(ex->args[1]);
  730. X        fmt = makeexpr_string((exprlongness(ex2) > 0) ? "%0*ld" : "%0*d");
  731. X        len = makeexpr_neg(makeexpr_longcast(ex->args[2], 0));
  732. X    } else {
  733. X    if (possiblesigns(ex->args[2]) & 1) {
  734. X            if (assumesigns)
  735. X                note("Assuming width for STRINT2 is positive [507]");
  736. X            else
  737. X                return ex;
  738. X        }
  739. X        ex2 = makeexpr_forcelongness(ex->args[1]);
  740. X        fmt = makeexpr_string((exprlongness(ex2) > 0) ? "%*ld" : "%*d");
  741. X        len = makeexpr_longcast(ex->args[2], 0);
  742. X    }
  743. X    ex = makeexpr_bicall_4("sprintf", ex->val.type,
  744. X                           ex->args[0], fmt, len, ex2);
  745. X    return cleansprintf(ex);
  746. X}
  747. X
  748. X
  749. X
  750. XStatic Expr *func_strhex(ex)
  751. XExpr *ex;
  752. X{
  753. X    Expr *ex2, *ex3;
  754. X    Value val;
  755. X
  756. X    if (isliteralconst(ex->args[2], &val) == 2) {
  757. X        ex2 = makeexpr_forcelongness(ex->args[1]);
  758. X        if (val.i < 1 || val.i > 8) {
  759. X            ex = makeexpr_bicall_3("sprintf", ex->val.type,
  760. X                                   ex->args[0],
  761. X                                   makeexpr_string((exprlongness(ex2) > 0) ? "%lX" : "%X"),
  762. X                                   ex2);
  763. X        } else {
  764. X            if (val.i < 8) {
  765. X                ex3 = makeexpr_long((1 << (val.i*4)) - 1);
  766. X                insertarg(&ex3, 0, makeexpr_name("%#lx", tp_integer));
  767. X                ex2 = makeexpr_bin(EK_BAND, ex2->val.type, ex2, ex3);
  768. X            }
  769. X            ex = makeexpr_bicall_3("sprintf", ex->val.type,
  770. X                                   ex->args[0],
  771. X                                   makeexpr_string(format_d((exprlongness(ex2) > 0) ? "%%.%ldlX" :
  772. X                                                                                      "%%.%ldX",
  773. X                                                            val.i)),
  774. X                                   ex2);
  775. X        }
  776. X    }
  777. X    return ex;
  778. X}
  779. X
  780. X
  781. X
  782. XStatic Expr *func_strreal(ex)
  783. XExpr *ex;
  784. X{
  785. X    return makeexpr_bicall_3("sprintf", ex->val.type,
  786. X                             ex->args[0],
  787. X                             makeexpr_string("%g"),
  788. X                             ex->args[1]);
  789. X}
  790. X
  791. X
  792. X
  793. XStatic Expr *func_strchar(ex)
  794. XExpr *ex;
  795. X{
  796. X    return makeexpr_bicall_3("sprintf", ex->val.type,
  797. X                             ex->args[0],
  798. X                             makeexpr_string("%c"),
  799. X                             ex->args[1]);
  800. X}
  801. X
  802. X
  803. X
  804. XStatic Expr *func_strreadint(ex)
  805. XExpr *ex;
  806. X{
  807. X    return makeexpr_bicall_3("strtol", tp_integer,
  808. X                             grabarg(ex, 0), 
  809. X                             makeexpr_nil(),
  810. X                             makeexpr_long(0));
  811. X}
  812. X
  813. X
  814. X
  815. XStatic Expr *func_strreadreal(ex)
  816. XExpr *ex;
  817. X{
  818. X    return makeexpr_bicall_1("atof", tp_longreal,
  819. X                             grabarg(ex, 0));
  820. X}
  821. X
  822. X
  823. X
  824. XStatic Stmt *proc_strappendc(ex)
  825. XExpr *ex;
  826. X{
  827. X    Expr *ex2;
  828. X
  829. X    ex2 = makeexpr_hat(ex->args[0], 0);
  830. X    return makestmt_assign(ex2, makeexpr_concat(copyexpr(ex2), ex->args[1], 0));
  831. X}
  832. X
  833. X
  834. X
  835. X/* Check if a string begins with a given prefix; this is easy if the
  836. X * prefix is known at compile-time.
  837. X */
  838. X
  839. XStatic Expr *func_strbegins(ex)
  840. XExpr *ex;
  841. X{
  842. X    Expr *ex1, *ex2;
  843. X
  844. X    ex1 = ex->args[0];
  845. X    ex2 = ex->args[1];
  846. X    if (ex2->kind == EK_CONST) {
  847. X        if (ex2->val.i == 1) {
  848. X            return makeexpr_rel(EK_EQ,
  849. X                                makeexpr_hat(ex1, 0),
  850. X                                makeexpr_char(ex2->val.s[0]));
  851. X        } else {
  852. X            return makeexpr_rel(EK_EQ,
  853. X                                makeexpr_bicall_3("strncmp", tp_int,
  854. X                                                  ex1,
  855. X                                                  ex2,
  856. X                                                  makeexpr_arglong(makeexpr_long(ex2->val.i), (size_t_long != 0))),
  857. X                                makeexpr_long(0));
  858. X        }
  859. X    }
  860. X    return ex;
  861. X}
  862. X
  863. X
  864. X
  865. XStatic Expr *func_strcontains(ex)
  866. XExpr *ex;
  867. X{
  868. X    return makeexpr_rel(EK_NE,
  869. X                        makeexpr_bicall_2("strpbrk", tp_strptr,
  870. X                                          ex->args[0],
  871. X                                          ex->args[1]),
  872. X                        makeexpr_nil());
  873. X}
  874. X
  875. X
  876. X
  877. X/* Extract a substring of a string.  If arguments are out-of-range, extract
  878. X * an empty or shorter substring.  Here, the length=infinity and constant
  879. X * starting index cases are handled specially.
  880. X */
  881. X
  882. XStatic Expr *func_strsub(ex)
  883. XExpr *ex;
  884. X{
  885. X    if (isliteralconst(ex->args[3], NULL) == 2 &&
  886. X        ex->args[3]->val.i >= stringceiling) {
  887. X        return makeexpr_bicall_3("sprintf", ex->val.type,
  888. X                                 ex->args[0],
  889. X                                 makeexpr_string("%s"),
  890. X                                 bumpstring(ex->args[1],
  891. X                                            makeexpr_unlongcast(ex->args[2]), 1));
  892. X    }
  893. X    if (checkconst(ex->args[2], 1)) {
  894. X        return makeexpr_addr(makeexpr_substring(ex->args[0], ex->args[1], 
  895. X                                                ex->args[2], ex->args[3]));
  896. X    }
  897. X    ex->args[2] = makeexpr_arglong(ex->args[2], 0);
  898. X    ex->args[3] = makeexpr_arglong(ex->args[3], 0);
  899. X    return ex;
  900. X}
  901. X
  902. X
  903. X
  904. XStatic Expr *func_strpart(ex)
  905. XExpr *ex;
  906. X{
  907. X    return func_strsub(ex);     /* all the special cases match */
  908. X}
  909. X
  910. X
  911. X
  912. XStatic Expr *func_strequal(ex)
  913. XExpr *ex;
  914. X{
  915. X    if (!*strcicmpname)
  916. X        return ex;
  917. X    return makeexpr_rel(EK_EQ, 
  918. X                        makeexpr_bicall_2(strcicmpname, tp_int,
  919. X                                          ex->args[0], ex->args[1]),
  920. X                        makeexpr_long(0));
  921. X}
  922. X
  923. X
  924. X
  925. XStatic Expr *func_strcmp(ex)
  926. XExpr *ex;
  927. X{
  928. X    return makeexpr_bicall_2("strcmp", tp_int, ex->args[0], ex->args[1]);
  929. X}
  930. X
  931. X
  932. X
  933. XStatic Expr *func_strljust(ex)
  934. XExpr *ex;
  935. X{
  936. X    return makeexpr_bicall_4("sprintf", ex->val.type,
  937. X                             ex->args[0],
  938. X                             makeexpr_string("%-*s"),
  939. X                             makeexpr_longcast(ex->args[2], 0),
  940. X                             ex->args[1]);
  941. X}
  942. X
  943. X
  944. X
  945. XStatic Expr *func_strrjust(ex)
  946. XExpr *ex;
  947. X{
  948. X    return makeexpr_bicall_4("sprintf", ex->val.type,
  949. X                             ex->args[0],
  950. X                             makeexpr_string("%*s"),
  951. X                             makeexpr_longcast(ex->args[2], 0),
  952. X                             ex->args[1]);
  953. X}
  954. X
  955. X
  956. X
  957. X
  958. X/* The procedure strnew(p,s) is converted into an assignment p = strdup(s). */
  959. X
  960. XStatic Stmt *proc_strnew(ex)
  961. XExpr *ex;
  962. X{
  963. X    return makestmt_assign(makeexpr_hat(ex->args[0], 0),
  964. X                           makeexpr_bicall_1("strdup", ex->args[1]->val.type,
  965. X                                             ex->args[1]));
  966. X}
  967. X
  968. X
  969. X
  970. X/* These procedures are also changed to functions returning a result. */
  971. X
  972. XStatic Stmt *proc_strlist_add(ex)
  973. XExpr *ex;
  974. X{
  975. X    return makestmt_assign(makeexpr_hat(ex->args[1], 0),
  976. X                           makeexpr_bicall_2("strlist_add", ex->args[0]->val.type->basetype,
  977. X                                             ex->args[0],
  978. X                                             ex->args[2]));
  979. X}
  980. X
  981. X
  982. X
  983. XStatic Stmt *proc_strlist_append(ex)
  984. XExpr *ex;
  985. X{
  986. X    return makestmt_assign(makeexpr_hat(ex->args[1], 0),
  987. X                           makeexpr_bicall_2("strlist_append", ex->args[0]->val.type->basetype,
  988. X                                             ex->args[0],
  989. X                                             ex->args[2]));
  990. X}
  991. X
  992. X
  993. X
  994. XStatic Stmt *proc_strlist_insert(ex)
  995. XExpr *ex;
  996. X{
  997. X    return makestmt_assign(makeexpr_hat(ex->args[1], 0),
  998. X                           makeexpr_bicall_2("strlist_insert", ex->args[0]->val.type->basetype,
  999. X                                             ex->args[0],
  1000. X                                             ex->args[2]));
  1001. X}
  1002. X
  1003. X
  1004. X
  1005. X
  1006. X
  1007. X
  1008. X
  1009. X
  1010. X
  1011. X/* NEWCI functions */
  1012. X
  1013. X
  1014. XStatic Stmt *proc_fixfname(ex)
  1015. XExpr *ex;
  1016. X{
  1017. X    if (ex->args[1]->kind == EK_CONST)
  1018. X    lwc(ex->args[1]->val.s);    /* Unix uses lower-case suffixes */
  1019. X    return makestmt_call(ex);
  1020. X}
  1021. X
  1022. X
  1023. XStatic Stmt *proc_forcefname(ex)
  1024. XExpr *ex;
  1025. X{
  1026. X    return proc_fixfname(ex);
  1027. X}
  1028. X
  1029. X
  1030. X/* In Pascal these were variables of type pointer-to-text; we translate
  1031. X * them as, e.g., &stdin.  Note that even though &stdin is not legal in
  1032. X * many systems, in the common usage of writeln(stdin^) the & will
  1033. X * cancel out in a later stage of the translation.
  1034. X */
  1035. X
  1036. XStatic Expr *func_stdin()
  1037. X{
  1038. X    return makeexpr_addr(makeexpr_var(mp_input));
  1039. X}
  1040. X
  1041. X
  1042. XStatic Expr *func_stdout()
  1043. X{
  1044. X    return makeexpr_addr(makeexpr_var(mp_output));
  1045. X}
  1046. X
  1047. X
  1048. XStatic Expr *func_stderr()
  1049. X{
  1050. X    return makeexpr_addr(makeexpr_name("stderr", tp_text));
  1051. X}
  1052. X
  1053. X
  1054. X
  1055. X
  1056. X
  1057. X
  1058. X
  1059. X
  1060. X/* MYLIB functions */
  1061. X
  1062. X
  1063. XStatic Stmt *proc_m_color(ex)
  1064. XExpr *ex;
  1065. X{
  1066. X    int i;
  1067. X    long val;
  1068. X
  1069. X    if (ex->kind == EK_PLUS) {
  1070. X        for (i = 0; i < ex->nargs; i++) {
  1071. X            if (isconstexpr(ex->args[i], &val)) {
  1072. X                if (val > 0 && (val & 15) == 0) {
  1073. X                    note("M_COLOR called with suspicious argument [508]");
  1074. X                }
  1075. X            }
  1076. X        }
  1077. X    } else if (ex->kind == EK_CONST) {
  1078. X        if (ex->val.i >= 16 && ex->val.i < 255) {    /* accept true colors and m_trans */
  1079. X            note("M_COLOR called with suspicious argument [508]");
  1080. X        }
  1081. X    }
  1082. X    return makestmt_call(ex);
  1083. X}
  1084. X
  1085. X
  1086. X
  1087. X
  1088. X
  1089. X
  1090. X
  1091. Xvoid citmods(name, defn)
  1092. Xchar *name;
  1093. Xint defn;
  1094. X{
  1095. X    if (!strcmp(name, "NEWASM")) {
  1096. X        makestandardproc("na_fillbyte", proc_na_fillbyte);
  1097. X        makestandardproc("na_fill", proc_na_fill);
  1098. X        makestandardproc("na_fillp", proc_na_fill);
  1099. X        makestandardproc("na_move", proc_na_move);
  1100. X        makestandardproc("na_movep", proc_na_move);
  1101. X        makestandardproc("na_exch", proc_na_exch);
  1102. X        makestandardproc("na_exchp", proc_na_exch);
  1103. X        makestandardfunc("na_comp", func_na_comp);
  1104. X        makestandardfunc("na_compp", func_na_comp);
  1105. X        makestandardfunc("na_scaneq", func_na_scaneq);
  1106. X        makestandardfunc("na_scaneqp", func_na_scaneq);
  1107. X        makestandardfunc("na_scanne", func_na_scanne);
  1108. X        makestandardfunc("na_scannep", func_na_scanne);
  1109. X        makestandardproc("na_new", proc_na_new);
  1110. X        makestandardproc("na_dispose", proc_na_dispose);
  1111. X        makestandardproc("na_alloc", proc_na_alloc);
  1112. X        makestandardproc("na_outeralloc", proc_na_outeralloc);
  1113. X        makestandardproc("na_free", proc_na_free);
  1114. X        makestandardfunc("na_memavail", func_na_memavail);
  1115. X        makestandardfunc("na_and", func_na_and);
  1116. X        makestandardfunc("na_bic", func_na_bic);
  1117. X        makestandardfunc("na_or", func_na_or);
  1118. X        makestandardfunc("na_xor", func_na_xor);
  1119. X        makestandardfunc("na_not", func_na_not);
  1120. X        makestandardfunc("na_mask", func_na_mask);
  1121. X        makestandardfunc("na_test", func_na_test);
  1122. X        makestandardproc("na_set", proc_na_set);
  1123. X        makestandardproc("na_clear", proc_na_clear);
  1124. X        makestandardfunc("na_po2", func_na_po2);
  1125. X        makestandardfunc("na_hibits", func_na_hibits);
  1126. X        makestandardfunc("na_lobits", func_na_lobits);
  1127. X        makestandardfunc("na_asl", func_na_asl);
  1128. X        makestandardfunc("na_lsl", func_na_lsl);
  1129. X        makestandardproc("na_bfand", proc_na_bfand);
  1130. X        makestandardproc("na_bfbic", proc_na_bfbic);
  1131. X        makestandardproc("na_bfor", proc_na_bfor);
  1132. X        makestandardproc("na_bfxor", proc_na_bfxor);
  1133. X        makestandardfunc("imin", func_imin);
  1134. X        makestandardfunc("imax", func_imax);
  1135. X        makestandardfunc("na_add", func_na_add);
  1136. X        makestandardfunc("na_sub", func_na_sub);
  1137. X        makestandardproc("return", proc_return);
  1138. X        makestandardfunc("charupper", func_charupper);
  1139. X        makestandardfunc("charlower", func_charlower);
  1140. X        makestandardfunc("strint", func_strint);
  1141. X        makestandardfunc("strint2", func_strint2);
  1142. X        makestandardfunc("strhex", func_strhex);
  1143. X        makestandardfunc("strreal", func_strreal);
  1144. X        makestandardfunc("strchar", func_strchar);
  1145. X        makestandardfunc("strreadint", func_strreadint);
  1146. X        makestandardfunc("strreadreal", func_strreadreal);
  1147. X        makestandardproc("strappendc", proc_strappendc);
  1148. X        makestandardfunc("strbegins", func_strbegins);
  1149. X        makestandardfunc("strcontains", func_strcontains);
  1150. X        makestandardfunc("strsub", func_strsub);
  1151. X        makestandardfunc("strpart", func_strpart);
  1152. X        makestandardfunc("strequal", func_strequal);
  1153. X        makestandardfunc("strcmp", func_strcmp);
  1154. X        makestandardfunc("strljust", func_strljust);
  1155. X        makestandardfunc("strrjust", func_strrjust);
  1156. X        makestandardproc("strnew", proc_strnew);
  1157. X        makestandardproc("strlist_add", proc_strlist_add);
  1158. X        makestandardproc("strlist_append", proc_strlist_append);
  1159. X        makestandardproc("strlist_insert", proc_strlist_insert);
  1160. X    } else if (!strcmp(name, "NEWCI")) {
  1161. X    makestandardproc("fixfname", proc_fixfname);
  1162. X    makestandardproc("forcefname", proc_forcefname);
  1163. X        makestandardfunc("stdin", func_stdin);
  1164. X        makestandardfunc("stdout", func_stdout);
  1165. X        makestandardfunc("stderr", func_stderr);
  1166. X    } else if (!strcmp(name, "MYLIB")) {
  1167. X        makestandardproc("m_color", proc_m_color);
  1168. X    }
  1169. X}
  1170. X
  1171. X
  1172. X
  1173. X
  1174. X/* End. */
  1175. X
  1176. X
  1177. X
  1178. END_OF_FILE
  1179. if test 31407 -ne `wc -c <'src/citmods.c'`; then
  1180.     echo shar: \"'src/citmods.c'\" unpacked with wrong size!
  1181. fi
  1182. # end of 'src/citmods.c'
  1183. fi
  1184. echo shar: End of archive 10 \(of 32\).
  1185. cp /dev/null ark10isdone
  1186. MISSING=""
  1187. for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 ; do
  1188.     if test ! -f ark${I}isdone ; then
  1189.     MISSING="${MISSING} ${I}"
  1190.     fi
  1191. done
  1192. if test "${MISSING}" = "" ; then
  1193.     echo You have unpacked all 32 archives.
  1194.     echo "Now see PACKNOTES and the README"
  1195.     rm -f ark[1-9]isdone ark[1-9][0-9]isdone
  1196. else
  1197.     echo You still need to unpack the following archives:
  1198.     echo "        " ${MISSING}
  1199. fi
  1200. ##  End of shell archive.
  1201. exit 0
  1202.