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