home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Professional / OS2PRO194.ISO / os2 / prgramer / pascal2c / funcs.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-08-03  |  146.0 KB  |  5,406 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_FUNCS_C
  21. #include "trans.h"
  22.  
  23.  
  24.  
  25.  
  26. Static Strlist *enumnames;
  27. Static int enumnamecount;
  28.  
  29.  
  30.  
  31. void setup_funcs()
  32. {
  33.     enumnames = NULL;
  34.     enumnamecount = 0;
  35. }
  36.  
  37.  
  38.  
  39.  
  40.  
  41. int isvar(ex, mp)
  42. Expr *ex;
  43. Meaning *mp;
  44. {
  45.     return (ex->kind == EK_VAR && (Meaning *)ex->val.i == mp);
  46. }
  47.  
  48.  
  49.  
  50.  
  51. char *getstring(ex)
  52. Expr *ex;
  53. {
  54.     ex = makeexpr_stringify(ex);
  55.     if (ex->kind != EK_CONST || ex->val.type->kind != TK_STRING) {
  56.         intwarning("getstring", "Not a string literal [206]");
  57.     return "";
  58.     }
  59.     return ex->val.s;
  60. }
  61.  
  62.  
  63.  
  64.  
  65. Expr *p_parexpr(target)
  66. Type *target;
  67. {
  68.     Expr *ex;
  69.  
  70.     if (wneedtok(TOK_LPAR)) {
  71.     ex = p_expr(target);
  72.     if (!wneedtok(TOK_RPAR))
  73.         skippasttotoken(TOK_RPAR, TOK_SEMI);
  74.     } else
  75.     ex = p_expr(target);
  76.     return ex;
  77. }
  78.  
  79.  
  80.  
  81. Type *argbasetype(ex)
  82. Expr *ex;
  83. {
  84.     if (ex->kind == EK_CAST)
  85.         ex = ex->args[0];
  86.     if (ex->val.type->kind == TK_POINTER)
  87.         return ex->val.type->basetype;
  88.     else
  89.         return ex->val.type;
  90. }
  91.  
  92.  
  93.  
  94. Type *choosetype(t1, t2)
  95. Type *t1, *t2;
  96. {
  97.     if (t1 == tp_void ||
  98.         (type_sizeof(t2, 1) && !type_sizeof(t1, 1)))
  99.         return t2;
  100.     else
  101.         return t1;
  102. }
  103.  
  104.  
  105.  
  106. Expr *convert_offset(type, ex2)
  107. Type *type;
  108. Expr *ex2;
  109. {
  110.     long size;
  111.     int i;
  112.     Value val;
  113.     Expr *ex3;
  114.  
  115.     if (type->kind == TK_POINTER ||
  116.         type->kind == TK_ARRAY ||
  117.         type->kind == TK_SET ||
  118.         type->kind == TK_STRING)
  119.         type = type->basetype;
  120.     size = type_sizeof(type, 1);
  121.     if (size == 1)
  122.         return ex2;
  123.     val = eval_expr_pasc(ex2);
  124.     if (val.type) {
  125.         if (val.i == 0)
  126.             return ex2;
  127.         if (size && val.i % size == 0) {
  128.             freeexpr(ex2);
  129.             return makeexpr_long(val.i / size);
  130.         }
  131.     } else {     /* look for terms like "n*sizeof(foo)" */
  132.     while (ex2->kind == EK_CAST || ex2->kind == EK_ACTCAST)
  133.         ex2 = ex2->args[0];
  134.         if (ex2->kind == EK_TIMES) {
  135.         for (i = 0; i < ex2->nargs; i++) {
  136.         ex3 = convert_offset(type, ex2->args[i]);
  137.         if (ex3) {
  138.             ex2->args[i] = ex3;
  139.             return resimplify(ex2);
  140.         }
  141.         }
  142.             for (i = 0;
  143.                  i < ex2->nargs && ex2->args[i]->kind != EK_SIZEOF;
  144.                  i++) ;
  145.             if (i < ex2->nargs) {
  146.                 if (ex2->args[i]->args[0]->val.type == type) {
  147.                     delfreearg(&ex2, i);
  148.                     if (ex2->nargs == 1)
  149.                         return ex2->args[0];
  150.                     else
  151.                         return ex2;
  152.                 }
  153.             }
  154.         } else if (ex2->kind == EK_PLUS) {
  155.         ex3 = copyexpr(ex2);
  156.         for (i = 0; i < ex2->nargs; i++) {
  157.         ex3->args[i] = convert_offset(type, ex3->args[i]);
  158.         if (!ex3->args[i]) {
  159.             freeexpr(ex3);
  160.             return NULL;
  161.         }
  162.         }
  163.         freeexpr(ex2);
  164.         return resimplify(ex3);
  165.         } else if (ex2->kind == EK_SIZEOF) {
  166.             if (ex2->args[0]->val.type == type) {
  167.                 freeexpr(ex2);
  168.                 return makeexpr_long(1);
  169.             }
  170.         } else if (ex2->kind == EK_NEG) {
  171.         ex3 = convert_offset(type, ex2->args[0]);
  172.         if (ex3)
  173.                 return makeexpr_neg(ex3);
  174.         }
  175.     }
  176.     return NULL;
  177. }
  178.  
  179.  
  180.  
  181. Expr *convert_size(type, ex, name)
  182. Type *type;
  183. Expr *ex;
  184. char *name;
  185. {
  186.     long size;
  187.     Expr *ex2;
  188.     int i, okay;
  189.     Value val;
  190.  
  191.     if (debug>2) { fprintf(outf,"convert_size("); dumpexpr(ex); fprintf(outf,")\n"); }
  192.     while (type->kind == TK_ARRAY || type->kind == TK_STRING)
  193.         type = type->basetype;
  194.     if (type == tp_void)
  195.         return ex;
  196.     size = type_sizeof(type, 1);
  197.     if (size == 1)
  198.         return ex;
  199.     while (ex->kind == EK_CAST || ex->kind == EK_ACTCAST)
  200.     ex = ex->args[0];
  201.     switch (ex->kind) {
  202.  
  203.         case EK_TIMES:
  204.             for (i = 0; i < ex->nargs; i++) {
  205.                 ex2 = convert_size(type, ex->args[i], NULL);
  206.                 if (ex2) {
  207.                     ex->args[i] = ex2;
  208.                     return resimplify(ex);
  209.                 }
  210.             }
  211.             break;
  212.  
  213.         case EK_PLUS:
  214.             okay = 1;
  215.             for (i = 0; i < ex->nargs; i++) {
  216.                 ex2 = convert_size(type, ex->args[i], NULL);
  217.                 if (ex2)
  218.                     ex->args[i] = ex2;
  219.                 else
  220.                     okay = 0;
  221.             }
  222.             ex = distribute_plus(ex);
  223.             if ((ex->kind != EK_TIMES || !okay) && name)
  224.                 note(format_s("Suspicious mixture of sizes in %s [173]", name));
  225.             return ex;
  226.  
  227.         case EK_SIZEOF:
  228.             return ex;
  229.  
  230.     default:
  231.         break;
  232.     }
  233.     val = eval_expr_pasc(ex);
  234.     if (val.type) {
  235.         if (val.i == 0)
  236.             return ex;
  237.         if (size && val.i % size == 0) {
  238.             freeexpr(ex);
  239.             return makeexpr_times(makeexpr_long(val.i / size),
  240.                                   makeexpr_sizeof(makeexpr_type(type), 0));
  241.         }
  242.     }
  243.     if (name) {
  244.         note(format_s("Can't interpret size in %s [174]", name));
  245.         return ex;
  246.     } else
  247.         return NULL;
  248. }
  249.  
  250.  
  251.  
  252.  
  253.  
  254.  
  255.  
  256.  
  257.  
  258.  
  259.  
  260.  
  261. Static Expr *func_abs()
  262. {
  263.     Expr *ex;
  264.     Meaning *tvar;
  265.     int lness;
  266.  
  267.     ex = p_parexpr(tp_integer);
  268.     if (ex->val.type->kind == TK_REAL)
  269.         return makeexpr_bicall_1("fabs", tp_longreal, ex);
  270.     else {
  271.         lness = exprlongness(ex);
  272.         if (lness < 0)
  273.             return makeexpr_bicall_1("abs", tp_int, ex);
  274.         else if (lness > 0 && *absname) {
  275.             if (ansiC > 0) {
  276.                 return makeexpr_bicall_1("labs", tp_integer, ex);
  277.             } else if (*absname == '*' && (exprspeed(ex) >= 5 || !nosideeffects(ex, 0))) {
  278.                 tvar = makestmttempvar(tp_integer, name_TEMP);
  279.                 return makeexpr_comma(makeexpr_assign(makeexpr_var(tvar),
  280.                                                       ex),
  281.                                       makeexpr_bicall_1(absname, tp_integer,
  282.                                                         makeexpr_var(tvar)));
  283.             } else {
  284.                 return makeexpr_bicall_1(absname, tp_integer, ex);
  285.             }
  286.         } else if (exprspeed(ex) < 5 && nosideeffects(ex, 0)) {
  287.             return makeexpr_cond(makeexpr_rel(EK_LT, copyexpr(ex),
  288.                                                      makeexpr_long(0)),
  289.                                  makeexpr_neg(copyexpr(ex)),
  290.                                  ex);
  291.         } else {
  292.             tvar = makestmttempvar(tp_integer, name_TEMP);
  293.             return makeexpr_cond(makeexpr_rel(EK_LT, makeexpr_assign(makeexpr_var(tvar),
  294.                                                                      ex),
  295.                                                      makeexpr_long(0)),
  296.                                  makeexpr_neg(makeexpr_var(tvar)),
  297.                                  makeexpr_var(tvar));
  298.         }
  299.     }
  300. }
  301.  
  302.  
  303.  
  304. Static Expr *func_addr()
  305. {
  306.     Expr *ex, *ex2, *ex3;
  307.     Type *type, *tp2;
  308.     int haspar;
  309.  
  310.     haspar = wneedtok(TOK_LPAR);
  311.     ex = p_expr(tp_proc);
  312.     if (curtok == TOK_COMMA) {
  313.         gettok();
  314.         ex2 = p_expr(tp_integer);
  315.         ex3 = convert_offset(ex->val.type, ex2);
  316.         if (checkconst(ex3, 0)) {
  317.             ex = makeexpr_addrf(ex);
  318.         } else {
  319.             ex = makeexpr_addrf(ex);
  320.             if (ex3) {
  321.                 ex = makeexpr_plus(ex, ex3);
  322.             } else {
  323.                 note("Don't know how to reduce offset for ADDR [175]");
  324.                 type = makepointertype(tp_abyte);
  325.         tp2 = ex->val.type;
  326.                 ex = makeexpr_cast(makeexpr_plus(makeexpr_cast(ex, type), ex2), tp2);
  327.             }
  328.         }
  329.     } else {
  330.     if ((ex->val.type->kind != TK_PROCPTR &&
  331.          ex->val.type->kind != TK_CPROCPTR) ||
  332.         (ex->kind == EK_VAR &&
  333.          ex->val.type == ((Meaning *)ex->val.i)->type))
  334.         ex = makeexpr_addrf(ex);
  335.     }
  336.     if (haspar) {
  337.     if (!wneedtok(TOK_RPAR))
  338.         skippasttotoken(TOK_RPAR, TOK_SEMI);
  339.     }
  340.     return ex;
  341. }
  342.  
  343.  
  344. Static Expr *func_iaddress()
  345. {
  346.     return makeexpr_cast(func_addr(), tp_integer);
  347. }
  348.  
  349.  
  350.  
  351. Static Expr *func_addtopointer()
  352. {
  353.     Expr *ex, *ex2, *ex3;
  354.     Type *type, *tp2;
  355.  
  356.     if (!skipopenparen())
  357.     return NULL;
  358.     ex = p_expr(tp_anyptr);
  359.     if (skipcomma()) {
  360.     ex2 = p_expr(tp_integer);
  361.     } else
  362.     ex2 = makeexpr_long(0);
  363.     skipcloseparen();
  364.     ex3 = convert_offset(ex->val.type, ex2);
  365.     if (!checkconst(ex3, 0)) {
  366.     if (ex3) {
  367.         ex = makeexpr_plus(ex, ex3);
  368.     } else {
  369.         note("Don't know how to reduce offset for ADDTOPOINTER [175]");
  370.         type = makepointertype(tp_abyte);
  371.         tp2 = ex->val.type;
  372.         ex = makeexpr_cast(makeexpr_plus(makeexpr_cast(ex, type), ex2), tp2);
  373.     }
  374.     }
  375.     return ex;
  376. }
  377.  
  378.  
  379.  
  380. Stmt *proc_assert()
  381. {
  382.     Expr *ex;
  383.  
  384.     ex = p_parexpr(tp_boolean);
  385.     return makestmt_call(makeexpr_bicall_1("assert", tp_void, ex));
  386. }
  387.  
  388.  
  389.  
  390. Stmt *wrapopencheck(sp, fex)
  391. Stmt *sp;
  392. Expr *fex;
  393. {
  394.     Stmt *sp2;
  395.  
  396.     if (FCheck(checkfileisopen) && !is_std_file(fex)) {
  397.         sp2 = makestmt(SK_IF);
  398.         sp2->exp1 = makeexpr_rel(EK_NE, filebasename(fex), makeexpr_nil());
  399.         sp2->stm1 = sp;
  400.         if (iocheck_flag) {
  401.             sp2->stm2 = makestmt_call(makeexpr_bicall_1(name_ESCIO, tp_integer,
  402.                             makeexpr_name(filenotopenname, tp_int)));
  403.         } else {
  404.             sp2->stm2 = makestmt_assign(makeexpr_var(mp_ioresult),
  405.                     makeexpr_name(filenotopenname, tp_int));
  406.         }
  407.         return sp2;
  408.     } else {
  409.         freeexpr(fex);
  410.         return sp;
  411.     }
  412. }
  413.  
  414.  
  415.  
  416. Static Expr *checkfilename(nex)
  417. Expr *nex;
  418. {
  419.     Expr *ex;
  420.  
  421.     nex = makeexpr_stringcast(nex);
  422.     if (nex->kind == EK_CONST && nex->val.type->kind == TK_STRING) {
  423.         switch (which_lang) {
  424.  
  425.             case LANG_HP:
  426.                 if (!strncmp(nex->val.s, "#1:", 3) ||
  427.                     !strncmp(nex->val.s, "console:", 8) ||
  428.                     !strncmp(nex->val.s, "CONSOLE:", 8)) {
  429.                     freeexpr(nex);
  430.                     nex = makeexpr_string("/dev/tty");
  431.                 } else if (!strncmp(nex->val.s, "#2:", 3) ||
  432.                            !strncmp(nex->val.s, "systerm:", 8) ||
  433.                            !strncmp(nex->val.s, "SYSTERM:", 8)) {
  434.                     freeexpr(nex);
  435.                     nex = makeexpr_string("/dev/tty");     /* should do more? */
  436.                 } else if (!strncmp(nex->val.s, "#6:", 3) ||
  437.                            !strncmp(nex->val.s, "printer:", 8) ||
  438.                            !strncmp(nex->val.s, "PRINTER:", 8)) {
  439.                     note("Opening a file named PRINTER: [176]");
  440.                 } else if (my_strchr(nex->val.s, ':')) {
  441.                     note("Opening a file whose name contains a ':' [177]");
  442.                 }
  443.                 break;
  444.  
  445.             case LANG_TURBO:
  446.                 if (checkstring(nex, "con") ||
  447.                     checkstring(nex, "CON") ||
  448.                     checkstring(nex, "")) {
  449.                     freeexpr(nex);
  450.                     nex = makeexpr_string("/dev/tty");
  451.                 } else if (checkstring(nex, "nul") ||
  452.                            checkstring(nex, "NUL")) {
  453.                     freeexpr(nex);
  454.                     nex = makeexpr_string("/dev/null");
  455.                 } else if (checkstring(nex, "lpt1") ||
  456.                            checkstring(nex, "LPT1") ||
  457.                            checkstring(nex, "lpt2") ||
  458.                            checkstring(nex, "LPT2") ||
  459.                            checkstring(nex, "lpt3") ||
  460.                            checkstring(nex, "LPT3") ||
  461.                            checkstring(nex, "com1") ||
  462.                            checkstring(nex, "COM1") ||
  463.                            checkstring(nex, "com2") ||
  464.                            checkstring(nex, "COM2")) {
  465.                     note("Opening a DOS device file name [178]");
  466.                 }
  467.                 break;
  468.  
  469.         default:
  470.         break;
  471.         }
  472.     } else {
  473.     if (*filenamefilter && strcmp(filenamefilter, "0")) {
  474.         ex = makeexpr_sizeof(copyexpr(nex), 0);
  475.         nex = makeexpr_bicall_2(filenamefilter, tp_str255, nex, ex);
  476.     } else
  477.         nex = makeexpr_stringify(nex);
  478.     }
  479.     return nex;
  480. }
  481.  
  482.  
  483.  
  484. Static Stmt *assignfilename(fex, nex)
  485. Expr *fex, *nex;
  486. {
  487.     Meaning *mp;
  488.     Expr *nvex;
  489.  
  490.     nvex = filenamepart(fex);
  491.     if (nvex) {
  492.         freeexpr(fex);
  493.         return makestmt_call(makeexpr_assign(nvex, nex));
  494.     } else {
  495.     mp = isfilevar(fex);
  496.         if (mp)
  497.             warning("Don't know how to ASSIGN to a non-explicit file variable [207]");
  498.         else
  499.             note("Encountered an ASSIGN statement [179]");
  500.         return makestmt_call(makeexpr_bicall_2("assign", tp_void, fex, nex));
  501.     }
  502. }
  503.  
  504.  
  505.  
  506. Static Stmt *proc_assign()
  507. {
  508.     Expr *fex, *nex;
  509.  
  510.     if (!skipopenparen())
  511.     return NULL;
  512.     fex = p_expr(tp_text);
  513.     if (!skipcomma())
  514.     return NULL;
  515.     nex = checkfilename(p_expr(tp_str255));
  516.     skipcloseparen();
  517.     return assignfilename(fex, nex);
  518. }
  519.  
  520.  
  521.  
  522. Static Stmt *handleopen(code)
  523. int code;
  524. {
  525.     Stmt *sp, *sp1, *sp2, *spassign;
  526.     Expr *fex, *nex, *ex, *truenex, *nvex;
  527.     Meaning *fmp;
  528.     int needcheckopen = 1;
  529.     char modebuf[5], *cp;
  530.  
  531.     if (!skipopenparen())
  532.     return NULL;
  533.     fex = p_expr(tp_text);
  534.     fmp = isfilevar(fex);
  535.     nvex = filenamepart(fex);
  536.     truenex = NULL;
  537.     spassign = NULL;
  538.     if (curtok == TOK_COMMA) {
  539.         gettok();
  540.         ex = p_expr(tp_str255);
  541.     } else
  542.         ex = NULL;
  543.     if (ex && (ex->val.type->kind == TK_STRING ||
  544.            ex->val.type->kind == TK_ARRAY)) {
  545.         nex = checkfilename(ex);
  546.         if (nvex) {
  547.             spassign = assignfilename(copyexpr(fex), nex);
  548.             nex = nvex;
  549.         }
  550.     truenex = nex;
  551.         if (curtok == TOK_COMMA) {
  552.             gettok();
  553.             ex = p_expr(tp_str255);
  554.         } else
  555.             ex = NULL;
  556.     } else if (nvex) {
  557.         nex = nvex;
  558.     } else {
  559.     switch (code) {
  560.         case 0:
  561.             if (ex)
  562.             note("Can't interpret name argument in RESET [180]");
  563.         break;
  564.           case 1:
  565.             note("REWRITE does not specify a name [181]");
  566.         break;
  567.         case 2:
  568.         note("OPEN does not specify a name [181]");
  569.         break;
  570.         case 3:
  571.         note("APPEND does not specify a name [181]");
  572.         break;
  573.     }
  574.     nex = NULL;
  575.     }
  576.     if (ex) {
  577.         if (ord_type(ex->val.type)->kind == TK_INTEGER) {
  578.         if (!checkconst(ex, 1))
  579.         note("Ignoring block size in binary file [182]");
  580.             freeexpr(ex);
  581.         } else {
  582.         if (ex->kind == EK_CONST && ex->val.type->kind == TK_STRING) {
  583.         cp = getstring(ex);
  584.         if (strcicmp(cp, "SHARED"))
  585.             note(format_s("Ignoring option string \"%s\" in open [183]", cp));
  586.         } else
  587.         note("Ignoring option string in open [183]");
  588.         }
  589.     }
  590.     switch (code) {
  591.  
  592.         case 0:  /* reset */
  593.             strcpy(modebuf, "r");
  594.             break;
  595.  
  596.         case 1:  /* rewrite */
  597.             strcpy(modebuf, "w");
  598.             break;
  599.  
  600.         case 2:  /* open */
  601.             strcpy(modebuf, openmode);
  602.             break;
  603.  
  604.         case 3:  /* append */
  605.             strcpy(modebuf, "a");
  606.             break;
  607.  
  608.     }
  609.     if (!*modebuf) {
  610.         strcpy(modebuf, "r+");
  611.     }
  612.     if (readwriteopen == 2 ||
  613.     (readwriteopen &&
  614.      fex->val.type != tp_text &&
  615.      fex->val.type != tp_bigtext)) {
  616.     if (!my_strchr(modebuf, '+'))
  617.         strcat(modebuf, "+");
  618.     }
  619.     if (fex->val.type != tp_text &&
  620.     fex->val.type != tp_bigtext &&
  621.     binarymode != 0) {
  622.         if (binarymode == 1)
  623.             strcat(modebuf, "b");
  624.         else
  625.             note("Opening a binary file [184]");
  626.     }
  627.     if (!nex && fmp &&
  628.     !is_std_file(fex) &&
  629.     literalfilesflag > 0 &&
  630.     (literalfilesflag == 1 ||
  631.      strlist_cifind(literalfiles, fmp->name))) {
  632.     nex = makeexpr_string(fmp->name);
  633.     }
  634.     sp1 = NULL;
  635.     sp2 = NULL;
  636.     if (!nex || (isfiletype(fex->val.type, 1) && !truenex)) {
  637.     if (isvar(fex, mp_output)) {
  638.         note("RESET/REWRITE ignored for file OUTPUT [319]");
  639.     } else {
  640.         sp1 = makestmt_call(makeexpr_bicall_1("rewind", tp_void,
  641.                           filebasename(copyexpr(fex))));
  642.         if (code == 0 || is_std_file(fex)) {
  643.         sp1 = wrapopencheck(sp1, copyexpr(fex));
  644.         needcheckopen = 0;
  645.         } else
  646.         sp1 = makestmt_if(makeexpr_rel(EK_NE,
  647.                            filebasename(copyexpr(fex)),
  648.                            makeexpr_nil()),
  649.                  sp1,
  650.                  makestmt_assign(filebasename(copyexpr(fex)),
  651.                          makeexpr_bicall_0("tmpfile",
  652.                                    tp_text)));
  653.     }
  654.     }
  655.     if (nex || isfiletype(fex->val.type, 1)) {
  656.     needcheckopen = 1;
  657.     if (!strcmp(freopenname, "fclose") ||
  658.         !strcmp(freopenname, "fopen")) {
  659.         sp2 = makestmt_assign(filebasename(copyexpr(fex)),
  660.                   makeexpr_bicall_2("fopen", tp_text,
  661.                             copyexpr(nex),
  662.                             makeexpr_string(modebuf)));
  663.         if (!strcmp(freopenname, "fclose")) {
  664.         sp2 = makestmt_seq(makestmt_if(makeexpr_rel(EK_NE,
  665.                                 filebasename(copyexpr(fex)),
  666.                                 makeexpr_nil()),
  667.                            makestmt_call(makeexpr_bicall_1("fclose", tp_void,
  668.                                            filebasename(copyexpr(fex)))),
  669.                            NULL),
  670.                    sp2);
  671.         }
  672.     } else {
  673.         sp2 = makestmt_assign(filebasename(copyexpr(fex)),
  674.                  makeexpr_bicall_3((*freopenname) ? freopenname : "freopen",
  675.                            tp_text,
  676.                            copyexpr(nex),
  677.                            makeexpr_string(modebuf),
  678.                            filebasename(copyexpr(fex))));
  679.         if (!*freopenname) {
  680.         sp2 = makestmt_if(makeexpr_rel(EK_NE, filebasename(copyexpr(fex)),
  681.                            makeexpr_nil()),
  682.                   sp2,
  683.                   makestmt_assign(filebasename(copyexpr(fex)),
  684.                           makeexpr_bicall_2("fopen", tp_text,
  685.                                     copyexpr(nex),
  686.                                     makeexpr_string(modebuf))));
  687.         }
  688.     }
  689.     }
  690.     if (!sp1)
  691.     sp = sp2;
  692.     else if (!sp2)
  693.     sp = sp1;
  694.     else {
  695.     sp = makestmt_if(makeexpr_rel(EK_NE, copyexpr(nex),
  696.                       makeexpr_string("")),
  697.              sp2, sp1);
  698.     }
  699.     if (code == 2 && !*openmode && nex) {
  700.         sp = makestmt_seq(sp, makestmt_if(makeexpr_rel(EK_EQ,
  701.                                filebasename(copyexpr(fex)),
  702.                                makeexpr_nil()),
  703.                                           makestmt_assign(filebasename(copyexpr(fex)),
  704.                                                           makeexpr_bicall_2("fopen", tp_text,
  705.                                                                             copyexpr(nex),
  706.                                                                             makeexpr_string("w+"))),
  707.                                           NULL));
  708.     }
  709.     if (nex)
  710.     freeexpr(nex);
  711.     if (FCheck(checkfileopen) && needcheckopen) {
  712.         sp = makestmt_seq(sp, makestmt_call(makeexpr_bicall_2("~SETIO", tp_void,
  713.                                                               makeexpr_rel(EK_NE, filebasename(copyexpr(fex)), makeexpr_nil()),
  714.                                   makeexpr_name(filenotfoundname, tp_int))));
  715.     }
  716.     sp = makestmt_seq(spassign, sp);
  717.     cp = (code == 0) ? resetbufname : setupbufname;
  718.     if (*cp &&   /* (may be eaten later, if buffering isn't needed) */
  719.     fileisbuffered(fex, 1))
  720.     sp = makestmt_seq(sp,
  721.              makestmt_call(
  722.                      makeexpr_bicall_2(cp, tp_void, filebasename(fex),
  723.              makeexpr_type(filebasetype(fex->val.type)))));
  724.     else
  725.     freeexpr(fex);
  726.     skipcloseparen();
  727.     return sp;
  728. }
  729.  
  730.  
  731.  
  732. Static Stmt *proc_append()
  733. {
  734.     return handleopen(3);
  735. }
  736.  
  737.  
  738.  
  739. Static Expr *func_arccos(ex)
  740. Expr *ex;
  741. {
  742.     return makeexpr_bicall_1("acos", tp_longreal, grabarg(ex, 0));
  743. }
  744.  
  745.  
  746. Static Expr *func_arcsin(ex)
  747. Expr *ex;
  748. {
  749.     return makeexpr_bicall_1("asin", tp_longreal, grabarg(ex, 0));
  750. }
  751.  
  752.  
  753. Static Expr *func_arctan(ex)
  754. Expr *ex;
  755. {
  756.     ex = grabarg(ex, 0);
  757.     if (atan2flag && ex->kind == EK_DIVIDE)
  758.         return makeexpr_bicall_2("atan2", tp_longreal, 
  759.                                  ex->args[0], ex->args[1]);
  760.     return makeexpr_bicall_1("atan", tp_longreal, ex);
  761. }
  762.  
  763.  
  764. Static Expr *func_arctanh(ex)
  765. Expr *ex;
  766. {
  767.     return makeexpr_bicall_1("atanh", tp_longreal, grabarg(ex, 0));
  768. }
  769.  
  770.  
  771.  
  772. Static Stmt *proc_argv()
  773. {
  774.     Expr *ex, *aex, *lex;
  775.  
  776.     if (!skipopenparen())
  777.     return NULL;
  778.     ex = p_expr(tp_integer);
  779.     if (skipcomma()) {
  780.     aex = p_expr(tp_str255);
  781.     } else
  782.     return NULL;
  783.     skipcloseparen();
  784.     lex = makeexpr_sizeof(copyexpr(aex), 0);
  785.     aex = makeexpr_addrstr(aex);
  786.     return makestmt_call(makeexpr_bicall_3("P_sun_argv", tp_void,
  787.                        aex, lex, makeexpr_arglong(ex, 0)));
  788. }
  789.  
  790.  
  791. Static Expr *func_asr()
  792. {
  793.     Expr *ex;
  794.  
  795.     if (!skipopenparen())
  796.     return NULL;
  797.     ex = p_expr(tp_integer);
  798.     if (skipcomma()) {
  799.         if (signedshift == 0 || signedshift == 2) {
  800.             ex = makeexpr_bicall_2("P_asr", ex->val.type, ex,
  801.                    p_expr(tp_unsigned));
  802.     } else {
  803.         ex = force_signed(ex);
  804.         ex = makeexpr_bin(EK_RSH, ex->val.type, ex, p_expr(tp_unsigned));
  805.         if (signedshift != 1)
  806.         note("Assuming >> is an arithmetic shift [320]");
  807.     }
  808.     skipcloseparen();
  809.     }
  810.     return ex;
  811. }
  812.  
  813.  
  814. Static Expr *func_lsl()
  815. {
  816.     Expr *ex;
  817.  
  818.     if (!skipopenparen())
  819.     return NULL;
  820.     ex = p_expr(tp_integer);
  821.     if (skipcomma()) {
  822.     ex = makeexpr_bin(EK_LSH, ex->val.type, ex, p_expr(tp_unsigned));
  823.     skipcloseparen();
  824.     }
  825.     return ex;
  826. }
  827.  
  828.  
  829. Static Expr *func_lsr()
  830. {
  831.     Expr *ex;
  832.  
  833.     if (!skipopenparen())
  834.     return NULL;
  835.     ex = p_expr(tp_integer);
  836.     if (skipcomma()) {
  837.     ex = force_unsigned(ex);
  838.     ex = makeexpr_bin(EK_RSH, ex->val.type, ex, p_expr(tp_unsigned));
  839.     skipcloseparen();
  840.     }
  841.     return ex;
  842. }
  843.  
  844.  
  845.  
  846. Static Expr *func_bin()
  847. {
  848.     note("Using %b for binary printf format [185]");
  849.     return handle_vax_hex(NULL, "b", 1);
  850. }
  851.  
  852.  
  853.  
  854. Static Expr *func_binary(ex)
  855. Expr *ex;
  856. {
  857.     char *cp;
  858.  
  859.     ex = grabarg(ex, 0);
  860.     if (ex->kind == EK_CONST) {
  861.         cp = getstring(ex);
  862.         ex = makeexpr_long(my_strtol(cp, NULL, 2));
  863.         insertarg(&ex, 0, makeexpr_name("%#lx", tp_integer));
  864.         return ex;
  865.     } else {
  866.         return makeexpr_bicall_3("strtol", tp_integer, 
  867.                                  ex, makeexpr_nil(), makeexpr_long(2));
  868.     }
  869. }
  870.  
  871.  
  872.  
  873. Static Expr *handle_bitsize(next)
  874. int next;
  875. {
  876.     Expr *ex;
  877.     Type *type;
  878.     int lpar;
  879.     long psize;
  880.  
  881.     lpar = (curtok == TOK_LPAR);
  882.     if (lpar)
  883.     gettok();
  884.     if (curtok == TOK_IDENT && curtokmeaning &&
  885.     curtokmeaning->kind == MK_TYPE) {
  886.         ex = makeexpr_type(curtokmeaning->type);
  887.         gettok();
  888.     } else
  889.         ex = p_expr(NULL);
  890.     type = ex->val.type;
  891.     if (lpar)
  892.     skipcloseparen();
  893.     psize = 0;
  894.     packedsize(NULL, &type, &psize, 0);
  895.     if (psize > 0 && psize < 32 && next) {
  896.     if (psize > 16)
  897.         psize = 32;
  898.     else if (psize > 8)
  899.         psize = 16;
  900.     else if (psize > 4)
  901.         psize = 8;
  902.     else if (psize > 2)
  903.         psize = 4;
  904.     else if (psize > 1)
  905.         psize = 2;
  906.     else
  907.         psize = 1;
  908.     }
  909.     if (psize)
  910.     return makeexpr_long(psize);
  911.     else
  912.     return makeexpr_times(makeexpr_sizeof(ex, 0),
  913.                   makeexpr_long(sizeof_char ? sizeof_char : 8));
  914. }
  915.  
  916.  
  917. Static Expr *func_bitsize()
  918. {
  919.     return handle_bitsize(0);
  920. }
  921.  
  922.  
  923. Static Expr *func_bitnext()
  924. {
  925.     return handle_bitsize(1);
  926. }
  927.  
  928.  
  929.  
  930. Static Expr *func_blockread()
  931. {
  932.     Expr *ex, *ex2, *vex, *sex, *fex;
  933.     Type *type;
  934.  
  935.     if (!skipopenparen())
  936.     return NULL;
  937.     fex = p_expr(tp_text);
  938.     if (!skipcomma())
  939.     return NULL;
  940.     vex = p_expr(NULL);
  941.     if (!skipcomma())
  942.     return NULL;
  943.     ex2 = p_expr(tp_integer);
  944.     if (curtok == TOK_COMMA) {
  945.         gettok();
  946.         sex = p_expr(tp_integer);
  947.     sex = doseek(copyexpr(fex),
  948.              makeexpr_times(sex, makeexpr_long(512)))->exp1;
  949.     } else
  950.         sex = NULL;
  951.     skipcloseparen();
  952.     type = vex->val.type;
  953.     ex = makeexpr_bicall_4("fread", tp_integer,
  954.                makeexpr_addr(vex),
  955.                makeexpr_long(512),
  956.                convert_size(type, ex2, "BLOCKREAD"),
  957.                filebasename(copyexpr(fex)));
  958.     return makeexpr_comma(sex, ex);
  959. }
  960.  
  961.  
  962.  
  963. Static Expr *func_blockwrite()
  964. {
  965.     Expr *ex, *ex2, *vex, *sex, *fex;
  966.     Type *type;
  967.  
  968.     if (!skipopenparen())
  969.     return NULL;
  970.     fex = p_expr(tp_text);
  971.     if (!skipcomma())
  972.     return NULL;
  973.     vex = p_expr(NULL);
  974.     if (!skipcomma())
  975.     return NULL;
  976.     ex2 = p_expr(tp_integer);
  977.     if (curtok == TOK_COMMA) {
  978.         gettok();
  979.         sex = p_expr(tp_integer);
  980.     sex = doseek(copyexpr(fex),
  981.              makeexpr_times(sex, makeexpr_long(512)))->exp1;
  982.     } else
  983.         sex = NULL;
  984.     skipcloseparen();
  985.     type = vex->val.type;
  986.     ex = makeexpr_bicall_4("fwrite", tp_integer,
  987.                makeexpr_addr(vex),
  988.                makeexpr_long(512),
  989.                convert_size(type, ex2, "BLOCKWRITE"),
  990.                filebasename(copyexpr(fex)));
  991.     return makeexpr_comma(sex, ex);
  992. }
  993.  
  994.  
  995.  
  996.  
  997. Static Stmt *proc_blockread()
  998. {
  999.     Expr *ex, *ex2, *vex, *rex, *fex;
  1000.     Type *type;
  1001.  
  1002.     if (!skipopenparen())
  1003.     return NULL;
  1004.     fex = p_expr(tp_text);
  1005.     if (!skipcomma())
  1006.     return NULL;
  1007.     vex = p_expr(NULL);
  1008.     if (!skipcomma())
  1009.     return NULL;
  1010.     ex2 = p_expr(tp_integer);
  1011.     if (curtok == TOK_COMMA) {
  1012.         gettok();
  1013.         rex = p_expr(tp_integer);
  1014.     } else
  1015.         rex = NULL;
  1016.     skipcloseparen();
  1017.     type = vex->val.type;
  1018.     if (rex) {
  1019.         ex = makeexpr_bicall_4("fread", tp_integer,
  1020.                                makeexpr_addr(vex),
  1021.                                makeexpr_long(1),
  1022.                                convert_size(type, ex2, "BLOCKREAD"),
  1023.                                filebasename(copyexpr(fex)));
  1024.         ex = makeexpr_assign(rex, ex);
  1025.         if (!iocheck_flag)
  1026.             ex = makeexpr_comma(ex,
  1027.                                 makeexpr_assign(makeexpr_var(mp_ioresult),
  1028.                                                 makeexpr_long(0)));
  1029.     } else {
  1030.         ex = makeexpr_bicall_4("fread", tp_integer,
  1031.                                makeexpr_addr(vex),
  1032.                                convert_size(type, ex2, "BLOCKREAD"),
  1033.                                makeexpr_long(1),
  1034.                                filebasename(copyexpr(fex)));
  1035.         if (checkeof(fex)) {
  1036.             ex = makeexpr_bicall_2(name_SETIO, tp_void,
  1037.                                    makeexpr_rel(EK_EQ, ex, makeexpr_long(1)),
  1038.                    makeexpr_name(endoffilename, tp_int));
  1039.         }
  1040.     }
  1041.     return wrapopencheck(makestmt_call(ex), fex);
  1042. }
  1043.  
  1044.  
  1045.  
  1046.  
  1047. Static Stmt *proc_blockwrite()
  1048. {
  1049.     Expr *ex, *ex2, *vex, *rex, *fex;
  1050.     Type *type;
  1051.  
  1052.     if (!skipopenparen())
  1053.     return NULL;
  1054.     fex = p_expr(tp_text);
  1055.     if (!skipcomma())
  1056.     return NULL;
  1057.     vex = p_expr(NULL);
  1058.     if (!skipcomma())
  1059.     return NULL;
  1060.     ex2 = p_expr(tp_integer);
  1061.     if (curtok == TOK_COMMA) {
  1062.         gettok();
  1063.         rex = p_expr(tp_integer);
  1064.     } else
  1065.         rex = NULL;
  1066.     skipcloseparen();
  1067.     type = vex->val.type;
  1068.     if (rex) {
  1069.         ex = makeexpr_bicall_4("fwrite", tp_integer,
  1070.                                makeexpr_addr(vex),
  1071.                                makeexpr_long(1),
  1072.                                convert_size(type, ex2, "BLOCKWRITE"),
  1073.                                filebasename(copyexpr(fex)));
  1074.         ex = makeexpr_assign(rex, ex);
  1075.         if (!iocheck_flag)
  1076.             ex = makeexpr_comma(ex,
  1077.                                 makeexpr_assign(makeexpr_var(mp_ioresult),
  1078.                                                 makeexpr_long(0)));
  1079.     } else {
  1080.         ex = makeexpr_bicall_4("fwrite", tp_integer,
  1081.                                makeexpr_addr(vex),
  1082.                                convert_size(type, ex2, "BLOCKWRITE"),
  1083.                                makeexpr_long(1),
  1084.                                filebasename(copyexpr(fex)));
  1085.         if (FCheck(checkfilewrite)) {
  1086.             ex = makeexpr_bicall_2(name_SETIO, tp_void,
  1087.                                    makeexpr_rel(EK_EQ, ex, makeexpr_long(1)),
  1088.                    makeexpr_name(filewriteerrorname, tp_int));
  1089.         }
  1090.     }
  1091.     return wrapopencheck(makestmt_call(ex), fex);
  1092. }
  1093.  
  1094.  
  1095.  
  1096. Static Stmt *proc_bclr()
  1097. {
  1098.     Expr *ex, *ex2;
  1099.  
  1100.     if (!skipopenparen())
  1101.     return NULL;
  1102.     ex = p_expr(tp_integer);
  1103.     if (!skipcomma())
  1104.     return NULL;
  1105.     ex2 = p_expr(tp_integer);
  1106.     skipcloseparen();
  1107.     return makestmt_assign(ex,
  1108.                makeexpr_bin(EK_BAND, ex->val.type,
  1109.                     copyexpr(ex),
  1110.                     makeexpr_un(EK_BNOT, ex->val.type,
  1111.                     makeexpr_bin(EK_LSH, tp_integer,
  1112.                              makeexpr_arglong(
  1113.                                  makeexpr_long(1), 1),
  1114.                              ex2))));
  1115. }
  1116.  
  1117.  
  1118.  
  1119. Static Stmt *proc_bset()
  1120. {
  1121.     Expr *ex, *ex2;
  1122.  
  1123.     if (!skipopenparen())
  1124.     return NULL;
  1125.     ex = p_expr(tp_integer);
  1126.     if (!skipcomma())
  1127.     return NULL;
  1128.     ex2 = p_expr(tp_integer);
  1129.     skipcloseparen();
  1130.     return makestmt_assign(ex,
  1131.                makeexpr_bin(EK_BOR, ex->val.type,
  1132.                     copyexpr(ex),
  1133.                     makeexpr_bin(EK_LSH, tp_integer,
  1134.                              makeexpr_arglong(
  1135.                                  makeexpr_long(1), 1),
  1136.                              ex2)));
  1137. }
  1138.  
  1139.  
  1140.  
  1141. Static Expr *func_bsl()
  1142. {
  1143.     Expr *ex, *ex2;
  1144.  
  1145.     if (!skipopenparen())
  1146.     return NULL;
  1147.     ex = p_expr(tp_integer);
  1148.     if (!skipcomma())
  1149.     return NULL;
  1150.     ex2 = p_expr(tp_integer);
  1151.     skipcloseparen();
  1152.     return makeexpr_bin(EK_LSH, tp_integer, ex, ex2);
  1153. }
  1154.  
  1155.  
  1156.  
  1157. Static Expr *func_bsr()
  1158. {
  1159.     Expr *ex, *ex2;
  1160.  
  1161.     if (!skipopenparen())
  1162.     return NULL;
  1163.     ex = p_expr(tp_integer);
  1164.     if (!skipcomma())
  1165.     return NULL;
  1166.     ex2 = p_expr(tp_integer);
  1167.     skipcloseparen();
  1168.     return makeexpr_bin(EK_RSH, tp_integer, force_unsigned(ex), ex2);
  1169. }
  1170.  
  1171.  
  1172.  
  1173. Static Expr *func_btst()
  1174. {
  1175.     Expr *ex, *ex2;
  1176.  
  1177.     if (!skipopenparen())
  1178.     return NULL;
  1179.     ex = p_expr(tp_integer);
  1180.     if (!skipcomma())
  1181.     return NULL;
  1182.     ex2 = p_expr(tp_integer);
  1183.     skipcloseparen();
  1184.     return makeexpr_rel(EK_NE,
  1185.             makeexpr_bin(EK_BAND, tp_integer,
  1186.                      ex,
  1187.                      makeexpr_bin(EK_LSH, tp_integer,
  1188.                           makeexpr_arglong(
  1189.                               makeexpr_long(1), 1),
  1190.                           ex2)),
  1191.             makeexpr_long(0));
  1192. }
  1193.  
  1194.  
  1195.  
  1196. Static Expr *func_byteread()
  1197. {
  1198.     Expr *ex, *ex2, *vex, *sex, *fex;
  1199.     Type *type;
  1200.  
  1201.     if (!skipopenparen())
  1202.     return NULL;
  1203.     fex = p_expr(tp_text);
  1204.     if (!skipcomma())
  1205.     return NULL;
  1206.     vex = p_expr(NULL);
  1207.     if (!skipcomma())
  1208.     return NULL;
  1209.     ex2 = p_expr(tp_integer);
  1210.     if (curtok == TOK_COMMA) {
  1211.         gettok();
  1212.         sex = p_expr(tp_integer);
  1213.     sex = doseek(copyexpr(fex), sex)->exp1;
  1214.     } else
  1215.         sex = NULL;
  1216.     skipcloseparen();
  1217.     type = vex->val.type;
  1218.     ex = makeexpr_bicall_4("fread", tp_integer,
  1219.                makeexpr_addr(vex),
  1220.                makeexpr_long(1),
  1221.                convert_size(type, ex2, "BYTEREAD"),
  1222.                filebasename(copyexpr(fex)));
  1223.     return makeexpr_comma(sex, ex);
  1224. }
  1225.  
  1226.  
  1227.  
  1228. Static Expr *func_bytewrite()
  1229. {
  1230.     Expr *ex, *ex2, *vex, *sex, *fex;
  1231.     Type *type;
  1232.  
  1233.     if (!skipopenparen())
  1234.     return NULL;
  1235.     fex = p_expr(tp_text);
  1236.     if (!skipcomma())
  1237.     return NULL;
  1238.     vex = p_expr(NULL);
  1239.     if (!skipcomma())
  1240.     return NULL;
  1241.     ex2 = p_expr(tp_integer);
  1242.     if (curtok == TOK_COMMA) {
  1243.         gettok();
  1244.         sex = p_expr(tp_integer);
  1245.     sex = doseek(copyexpr(fex), sex)->exp1;
  1246.     } else
  1247.         sex = NULL;
  1248.     skipcloseparen();
  1249.     type = vex->val.type;
  1250.     ex = makeexpr_bicall_4("fwrite", tp_integer,
  1251.                makeexpr_addr(vex),
  1252.                makeexpr_long(1),
  1253.                convert_size(type, ex2, "BYTEWRITE"),
  1254.                filebasename(copyexpr(fex)));
  1255.     return makeexpr_comma(sex, ex);
  1256. }
  1257.  
  1258.  
  1259.  
  1260. Static Expr *func_byte_offset()
  1261. {
  1262.     Type *tp;
  1263.     Meaning *mp;
  1264.     Expr *ex;
  1265.  
  1266.     if (!skipopenparen())
  1267.     return NULL;
  1268.     tp = p_type(NULL);
  1269.     if (!skipcomma())
  1270.     return NULL;
  1271.     if (!wexpecttok(TOK_IDENT))
  1272.     return NULL;
  1273.     mp = curtoksym->fbase;
  1274.     while (mp && mp->rectype != tp)
  1275.     mp = mp->snext;
  1276.     if (!mp)
  1277.     ex = makeexpr_name(curtokcase, tp_integer);
  1278.     else
  1279.     ex = makeexpr_name(mp->name, tp_integer);
  1280.     gettok();
  1281.     skipcloseparen();
  1282.     return makeexpr_bicall_2("OFFSETOF", (size_t_long) ? tp_integer : tp_int,
  1283.                  makeexpr_type(tp), ex);
  1284. }
  1285.  
  1286.  
  1287.  
  1288. Static Stmt *proc_call()
  1289. {
  1290.     Expr *ex, *ex2, *ex3;
  1291.     Type *type, *tp;
  1292.     Meaning *mp;
  1293.  
  1294.     if (!skipopenparen())
  1295.     return NULL;
  1296.     ex2 = p_expr(tp_proc);
  1297.     type = ex2->val.type;
  1298.     if (type->kind != TK_PROCPTR && type->kind != TK_CPROCPTR) {
  1299.         warning("CALL requires a procedure variable [208]");
  1300.     type = tp_proc;
  1301.     }
  1302.     ex = makeexpr(EK_SPCALL, 1);
  1303.     ex->val.type = tp_void;
  1304.     ex->args[0] = copyexpr(ex2);
  1305.     if (type->escale != 0)
  1306.     ex->args[0] = makeexpr_cast(makeexpr_dotq(ex2, "proc", tp_anyptr),
  1307.                     makepointertype(type->basetype));
  1308.     mp = type->basetype->fbase;
  1309.     if (mp) {
  1310.         if (wneedtok(TOK_COMMA))
  1311.         ex = p_funcarglist(ex, mp, 0, 0);
  1312.     }
  1313.     skipcloseparen();
  1314.     if (type->escale != 1 || hasstaticlinks == 2) {
  1315.     freeexpr(ex2);
  1316.     return makestmt_call(ex);
  1317.     }
  1318.     ex2 = makeexpr_dotq(ex2, "link", tp_anyptr),
  1319.     ex3 = copyexpr(ex);
  1320.     insertarg(&ex3, ex3->nargs, copyexpr(ex2));
  1321.     tp = maketype(TK_FUNCTION);
  1322.     tp->basetype = type->basetype->basetype;
  1323.     tp->fbase = type->basetype->fbase;
  1324.     tp->issigned = 1;
  1325.     ex3->args[0]->val.type = makepointertype(tp);
  1326.     return makestmt_if(makeexpr_rel(EK_NE, ex2, makeexpr_nil()),
  1327.                        makestmt_call(ex3),
  1328.                        makestmt_call(ex));
  1329. }
  1330.  
  1331.  
  1332.  
  1333. Static Expr *func_chr()
  1334. {
  1335.     Expr *ex;
  1336.  
  1337.     ex = p_expr(tp_integer);
  1338.     if ((exprlongness(ex) < 0 || ex->kind == EK_CAST) && ex->kind != EK_ACTCAST)
  1339.         ex->val.type = tp_char;
  1340.     else
  1341.         ex = makeexpr_cast(ex, tp_char);
  1342.     return ex;
  1343. }
  1344.  
  1345.  
  1346.  
  1347. Static Stmt *proc_close()
  1348. {
  1349.     Stmt *sp;
  1350.     Expr *fex, *ex;
  1351.     char *opt;
  1352.  
  1353.     if (!skipopenparen())
  1354.     return NULL;
  1355.     fex = p_expr(tp_text);
  1356.     sp = makestmt_if(makeexpr_rel(EK_NE, filebasename(copyexpr(fex)),
  1357.                   makeexpr_nil()),
  1358.                      makestmt_call(makeexpr_bicall_1("fclose", tp_void,
  1359.                                                      filebasename(copyexpr(fex)))),
  1360.                      (FCheck(checkfileisopen))
  1361.                  ? makestmt_call(
  1362.                  makeexpr_bicall_1(name_ESCIO,
  1363.                            tp_integer,
  1364.                            makeexpr_name(filenotopenname,
  1365.                                  tp_int)))
  1366.                          : NULL);
  1367.     if (curtok == TOK_COMMA) {
  1368.         gettok();
  1369.     opt = "";
  1370.     if (curtok == TOK_IDENT &&
  1371.         (!strcicmp(curtokbuf, "LOCK") ||
  1372.          !strcicmp(curtokbuf, "PURGE") ||
  1373.          !strcicmp(curtokbuf, "NORMAL") ||
  1374.          !strcicmp(curtokbuf, "CRUNCH"))) {
  1375.         opt = stralloc(curtokbuf);
  1376.         gettok();
  1377.     } else {
  1378.         ex = p_expr(tp_str255);
  1379.         if (ex->kind == EK_CONST && ex->val.type->kind == TK_STRING)
  1380.         opt = ex->val.s;
  1381.     }
  1382.     if (!strcicmp(opt, "PURGE")) {
  1383.         note("File is being closed with PURGE option [186]");
  1384.         }
  1385.     }
  1386.     sp = makestmt_seq(sp, makestmt_assign(filebasename(fex), makeexpr_nil()));
  1387.     skipcloseparen();
  1388.     return sp;
  1389. }
  1390.  
  1391.  
  1392.  
  1393. Static Expr *func_concat()
  1394. {
  1395.     Expr *ex;
  1396.  
  1397.     if (!skipopenparen())
  1398.     return makeexpr_string("oops");
  1399.     ex = p_expr(tp_str255);
  1400.     while (curtok == TOK_COMMA) {
  1401.         gettok();
  1402.         ex = makeexpr_concat(ex, p_expr(tp_str255), 0);
  1403.     }
  1404.     skipcloseparen();
  1405.     return ex;
  1406. }
  1407.  
  1408.  
  1409.  
  1410. Static Expr *func_copy(ex)
  1411. Expr *ex;
  1412. {
  1413.     if (isliteralconst(ex->args[3], NULL) == 2 &&
  1414.         ex->args[3]->val.i >= stringceiling) {
  1415.         return makeexpr_bicall_3("sprintf", ex->val.type,
  1416.                                  ex->args[0],
  1417.                                  makeexpr_string("%s"),
  1418.                                  bumpstring(ex->args[1], 
  1419.                                             makeexpr_unlongcast(ex->args[2]), 1));
  1420.     }
  1421.     if (checkconst(ex->args[2], 1)) {
  1422.         return makeexpr_addr(makeexpr_substring(ex->args[0], ex->args[1], 
  1423.                                                 ex->args[2], ex->args[3]));
  1424.     }
  1425.     return makeexpr_bicall_4(strsubname, ex->val.type,
  1426.                              ex->args[0],
  1427.                              ex->args[1],
  1428.                              makeexpr_arglong(ex->args[2], 0),
  1429.                              makeexpr_arglong(ex->args[3], 0));
  1430. }
  1431.  
  1432.  
  1433.  
  1434. Static Expr *func_cos(ex)
  1435. Expr *ex;
  1436. {
  1437.     return makeexpr_bicall_1("cos", tp_longreal, grabarg(ex, 0));
  1438. }
  1439.  
  1440.  
  1441. Static Expr *func_cosh(ex)
  1442. Expr *ex;
  1443. {
  1444.     return makeexpr_bicall_1("cosh", tp_longreal, grabarg(ex, 0));
  1445. }
  1446.  
  1447.  
  1448.  
  1449. Static Stmt *proc_cycle()
  1450. {
  1451.     return makestmt(SK_CONTINUE);
  1452. }
  1453.  
  1454.  
  1455.  
  1456. Static Stmt *proc_date()
  1457. {
  1458.     Expr *ex;
  1459.  
  1460.     if (!skipopenparen())
  1461.     return NULL;
  1462.     ex = p_expr(tp_str255);
  1463.     skipcloseparen();
  1464.     return makestmt_call(makeexpr_bicall_1("VAXdate", tp_integer, ex));
  1465. }
  1466.  
  1467.  
  1468. Static Stmt *proc_dec()
  1469. {
  1470.     Expr *vex, *ex;
  1471.  
  1472.     if (!skipopenparen())
  1473.     return NULL;
  1474.     vex = p_expr(NULL);
  1475.     if (curtok == TOK_COMMA) {
  1476.         gettok();
  1477.         ex = p_expr(tp_integer);
  1478.     } else
  1479.         ex = makeexpr_long(1);
  1480.     skipcloseparen();
  1481.     return makestmt_assign(vex, makeexpr_minus(copyexpr(vex), ex));
  1482. }
  1483.  
  1484.  
  1485.  
  1486. Static Expr *func_dec()
  1487. {
  1488.     return handle_vax_hex(NULL, "d", 0);
  1489. }
  1490.  
  1491.  
  1492.  
  1493. Static Stmt *proc_delete(ex)
  1494. Expr *ex;
  1495. {
  1496.     if (ex->nargs == 1)   /* Kludge for Oregon Software Pascal's delete(f) */
  1497.     return makestmt_call(makeexpr_bicall_1(strdeletename, tp_void, ex->args[0]));
  1498.     return makestmt_call(makeexpr_bicall_3(strdeletename, tp_void,
  1499.                                            ex->args[0], 
  1500.                                            makeexpr_arglong(ex->args[1], 0),
  1501.                                            makeexpr_arglong(ex->args[2], 0)));
  1502. }
  1503.  
  1504.  
  1505.  
  1506. void parse_special_variant(tp, buf)
  1507. Type *tp;
  1508. char *buf;
  1509. {
  1510.     char *cp;
  1511.     Expr *ex;
  1512.  
  1513.     if (!tp)
  1514.     intwarning("parse_special_variant", "tp == NULL");
  1515.     if (!tp || tp->meaning == NULL) {
  1516.     *buf = 0;
  1517.     if (curtok == TOK_COMMA) {
  1518.         skiptotoken(TOK_RPAR);
  1519.     }
  1520.     return;
  1521.     }
  1522.     strcpy(buf, tp->meaning->name);
  1523.     while (curtok == TOK_COMMA) {
  1524.     gettok();
  1525.     cp = buf + strlen(buf);
  1526.     *cp++ = '.';
  1527.     if (curtok == TOK_MINUS) {
  1528.         *cp++ = '-';
  1529.         gettok();
  1530.     }
  1531.     if (curtok == TOK_INTLIT ||
  1532.         curtok == TOK_HEXLIT ||
  1533.         curtok == TOK_OCTLIT) {
  1534.         sprintf(cp, "%ld", curtokint);
  1535.         gettok();
  1536.     } else if (curtok == TOK_HAT || curtok == TOK_STRLIT) {
  1537.         ex = makeexpr_charcast(accumulate_strlit());
  1538.         if (ex->kind == EK_CONST) {
  1539.         if (ex->val.i <= 32 || ex->val.i > 126 ||
  1540.             ex->val.i == '\'' || ex->val.i == '\\' ||
  1541.             ex->val.i == '=' || ex->val.i == '}')
  1542.             sprintf(cp, "%ld", ex->val.i);
  1543.         else
  1544.             strcpy(cp, makeCchar(ex->val.i));
  1545.         } else {
  1546.         *buf = 0;
  1547.         *cp = 0;
  1548.         }
  1549.         freeexpr(ex);
  1550.     } else {
  1551.         if (!wexpecttok(TOK_IDENT)) {
  1552.         skiptotoken(TOK_RPAR);
  1553.         return;
  1554.         }
  1555.         if (curtokmeaning)
  1556.         strcpy(cp, curtokmeaning->name);
  1557.         else
  1558.         strcpy(cp, curtokbuf);
  1559.         gettok();
  1560.     }
  1561.     }
  1562. }
  1563.  
  1564.  
  1565. char *find_special_variant(buf, spname, splist, need)
  1566. char *buf, *spname;
  1567. Strlist *splist;
  1568. int need;
  1569. {
  1570.     Strlist *best = NULL;
  1571.     int len, bestlen = -1;
  1572.     char *cp, *cp2;
  1573.  
  1574.     if (!*buf)
  1575.     return NULL;
  1576.     while (splist) {
  1577.     cp = splist->s;
  1578.     cp2 = buf;
  1579.     while (*cp && toupper(*cp) == toupper(*cp2))
  1580.         cp++, cp2++;
  1581.     len = cp2 - buf;
  1582.     if (!*cp && (!*cp2 || *cp2 == '.') && len > bestlen) {
  1583.         best = splist;
  1584.         bestlen = len;
  1585.     }
  1586.     splist = splist->next;
  1587.     }
  1588.     if (bestlen != strlen(buf) && my_strchr(buf, '.')) {
  1589.     if ((need & 1) || bestlen >= 0) {
  1590.         if (need & 2)
  1591.         return NULL;
  1592.         if (spname)
  1593.         note(format_ss("No %s form known for %s [187]",
  1594.                    spname, strupper(buf)));
  1595.     }
  1596.     }
  1597.     if (bestlen >= 0)
  1598.     return (char *)best->value;
  1599.     else
  1600.     return NULL;
  1601. }
  1602.  
  1603.  
  1604.  
  1605. Static char *choose_free_func(ex)
  1606. Expr *ex;
  1607. {
  1608.     if (!*freename) {
  1609.     if (!*freervaluename)
  1610.         return "free";
  1611.     else
  1612.         return freervaluename;
  1613.     }
  1614.     if (!*freervaluename)
  1615.     return freervaluename;
  1616.     if (expr_is_lvalue(ex))
  1617.     return freename;
  1618.     else
  1619.     return freervaluename;
  1620. }
  1621.  
  1622.  
  1623. Static Stmt *proc_dispose()
  1624. {
  1625.     Expr *ex;
  1626.     Type *type;
  1627.     char *name, vbuf[1000];
  1628.  
  1629.     if (!skipopenparen())
  1630.     return NULL;
  1631.     ex = p_expr(tp_anyptr);
  1632.     type = ex->val.type->basetype;
  1633.     parse_special_variant(type, vbuf);
  1634.     skipcloseparen();
  1635.     name = find_special_variant(vbuf, "SpecialFree", specialfrees, 0);
  1636.     if (!name)
  1637.     name = choose_free_func(ex);
  1638.     return makestmt_call(makeexpr_bicall_1(name, tp_void, ex));
  1639. }
  1640.  
  1641.  
  1642.  
  1643. Static Expr *func_exp(ex)
  1644. Expr *ex;
  1645. {
  1646.     return makeexpr_bicall_1("exp", tp_longreal, grabarg(ex, 0));
  1647. }
  1648.  
  1649.  
  1650.  
  1651. Static Expr *func_expo(ex)
  1652. Expr *ex;
  1653. {
  1654.     Meaning *tvar;
  1655.  
  1656.     tvar = makestmttempvar(tp_int, name_TEMP);
  1657.     return makeexpr_comma(makeexpr_bicall_2("frexp", tp_longreal,
  1658.                         grabarg(ex, 0),
  1659.                         makeexpr_addr(makeexpr_var(tvar))),
  1660.               makeexpr_var(tvar));
  1661. }
  1662.  
  1663.  
  1664.  
  1665. int is_std_file(ex)
  1666. Expr *ex;
  1667. {
  1668.     return isvar(ex, mp_input) || isvar(ex, mp_output) ||
  1669.            isvar(ex, mp_stderr);
  1670. }
  1671.  
  1672.  
  1673.  
  1674. Static Expr *iofunc(ex, code)
  1675. Expr *ex;
  1676. int code;
  1677. {
  1678.     Expr *ex2 = NULL, *ex3 = NULL;
  1679.     Meaning *tvar = NULL;
  1680.  
  1681.     if (FCheck(checkfileisopen) && !is_std_file(ex)) {
  1682.         if (isfiletype(ex->val.type, 1) ||
  1683.         (exprspeed(ex) < 5 && nosideeffects(ex, 0))) {
  1684.             ex2 = filebasename(copyexpr(ex));
  1685.     } else {
  1686.             ex3 = ex;
  1687.             tvar = makestmttempvar(ex->val.type, name_TEMP);
  1688.             ex2 = makeexpr_var(tvar);
  1689.             ex = makeexpr_var(tvar);
  1690.         }
  1691.     }
  1692.     ex = filebasename(ex);
  1693.     switch (code) {
  1694.  
  1695.         case 0:  /* eof */
  1696.             if (fileisbuffered(ex, 0) && *eofbufname)
  1697.         ex = makeexpr_bicall_1(eofbufname, tp_boolean, ex);
  1698.         else if (*eofname)
  1699.         ex = makeexpr_bicall_1(eofname, tp_boolean, ex);
  1700.         else
  1701.         ex = makeexpr_rel(EK_NE, makeexpr_bicall_1("feof", tp_int, ex),
  1702.                          makeexpr_long(0));
  1703.             break;
  1704.  
  1705.         case 1:  /* eoln */
  1706.             ex = makeexpr_bicall_1(eolnname, tp_boolean, ex);
  1707.             break;
  1708.  
  1709.         case 2:  /* position or filepos */
  1710.             if (fileisbuffered(ex, 0) && *fileposbufname)
  1711.         ex = makeexpr_bicall_1(fileposbufname, tp_integer, ex);
  1712.         else
  1713.         ex = makeexpr_bicall_1(fileposname, tp_integer, ex);
  1714.             break;
  1715.  
  1716.         case 3:  /* maxpos or filesize */
  1717.             ex = makeexpr_bicall_1(maxposname, tp_integer, ex);
  1718.             break;
  1719.  
  1720.     }
  1721.     if (ex2) {
  1722.         ex = makeexpr_bicall_4("~CHKIO",
  1723.                                (code == 0 || code == 1) ? tp_boolean : tp_integer,
  1724.                                makeexpr_rel(EK_NE, ex2, makeexpr_nil()),
  1725.                    makeexpr_name("FileNotOpen", tp_int),
  1726.                                ex, makeexpr_long(0));
  1727.     }
  1728.     if (ex3)
  1729.         ex = makeexpr_comma(makeexpr_assign(makeexpr_var(tvar), ex3), ex);
  1730.     return ex;
  1731. }
  1732.  
  1733.  
  1734.  
  1735. Static Expr *func_eof()
  1736. {
  1737.     Expr *ex;
  1738.  
  1739.     if (curtok == TOK_LPAR)
  1740.         ex = p_parexpr(tp_text);
  1741.     else
  1742.         ex = makeexpr_var(mp_input);
  1743.     return iofunc(ex, 0);
  1744. }
  1745.  
  1746.  
  1747.  
  1748. Static Expr *func_eoln()
  1749. {
  1750.     Expr *ex;
  1751.  
  1752.     if (curtok == TOK_LPAR)
  1753.         ex = p_parexpr(tp_text);
  1754.     else
  1755.         ex = makeexpr_var(mp_input);
  1756.     return iofunc(ex, 1);
  1757. }
  1758.  
  1759.  
  1760.  
  1761. Static Stmt *proc_escape()
  1762. {
  1763.     Expr *ex;
  1764.  
  1765.     if (curtok == TOK_LPAR)
  1766.         ex = p_parexpr(tp_integer);
  1767.     else
  1768.         ex = makeexpr_long(0);
  1769.     return makestmt_call(makeexpr_bicall_1(name_ESCAPE, tp_int, 
  1770.                                            makeexpr_arglong(ex, 0)));
  1771. }
  1772.  
  1773.  
  1774.  
  1775. Static Stmt *proc_excl()
  1776. {
  1777.     Expr *vex, *ex;
  1778.  
  1779.     if (!skipopenparen())
  1780.     return NULL;
  1781.     vex = p_expr(NULL);
  1782.     if (!skipcomma())
  1783.     return NULL;
  1784.     ex = p_expr(vex->val.type->indextype);
  1785.     skipcloseparen();
  1786.     if (vex->val.type->kind == TK_SMALLSET)
  1787.     return makestmt_assign(vex, makeexpr_bin(EK_BAND, vex->val.type,
  1788.                          copyexpr(vex),
  1789.                          makeexpr_un(EK_BNOT, vex->val.type,
  1790.                                  makeexpr_bin(EK_LSH, vex->val.type,
  1791.                                       makeexpr_longcast(makeexpr_long(1), 1),
  1792.                                       ex))));
  1793.     else
  1794.     return makestmt_call(makeexpr_bicall_2(setremname, tp_void, vex,
  1795.                            makeexpr_arglong(enum_to_int(ex), 0)));
  1796. }
  1797.  
  1798.  
  1799.  
  1800. Stmt *proc_exit()
  1801. {
  1802.     Stmt *sp;
  1803.  
  1804.     if (modula2) {
  1805.     return makestmt(SK_BREAK);
  1806.     }
  1807.     if (curtok == TOK_LPAR) {
  1808.         gettok();
  1809.     if (curtok == TOK_PROGRAM ||
  1810.         (curtok == TOK_IDENT && curtokmeaning->kind == MK_MODULE)) {
  1811.         gettok();
  1812.         skipcloseparen();
  1813.         return makestmt_call(makeexpr_bicall_1("exit", tp_void,
  1814.                            makeexpr_name("EXIT_SUCCESS",
  1815.                                  tp_integer)));
  1816.     }
  1817.         if (curtok != TOK_IDENT || !curtokmeaning || curtokmeaning != curctx)
  1818.             note("Attempting to EXIT beyond this function [188]");
  1819.         gettok();
  1820.     skipcloseparen();
  1821.     }
  1822.     sp = makestmt(SK_RETURN);
  1823.     if (curctx->kind == MK_FUNCTION && curctx->isfunction) {
  1824.         sp->exp1 = makeexpr_var(curctx->cbase);
  1825.         curctx->cbase->refcount++;
  1826.     }
  1827.     return sp;
  1828. }
  1829.  
  1830.  
  1831.  
  1832. Static Expr *file_iofunc(code, base)
  1833. int code;
  1834. long base;
  1835. {
  1836.     Expr *ex;
  1837.     Type *basetype;
  1838.  
  1839.     if (curtok == TOK_LPAR)
  1840.     ex = p_parexpr(tp_text);
  1841.     else
  1842.     ex = makeexpr_var(mp_input);
  1843.     if (!ex->val.type || !ex->val.type->basetype ||
  1844.     !filebasetype(ex->val.type))
  1845.     basetype = tp_char;
  1846.     else
  1847.     basetype = filebasetype(ex->val.type);
  1848.     return makeexpr_plus(makeexpr_div(iofunc(ex, code),
  1849.                                       makeexpr_sizeof(makeexpr_type(basetype), 0)),
  1850.                          makeexpr_long(base));
  1851. }
  1852.  
  1853.  
  1854.  
  1855. Static Expr *func_fcall()
  1856. {
  1857.     Expr *ex, *ex2, *ex3;
  1858.     Type *type, *tp;
  1859.     Meaning *mp, *tvar = NULL;
  1860.     int firstarg = 0;
  1861.  
  1862.     if (!skipopenparen())
  1863.     return NULL;
  1864.     ex2 = p_expr(tp_proc);
  1865.     type = ex2->val.type;
  1866.     if (type->kind != TK_PROCPTR && type->kind != TK_CPROCPTR) {
  1867.         warning("FCALL requires a function variable [209]");
  1868.     type = tp_proc;
  1869.     }
  1870.     ex = makeexpr(EK_SPCALL, 1);
  1871.     ex->val.type = type->basetype->basetype;
  1872.     ex->args[0] = copyexpr(ex2);
  1873.     if (type->escale != 0)
  1874.     ex->args[0] = makeexpr_cast(makeexpr_dotq(ex2, "proc", tp_anyptr),
  1875.                     makepointertype(type->basetype));
  1876.     mp = type->basetype->fbase;
  1877.     if (mp && mp->isreturn) {    /* pointer to buffer for return value */
  1878.         tvar = makestmttempvar(ex->val.type->basetype,
  1879.             (ex->val.type->basetype->kind == TK_STRING) ? name_STRING : name_TEMP);
  1880.         insertarg(&ex, 1, makeexpr_addr(makeexpr_var(tvar)));
  1881.         mp = mp->xnext;
  1882.     firstarg++;
  1883.     }
  1884.     if (mp) {
  1885.         if (wneedtok(TOK_COMMA))
  1886.         ex = p_funcarglist(ex, mp, 0, 0);
  1887.     }
  1888.     if (tvar)
  1889.     ex = makeexpr_hat(ex, 0);    /* returns pointer to structured result */
  1890.     skipcloseparen();
  1891.     if (type->escale != 1 || hasstaticlinks == 2) {
  1892.     freeexpr(ex2);
  1893.     return ex;
  1894.     }
  1895.     ex2 = makeexpr_dotq(ex2, "link", tp_anyptr),
  1896.     ex3 = copyexpr(ex);
  1897.     insertarg(&ex3, ex3->nargs, copyexpr(ex2));
  1898.     tp = maketype(TK_FUNCTION);
  1899.     tp->basetype = type->basetype->basetype;
  1900.     tp->fbase = type->basetype->fbase;
  1901.     tp->issigned = 1;
  1902.     ex3->args[0]->val.type = makepointertype(tp);
  1903.     return makeexpr_cond(makeexpr_rel(EK_NE, ex2, makeexpr_nil()),
  1904.              ex3, ex);
  1905. }
  1906.  
  1907.  
  1908.  
  1909. Static Expr *func_filepos()
  1910. {
  1911.     return file_iofunc(2, seek_base);
  1912. }
  1913.  
  1914.  
  1915.  
  1916. Static Expr *func_filesize()
  1917. {
  1918.     return file_iofunc(3, 1L);
  1919. }
  1920.  
  1921.  
  1922.  
  1923. Static Stmt *proc_fillchar()
  1924. {
  1925.     Expr *vex, *ex, *cex;
  1926.  
  1927.     if (!skipopenparen())
  1928.     return NULL;
  1929.     vex = gentle_cast(makeexpr_addr(p_expr(NULL)), tp_anyptr);
  1930.     if (!skipcomma())
  1931.     return NULL;
  1932.     ex = convert_size(argbasetype(vex), p_expr(tp_integer), "FILLCHAR");
  1933.     if (!skipcomma())
  1934.     return NULL;
  1935.     cex = makeexpr_charcast(p_expr(tp_integer));
  1936.     skipcloseparen();
  1937.     return makestmt_call(makeexpr_bicall_3("memset", tp_void,
  1938.                                            vex,
  1939.                                            makeexpr_arglong(cex, 0),
  1940.                                            makeexpr_arglong(ex, (size_t_long != 0))));
  1941. }
  1942.  
  1943.  
  1944.  
  1945. Static Expr *func_sngl()
  1946. {
  1947.     Expr *ex;
  1948.  
  1949.     ex = p_parexpr(tp_real);
  1950.     return makeexpr_cast(ex, tp_real);
  1951. }
  1952.  
  1953.  
  1954.  
  1955. Static Expr *func_float()
  1956. {
  1957.     Expr *ex;
  1958.  
  1959.     ex = p_parexpr(tp_longreal);
  1960.     return makeexpr_cast(ex, tp_longreal);
  1961. }
  1962.  
  1963.  
  1964.  
  1965. Static Stmt *proc_flush()
  1966. {
  1967.     Expr *ex;
  1968.     Stmt *sp;
  1969.  
  1970.     ex = p_parexpr(tp_text);
  1971.     sp = makestmt_call(makeexpr_bicall_1("fflush", tp_void, filebasename(ex)));
  1972.     if (iocheck_flag)
  1973.         sp = makestmt_seq(sp, makestmt_assign(makeexpr_var(mp_ioresult), 
  1974.                                               makeexpr_long(0)));
  1975.     return sp;
  1976. }
  1977.  
  1978.  
  1979.  
  1980. Static Expr *func_frac(ex)
  1981. Expr *ex;
  1982. {
  1983.     Meaning *tvar;
  1984.  
  1985.     tvar = makestmttempvar(tp_longreal, name_DUMMY);
  1986.     return makeexpr_bicall_2("modf", tp_longreal, 
  1987.                              grabarg(ex, 0),
  1988.                              makeexpr_addr(makeexpr_var(tvar)));
  1989. }
  1990.  
  1991.  
  1992.  
  1993. Static Stmt *proc_freemem(ex)
  1994. Expr *ex;
  1995. {
  1996.     Stmt *sp;
  1997.     Expr *vex;
  1998.  
  1999.     vex = makeexpr_hat(eatcasts(ex->args[0]), 0);
  2000.     sp = makestmt_call(makeexpr_bicall_1(choose_free_func(vex),
  2001.                      tp_void, copyexpr(vex)));
  2002.     if (alloczeronil) {
  2003.         sp = makestmt_if(makeexpr_rel(EK_NE, vex, makeexpr_nil()),
  2004.                          sp, NULL);
  2005.     } else
  2006.         freeexpr(vex);
  2007.     return sp;
  2008. }
  2009.  
  2010.  
  2011.  
  2012. Static Stmt *proc_get()
  2013. {
  2014.     Expr *ex;
  2015.     Type *type;
  2016.  
  2017.     if (curtok == TOK_LPAR)
  2018.     ex = p_parexpr(tp_text);
  2019.     else
  2020.     ex = makeexpr_var(mp_input);
  2021.     requirefilebuffer(ex);
  2022.     type = ex->val.type;
  2023.     if (isfiletype(type, -1) && *chargetname &&
  2024.     filebasetype(type)->kind == TK_CHAR)
  2025.     return makestmt_call(makeexpr_bicall_1(chargetname, tp_void,
  2026.                            filebasename(ex)));
  2027.     else if (isfiletype(type, -1) && *arraygetname &&
  2028.          filebasetype(type)->kind == TK_ARRAY)
  2029.     return makestmt_call(makeexpr_bicall_2(arraygetname, tp_void,
  2030.                            filebasename(ex),
  2031.                            makeexpr_type(filebasetype(type))));
  2032.     else
  2033.     return makestmt_call(makeexpr_bicall_2(getname, tp_void,
  2034.                            filebasename(ex),
  2035.                            makeexpr_type(filebasetype(type))));
  2036. }
  2037.  
  2038.  
  2039.  
  2040. Static Stmt *proc_getmem(ex)
  2041. Expr *ex;
  2042. {
  2043.     Expr *vex, *ex2, *sz = NULL;
  2044.     Stmt *sp;
  2045.  
  2046.     vex = makeexpr_hat(eatcasts(ex->args[0]), 0);
  2047.     ex2 = ex->args[1];
  2048.     if (vex->val.type->kind == TK_POINTER)
  2049.         ex2 = convert_size(vex->val.type->basetype, ex2, "GETMEM");
  2050.     if (alloczeronil)
  2051.         sz = copyexpr(ex2);
  2052.     ex2 = makeexpr_bicall_1(mallocname, tp_anyptr, ex2);
  2053.     sp = makestmt_assign(copyexpr(vex), ex2);
  2054.     if (malloccheck) {
  2055.         sp = makestmt_seq(sp, makestmt_if(makeexpr_rel(EK_EQ, copyexpr(vex), makeexpr_nil()),
  2056.                                           makestmt_call(makeexpr_bicall_0(name_OUTMEM, tp_int)),
  2057.                                           NULL));
  2058.     }
  2059.     if (sz && !isconstantexpr(sz)) {
  2060.         if (alloczeronil == 2)
  2061.             note("Called GETMEM with variable argument [189]");
  2062.         sp = makestmt_if(makeexpr_rel(EK_NE, sz, makeexpr_long(0)),
  2063.                          sp,
  2064.                          makestmt_assign(vex, makeexpr_nil()));
  2065.     } else
  2066.         freeexpr(vex);
  2067.     return sp;
  2068. }
  2069.  
  2070.  
  2071.  
  2072. Static Stmt *proc_gotoxy(ex)
  2073. Expr *ex;
  2074. {
  2075.     return makestmt_call(makeexpr_bicall_2("gotoxy", tp_void,
  2076.                                            makeexpr_arglong(ex->args[0], 0),
  2077.                                            makeexpr_arglong(ex->args[1], 0)));
  2078. }
  2079.  
  2080.  
  2081.  
  2082. Static Expr *handle_vax_hex(ex, fmt, scale)
  2083. Expr *ex;
  2084. char *fmt;
  2085. int scale;
  2086. {
  2087.     Expr *lex, *dex, *vex;
  2088.     Meaning *tvar;
  2089.     Type *tp;
  2090.     long smin, smax;
  2091.     int bits;
  2092.  
  2093.     if (!ex) {
  2094.     if (!skipopenparen())
  2095.         return NULL;
  2096.     ex = p_expr(tp_integer);
  2097.     }
  2098.     tp = true_type(ex);
  2099.     if (ord_range(tp, &smin, &smax))
  2100.     bits = typebits(smin, smax);
  2101.     else
  2102.     bits = 32;
  2103.     if (curtok == TOK_COMMA) {
  2104.     gettok();
  2105.     if (curtok != TOK_COMMA)
  2106.         lex = makeexpr_arglong(p_expr(tp_integer), 0);
  2107.     else
  2108.         lex = NULL;
  2109.     } else
  2110.     lex = NULL;
  2111.     if (!lex) {
  2112.     if (!scale)
  2113.         lex = makeexpr_long(11);
  2114.     else
  2115.         lex = makeexpr_long((bits+scale-1) / scale + 1);
  2116.     }
  2117.     if (curtok == TOK_COMMA) {
  2118.     gettok();
  2119.     dex = makeexpr_arglong(p_expr(tp_integer), 0);
  2120.     } else {
  2121.     if (!scale)
  2122.         dex = makeexpr_long(10);
  2123.     else
  2124.         dex = makeexpr_long((bits+scale-1) / scale);
  2125.     }
  2126.     if (lex->kind == EK_CONST && dex->kind == EK_CONST &&
  2127.     lex->val.i < dex->val.i)
  2128.     lex = NULL;
  2129.     skipcloseparen();
  2130.     tvar = makestmttempvar(tp_str255, name_STRING);
  2131.     vex = makeexpr_var(tvar);
  2132.     ex = makeexpr_forcelongness(ex);
  2133.     if (exprlongness(ex) > 0)
  2134.     fmt = format_s("l%s", fmt);
  2135.     if (checkconst(lex, 0) || checkconst(lex, 1))
  2136.     lex = NULL;
  2137.     if (checkconst(dex, 0) || checkconst(dex, 1))
  2138.     dex = NULL;
  2139.     if (lex) {
  2140.     if (dex)
  2141.         ex = makeexpr_bicall_5("sprintf", tp_str255, vex,
  2142.                    makeexpr_string(format_s("%%*.*%s", fmt)),
  2143.                    lex, dex, ex);
  2144.     else
  2145.         ex = makeexpr_bicall_4("sprintf", tp_str255, vex,
  2146.                    makeexpr_string(format_s("%%*%s", fmt)),
  2147.                    lex, ex);
  2148.     } else {
  2149.     if (dex)
  2150.         ex = makeexpr_bicall_4("sprintf", tp_str255, vex,
  2151.                    makeexpr_string(format_s("%%.*%s", fmt)),
  2152.                    dex, ex);
  2153.     else
  2154.         ex = makeexpr_bicall_3("sprintf", tp_str255, vex,
  2155.                    makeexpr_string(format_s("%%%s", fmt)),
  2156.                    ex);
  2157.     }
  2158.     return ex;
  2159. }
  2160.  
  2161.  
  2162.  
  2163.  
  2164. Static Expr *func_hex()
  2165. {
  2166.     Expr *ex;
  2167.     char *cp;
  2168.  
  2169.     if (!skipopenparen())
  2170.     return NULL;
  2171.     ex = makeexpr_stringcast(p_expr(tp_integer));
  2172.     if ((ex->val.type->kind == TK_STRING ||
  2173.      ex->val.type == tp_strptr) &&
  2174.     curtok != TOK_COMMA) {
  2175.     skipcloseparen();
  2176.     if (ex->kind == EK_CONST) {    /* HP Pascal */
  2177.         cp = getstring(ex);
  2178.         ex = makeexpr_long(my_strtol(cp, NULL, 16));
  2179.         insertarg(&ex, 0, makeexpr_name("%#lx", tp_integer));
  2180.         return ex;
  2181.     } else {
  2182.         return makeexpr_bicall_3("strtol", tp_integer, 
  2183.                      ex, makeexpr_nil(), makeexpr_long(16));
  2184.     }
  2185.     } else {    /* VAX Pascal */
  2186.     return handle_vax_hex(ex, "x", 4);
  2187.     }
  2188. }
  2189.  
  2190.  
  2191.  
  2192. Static Expr *func_hi()
  2193. {
  2194.     Expr *ex;
  2195.  
  2196.     ex = force_unsigned(p_parexpr(tp_integer));
  2197.     return makeexpr_bin(EK_RSH, tp_ubyte,
  2198.                         ex, makeexpr_long(8));
  2199. }
  2200.  
  2201.  
  2202.  
  2203. Static Expr *func_high()
  2204. {
  2205.     Expr *ex;
  2206.     Type *type;
  2207.  
  2208.     ex = p_parexpr(tp_integer);
  2209.     type = ex->val.type;
  2210.     if (type->kind == TK_POINTER)
  2211.     type = type->basetype;
  2212.     if (type->kind == TK_ARRAY ||
  2213.     type->kind == TK_SMALLARRAY) {
  2214.     ex = makeexpr_minus(copyexpr(type->indextype->smax),
  2215.                 copyexpr(type->indextype->smin));
  2216.     } else {
  2217.     warning("HIGH requires an array name parameter [210]");
  2218.     ex = makeexpr_bicall_1("HIGH", tp_int, ex);
  2219.     }
  2220.     return ex;
  2221. }
  2222.  
  2223.  
  2224.  
  2225. Static Expr *func_hiword()
  2226. {
  2227.     Expr *ex;
  2228.  
  2229.     ex = force_unsigned(p_parexpr(tp_unsigned));
  2230.     return makeexpr_bin(EK_RSH, tp_unsigned,
  2231.                         ex, makeexpr_long(16));
  2232. }
  2233.  
  2234.  
  2235.  
  2236. Static Stmt *proc_inc()
  2237. {
  2238.     Expr *vex, *ex;
  2239.  
  2240.     if (!skipopenparen())
  2241.     return NULL;
  2242.     vex = p_expr(NULL);
  2243.     if (curtok == TOK_COMMA) {
  2244.         gettok();
  2245.         ex = p_expr(tp_integer);
  2246.     } else
  2247.         ex = makeexpr_long(1);
  2248.     skipcloseparen();
  2249.     return makestmt_assign(vex, makeexpr_plus(copyexpr(vex), ex));
  2250. }
  2251.  
  2252.  
  2253.  
  2254. Static Stmt *proc_incl()
  2255. {
  2256.     Expr *vex, *ex;
  2257.  
  2258.     if (!skipopenparen())
  2259.     return NULL;
  2260.     vex = p_expr(NULL);
  2261.     if (!skipcomma())
  2262.     return NULL;
  2263.     ex = p_expr(vex->val.type->indextype);
  2264.     skipcloseparen();
  2265.     if (vex->val.type->kind == TK_SMALLSET)
  2266.     return makestmt_assign(vex, makeexpr_bin(EK_BOR, vex->val.type,
  2267.                          copyexpr(vex),
  2268.                          makeexpr_bin(EK_LSH, vex->val.type,
  2269.                                   makeexpr_longcast(makeexpr_long(1), 1),
  2270.                                   ex)));
  2271.     else
  2272.     return makestmt_call(makeexpr_bicall_2(setaddname, tp_void, vex,
  2273.                            makeexpr_arglong(enum_to_int(ex), 0)));
  2274. }
  2275.  
  2276.  
  2277.  
  2278. Static Stmt *proc_insert(ex)
  2279. Expr *ex;
  2280. {
  2281.     return makestmt_call(makeexpr_bicall_3(strinsertname, tp_void,
  2282.                                            ex->args[0], 
  2283.                                            ex->args[1],
  2284.                                            makeexpr_arglong(ex->args[2], 0)));
  2285. }
  2286.  
  2287.  
  2288.  
  2289. Static Expr *func_int()
  2290. {
  2291.     Expr *ex;
  2292.     Meaning *tvar;
  2293.  
  2294.     ex = p_parexpr(tp_integer);
  2295.     if (ex->val.type->kind == TK_REAL) {    /* Turbo Pascal INT */
  2296.     tvar = makestmttempvar(tp_longreal, name_TEMP);
  2297.     return makeexpr_comma(makeexpr_bicall_2("modf", tp_longreal,
  2298.                         grabarg(ex, 0),
  2299.                         makeexpr_addr(makeexpr_var(tvar))),
  2300.                   makeexpr_var(tvar));
  2301.     } else {     /* VAX Pascal INT */
  2302.     return makeexpr_ord(ex);
  2303.     }
  2304. }
  2305.  
  2306.  
  2307. Static Expr *func_uint()
  2308. {
  2309.     Expr *ex;
  2310.  
  2311.     ex = p_parexpr(tp_integer);
  2312.     return makeexpr_cast(ex, tp_unsigned);
  2313. }
  2314.  
  2315.  
  2316.  
  2317. Static Stmt *proc_leave()
  2318. {
  2319.     return makestmt(SK_BREAK);
  2320. }
  2321.  
  2322.  
  2323.  
  2324. Static Expr *func_lo()
  2325. {
  2326.     Expr *ex;
  2327.  
  2328.     ex = gentle_cast(p_parexpr(tp_integer), tp_ushort);
  2329.     return makeexpr_bin(EK_BAND, tp_ubyte,
  2330.                         ex, makeexpr_long(255));
  2331. }
  2332.  
  2333.  
  2334. Static Expr *func_loophole()
  2335. {
  2336.     Type *type;
  2337.     Expr *ex;
  2338.  
  2339.     if (!skipopenparen())
  2340.     return NULL;
  2341.     type = p_type(NULL);
  2342.     if (!skipcomma())
  2343.     return NULL;
  2344.     ex = p_expr(tp_integer);
  2345.     skipcloseparen();
  2346.     return pascaltypecast(type, ex);
  2347. }
  2348.  
  2349.  
  2350.  
  2351. Static Expr *func_lower()
  2352. {
  2353.     Expr *ex;
  2354.     Value val;
  2355.  
  2356.     if (!skipopenparen())
  2357.     return NULL;
  2358.     ex = p_expr(tp_integer);
  2359.     if (curtok == TOK_COMMA) {
  2360.     gettok();
  2361.     val = p_constant(tp_integer);
  2362.     if (!val.type || val.i != 1)
  2363.         note("LOWER(v,n) not supported for n>1 [190]");
  2364.     }
  2365.     skipcloseparen();
  2366.     return copyexpr(ex->val.type->indextype->smin);
  2367. }
  2368.  
  2369.  
  2370.  
  2371. Static Expr *func_loword()
  2372. {
  2373.     Expr *ex;
  2374.  
  2375.     ex = p_parexpr(tp_integer);
  2376.     return makeexpr_bin(EK_BAND, tp_ushort,
  2377.                         ex, makeexpr_long(65535));
  2378. }
  2379.  
  2380.  
  2381.  
  2382. Static Expr *func_ln(ex)
  2383. Expr *ex;
  2384. {
  2385.     return makeexpr_bicall_1("log", tp_longreal, grabarg(ex, 0));
  2386. }
  2387.  
  2388.  
  2389.  
  2390. Static Expr *func_log(ex)
  2391. Expr *ex;
  2392. {
  2393.     return makeexpr_bicall_1("log10", tp_longreal, grabarg(ex, 0));
  2394. }
  2395.  
  2396.  
  2397.  
  2398. Static Expr *func_max()
  2399. {
  2400.     Type *tp;
  2401.     Expr *ex, *ex2;
  2402.  
  2403.     if (!skipopenparen())
  2404.     return NULL;
  2405.     if (curtok == TOK_IDENT && curtokmeaning &&
  2406.     curtokmeaning->kind == MK_TYPE) {
  2407.     tp = curtokmeaning->type;
  2408.     gettok();
  2409.     skipcloseparen();
  2410.     return copyexpr(tp->smax);
  2411.     }
  2412.     ex = p_expr(tp_integer);
  2413.     while (curtok == TOK_COMMA) {
  2414.     gettok();
  2415.     ex2 = p_expr(ex->val.type);
  2416.     if (ex->val.type->kind == TK_REAL) {
  2417.         tp = ex->val.type;
  2418.         if (ex2->val.type->kind != TK_REAL)
  2419.         ex2 = makeexpr_cast(ex2, tp);
  2420.     } else {
  2421.         tp = ex2->val.type;
  2422.         if (ex->val.type->kind != TK_REAL)
  2423.         ex = makeexpr_cast(ex, tp);
  2424.     }
  2425.     ex = makeexpr_bicall_2((tp->kind == TK_REAL) ? "P_rmax" : "P_imax",
  2426.                    tp, ex, ex2);
  2427.     }                
  2428.     skipcloseparen();
  2429.     return ex;
  2430. }
  2431.  
  2432.  
  2433.  
  2434. Static Expr *func_maxavail(ex)
  2435. Expr *ex;
  2436. {
  2437.     freeexpr(ex);
  2438.     return makeexpr_bicall_0("maxavail", tp_integer);
  2439. }
  2440.  
  2441.  
  2442.  
  2443. Static Expr *func_maxpos()
  2444. {
  2445.     return file_iofunc(3, seek_base);
  2446. }
  2447.  
  2448.  
  2449.  
  2450. Static Expr *func_memavail(ex)
  2451. Expr *ex;
  2452. {
  2453.     freeexpr(ex);
  2454.     return makeexpr_bicall_0("memavail", tp_integer);
  2455. }
  2456.  
  2457.  
  2458.  
  2459. Static Expr *var_mem()
  2460. {
  2461.     Expr *ex, *ex2;
  2462.  
  2463.     if (!wneedtok(TOK_LBR))
  2464.     return makeexpr_name("MEM", tp_integer);
  2465.     ex = p_expr(tp_integer);
  2466.     if (curtok == TOK_COLON) {
  2467.     gettok();
  2468.     ex2 = p_expr(tp_integer);
  2469.     ex = makeexpr_bicall_2("MEM", tp_ubyte, ex, ex2);
  2470.     } else {
  2471.     ex = makeexpr_bicall_1("MEM", tp_ubyte, ex);
  2472.     }
  2473.     if (!wneedtok(TOK_RBR))
  2474.     skippasttotoken(TOK_RBR, TOK_SEMI);
  2475.     note("Reference to MEM [191]");
  2476.     return ex;
  2477. }
  2478.  
  2479.  
  2480.  
  2481. Static Expr *var_memw()
  2482. {
  2483.     Expr *ex, *ex2;
  2484.  
  2485.     if (!wneedtok(TOK_LBR))
  2486.     return makeexpr_name("MEMW", tp_integer);
  2487.     ex = p_expr(tp_integer);
  2488.     if (curtok == TOK_COLON) {
  2489.     gettok();
  2490.     ex2 = p_expr(tp_integer);
  2491.     ex = makeexpr_bicall_2("MEMW", tp_ushort, ex, ex2);
  2492.     } else {
  2493.     ex = makeexpr_bicall_1("MEMW", tp_ushort, ex);
  2494.     }
  2495.     if (!wneedtok(TOK_RBR))
  2496.     skippasttotoken(TOK_RBR, TOK_SEMI);
  2497.     note("Reference to MEMW [191]");
  2498.     return ex;
  2499. }
  2500.  
  2501.  
  2502.  
  2503. Static Expr *var_meml()
  2504. {
  2505.     Expr *ex, *ex2;
  2506.  
  2507.     if (!wneedtok(TOK_LBR))
  2508.     return makeexpr_name("MEML", tp_integer);
  2509.     ex = p_expr(tp_integer);
  2510.     if (curtok == TOK_COLON) {
  2511.     gettok();
  2512.     ex2 = p_expr(tp_integer);
  2513.     ex = makeexpr_bicall_2("MEML", tp_integer, ex, ex2);
  2514.     } else {
  2515.     ex = makeexpr_bicall_1("MEML", tp_integer, ex);
  2516.     }
  2517.     if (!wneedtok(TOK_RBR))
  2518.     skippasttotoken(TOK_RBR, TOK_SEMI);
  2519.     note("Reference to MEML [191]");
  2520.     return ex;
  2521. }
  2522.  
  2523.  
  2524.  
  2525. Static Expr *func_min()
  2526. {
  2527.     Type *tp;
  2528.     Expr *ex, *ex2;
  2529.  
  2530.     if (!skipopenparen())
  2531.     return NULL;
  2532.     if (curtok == TOK_IDENT && curtokmeaning &&
  2533.     curtokmeaning->kind == MK_TYPE) {
  2534.     tp = curtokmeaning->type;
  2535.     gettok();
  2536.     skipcloseparen();
  2537.     return copyexpr(tp->smin);
  2538.     }
  2539.     ex = p_expr(tp_integer);
  2540.     while (curtok == TOK_COMMA) {
  2541.     gettok();
  2542.     ex2 = p_expr(ex->val.type);
  2543.     if (ex->val.type->kind == TK_REAL) {
  2544.         tp = ex->val.type;
  2545.         if (ex2->val.type->kind != TK_REAL)
  2546.         ex2 = makeexpr_cast(ex2, tp);
  2547.     } else {
  2548.         tp = ex2->val.type;
  2549.         if (ex->val.type->kind != TK_REAL)
  2550.         ex = makeexpr_cast(ex, tp);
  2551.     }
  2552.     ex = makeexpr_bicall_2((tp->kind == TK_REAL) ? "P_rmin" : "P_imin",
  2553.                    tp, ex, ex2);
  2554.     }                
  2555.     skipcloseparen();
  2556.     return ex;
  2557. }
  2558.  
  2559.  
  2560.  
  2561. Static Stmt *proc_move(ex)
  2562. Expr *ex;
  2563. {
  2564.     ex->args[0] = gentle_cast(ex->args[0], tp_anyptr);    /* source */
  2565.     ex->args[1] = gentle_cast(ex->args[1], tp_anyptr);    /* dest */
  2566.     ex->args[2] = convert_size(choosetype(argbasetype(ex->args[0]),
  2567.                                           argbasetype(ex->args[1])), ex->args[2], "MOVE");
  2568.     return makestmt_call(makeexpr_bicall_3("memmove", tp_void,
  2569.                                            ex->args[1],
  2570.                                            ex->args[0],
  2571.                                            makeexpr_arglong(ex->args[2], (size_t_long != 0))));
  2572. }
  2573.  
  2574.  
  2575.  
  2576. Static Stmt *proc_move_fast()
  2577. {
  2578.     Expr *ex, *ex2, *ex3, *ex4;
  2579.  
  2580.     if (!skipopenparen())
  2581.     return NULL;
  2582.     ex = p_expr(tp_integer);
  2583.     if (!skipcomma())
  2584.     return NULL;
  2585.     ex2 = p_expr(tp_integer);
  2586.     if (!skipcomma())
  2587.     return NULL;
  2588.     ord_range_expr(ex2->val.type->indextype, &ex4, NULL);
  2589.     ex2 = makeexpr_index(ex2, p_expr(tp_integer), copyexpr(ex4));
  2590.     if (!skipcomma())
  2591.     return NULL;
  2592.     ex3 = p_expr(tp_integer);
  2593.     if (!skipcomma())
  2594.     return NULL;
  2595.     ord_range_expr(ex3->val.type->indextype, &ex4, NULL);
  2596.     ex3 = makeexpr_index(ex3, p_expr(tp_integer), copyexpr(ex4));
  2597.     skipcloseparen();
  2598.     ex = convert_size(choosetype(argbasetype(ex2),
  2599.                  argbasetype(ex3)), ex, "MOVE_FAST");
  2600.     return makestmt_call(makeexpr_bicall_3("memmove", tp_void,
  2601.                        makeexpr_addr(ex3),
  2602.                        makeexpr_addr(ex2),
  2603.                        makeexpr_arglong(ex, (size_t_long != 0))));
  2604. }
  2605.  
  2606.  
  2607.  
  2608. Static Stmt *proc_new()
  2609. {
  2610.     Expr *ex, *ex2;
  2611.     Stmt *sp, **spp;
  2612.     Type *type;
  2613.     char *name, *name2 = NULL, vbuf[1000];
  2614.  
  2615.     if (!skipopenparen())
  2616.     return NULL;
  2617.     ex = p_expr(tp_anyptr);
  2618.     type = ex->val.type;
  2619.     if (type->kind == TK_POINTER)
  2620.     type = type->basetype;
  2621.     parse_special_variant(type, vbuf);
  2622.     skipcloseparen();
  2623.     name = find_special_variant(vbuf, NULL, specialmallocs, 3);
  2624.     if (!name) {
  2625.         name2 = find_special_variant(vbuf, NULL, specialsizeofs, 3);
  2626.     if (!name2) {
  2627.         name = find_special_variant(vbuf, NULL, specialmallocs, 1);
  2628.         name2 = find_special_variant(vbuf, NULL, specialsizeofs, 1);
  2629.         if (name || !name2)
  2630.         name = find_special_variant(vbuf, "SpecialMalloc", specialmallocs, 1);
  2631.         else
  2632.         name2 = find_special_variant(vbuf, "SpecialSizeOf", specialsizeofs, 1);
  2633.     }
  2634.     }
  2635.     if (name) {
  2636.     ex2 = makeexpr_bicall_0(name, ex->val.type);
  2637.     } else if (name2) {
  2638.     ex2 = makeexpr_bicall_1(mallocname, tp_anyptr, pc_expr_str(name2));
  2639.     } else {
  2640.     ex2 = makeexpr_bicall_1(mallocname, tp_anyptr,
  2641.                 makeexpr_sizeof(makeexpr_type(type), 1));
  2642.     }
  2643.     sp = makestmt_assign(copyexpr(ex), ex2);
  2644.     if (malloccheck) {
  2645.         sp = makestmt_seq(sp, makestmt_if(makeexpr_rel(EK_EQ,
  2646.                                copyexpr(ex),
  2647.                                makeexpr_nil()),
  2648.                                           makestmt_call(makeexpr_bicall_0(name_OUTMEM, tp_int)),
  2649.                                           NULL));
  2650.     }
  2651.     spp = &sp->next;
  2652.     while (*spp)
  2653.     spp = &(*spp)->next;
  2654.     if (type->kind == TK_RECORD)
  2655.     initfilevars(type->fbase, &spp, makeexpr_hat(ex, 0));
  2656.     else if (isfiletype(type, -1))
  2657.     sp = makestmt_seq(sp, makestmt_call(initfilevar(makeexpr_hat(ex, 0))));
  2658.     else
  2659.     freeexpr(ex);
  2660.     return sp;
  2661. }
  2662.  
  2663.  
  2664.  
  2665. Static Expr *func_oct()
  2666. {
  2667.     return handle_vax_hex(NULL, "o", 3);
  2668. }
  2669.  
  2670.  
  2671.  
  2672. Static Expr *func_octal(ex)
  2673. Expr *ex;
  2674. {
  2675.     char *cp;
  2676.  
  2677.     ex = grabarg(ex, 0);
  2678.     if (ex->kind == EK_CONST) {
  2679.         cp = getstring(ex);
  2680.         ex = makeexpr_long(my_strtol(cp, NULL, 8));
  2681.         insertarg(&ex, 0, makeexpr_name("0%lo", tp_integer));
  2682.         return ex;
  2683.     } else {
  2684.         return makeexpr_bicall_3("strtol", tp_integer, 
  2685.                                  ex, makeexpr_nil(), makeexpr_long(8));
  2686.     }
  2687. }
  2688.  
  2689.  
  2690.  
  2691. Static Expr *func_odd(ex)
  2692. Expr *ex;
  2693. {
  2694.     ex = makeexpr_unlongcast(grabarg(ex, 0));
  2695.     if (*oddname)
  2696.         return makeexpr_bicall_1(oddname, tp_boolean, ex);
  2697.     else
  2698.         return makeexpr_bin(EK_BAND, tp_boolean, ex, makeexpr_long(1));
  2699. }
  2700.  
  2701.  
  2702.  
  2703. Static Stmt *proc_open()
  2704. {
  2705.     return handleopen(2);
  2706. }
  2707.  
  2708.  
  2709.  
  2710. Static Expr *func_ord()
  2711. {
  2712.     Expr *ex;
  2713.  
  2714.     if (wneedtok(TOK_LPAR)) {
  2715.     ex = p_ord_expr();
  2716.     skipcloseparen();
  2717.     } else
  2718.     ex = p_ord_expr();
  2719.     return makeexpr_ord(ex);
  2720. }
  2721.  
  2722.  
  2723.  
  2724. Static Expr *func_ord4()
  2725. {
  2726.     Expr *ex;
  2727.  
  2728.     if (wneedtok(TOK_LPAR)) {
  2729.     ex = p_ord_expr();
  2730.     skipcloseparen();
  2731.     } else
  2732.     ex = p_ord_expr();
  2733.     return makeexpr_longcast(makeexpr_ord(ex), 1);
  2734. }
  2735.  
  2736.  
  2737.  
  2738. Static Stmt *proc_pack()
  2739. {
  2740.     Expr *exs, *exd, *exi, *mind;
  2741.     Meaning *tvar;
  2742.     Stmt *sp;
  2743.  
  2744.     if (!skipopenparen())
  2745.     return NULL;
  2746.     exs = p_expr(NULL);
  2747.     if (!skipcomma())
  2748.     return NULL;
  2749.     exi = p_ord_expr();
  2750.     if (!skipcomma())
  2751.     return NULL;
  2752.     exd = p_expr(NULL);
  2753.     skipcloseparen();
  2754.     if (exs->val.type->kind != TK_ARRAY ||
  2755.     (exd->val.type->kind != TK_ARRAY &&
  2756.      exd->val.type->kind != TK_SMALLARRAY)) {
  2757.     warning("Bad argument types for PACK/UNPACK [325]");
  2758.     return makestmt_call(makeexpr_bicall_3("pack", tp_void,
  2759.                            exs, exi, exd));
  2760.     }
  2761.     if (exs->val.type->smax || exd->val.type->smax) {
  2762.     tvar = makestmttempvar(exd->val.type->indextype, name_TEMP);
  2763.     sp = makestmt(SK_FOR);
  2764.     if (exd->val.type->smin)
  2765.         mind = exd->val.type->smin;
  2766.     else
  2767.         mind = exd->val.type->indextype->smin;
  2768.     sp->exp1 = makeexpr_assign(makeexpr_var(tvar),
  2769.                    copyexpr(mind));
  2770.     sp->exp2 = makeexpr_rel(EK_LE, makeexpr_var(tvar),
  2771.                 copyexpr(exd->val.type->indextype->smax));
  2772.     sp->exp3 = makeexpr_assign(makeexpr_var(tvar),
  2773.                    makeexpr_plus(makeexpr_var(tvar),
  2774.                          makeexpr_long(1)));
  2775.     exi = makeexpr_minus(exi, copyexpr(mind));
  2776.     sp->stm1 = makestmt_assign(p_index(exd, makeexpr_var(tvar)),
  2777.                    p_index(exs,
  2778.                        makeexpr_plus(makeexpr_var(tvar),
  2779.                              exi)));
  2780.     return sp;
  2781.     } else {
  2782.     exi = gentle_cast(exi, exs->val.type->indextype);
  2783.     return makestmt_call(makeexpr_bicall_3("memcpy", exd->val.type,
  2784.                            exd,
  2785.                            makeexpr_addr(p_index(exs, exi)),
  2786.                            makeexpr_sizeof(copyexpr(exd), 0)));
  2787.     }
  2788. }
  2789.  
  2790.  
  2791.  
  2792. Static Expr *func_pad(ex)
  2793. Expr *ex;
  2794. {
  2795.     if (checkconst(ex->args[1], 0) ||    /* "s" is null string */
  2796.     checkconst(ex->args[2], ' ')) {
  2797.         return makeexpr_bicall_4("sprintf", tp_strptr, ex->args[0],
  2798.                                  makeexpr_string("%*s"),
  2799.                                  makeexpr_longcast(ex->args[3], 0),
  2800.                                  makeexpr_string(""));
  2801.     }
  2802.     return makeexpr_bicall_4(strpadname, tp_strptr,
  2803.                  ex->args[0], ex->args[1], ex->args[2],
  2804.                  makeexpr_arglong(ex->args[3], 0));
  2805. }
  2806.  
  2807.  
  2808.  
  2809. Static Stmt *proc_page()
  2810. {
  2811.     Expr *fex, *ex;
  2812.  
  2813.     if (curtok == TOK_LPAR) {
  2814.         fex = p_parexpr(tp_text);
  2815.         ex = makeexpr_bicall_2("fprintf", tp_int,
  2816.                                filebasename(copyexpr(fex)),
  2817.                                makeexpr_string("\f"));
  2818.     } else {
  2819.         fex = makeexpr_var(mp_output);
  2820.         ex = makeexpr_bicall_1("printf", tp_int,
  2821.                                makeexpr_string("\f"));
  2822.     }
  2823.     if (FCheck(checkfilewrite)) {
  2824.         ex = makeexpr_bicall_2("~SETIO", tp_void,
  2825.                                makeexpr_rel(EK_GE, ex, makeexpr_long(0)),
  2826.                    makeexpr_name(filewriteerrorname, tp_int));
  2827.     }
  2828.     return wrapopencheck(makestmt_call(ex), fex);
  2829. }
  2830.  
  2831.  
  2832.  
  2833. Static Expr *func_paramcount(ex)
  2834. Expr *ex;
  2835. {
  2836.     freeexpr(ex);
  2837.     return makeexpr_minus(makeexpr_name(name_ARGC, tp_int),
  2838.                           makeexpr_long(1));
  2839. }
  2840.  
  2841.  
  2842.  
  2843. Static Expr *func_paramstr(ex)
  2844. Expr *ex;
  2845. {
  2846.     Expr *ex2;
  2847.  
  2848.     ex2 = makeexpr_index(makeexpr_name(name_ARGV,
  2849.                        makepointertype(tp_strptr)),
  2850.              makeexpr_unlongcast(ex->args[1]),
  2851.              makeexpr_long(0));
  2852.     ex2->val.type = tp_str255;
  2853.     return makeexpr_bicall_3("sprintf", tp_strptr,
  2854.                  ex->args[0],
  2855.                  makeexpr_string("%s"),
  2856.                  ex2);
  2857. }
  2858.  
  2859.  
  2860.  
  2861. Static Expr *func_pi()
  2862. {
  2863.     return makeexpr_name("M_PI", tp_longreal);
  2864. }
  2865.  
  2866.  
  2867.  
  2868. Static Expr *var_port()
  2869. {
  2870.     Expr *ex;
  2871.  
  2872.     if (!wneedtok(TOK_LBR))
  2873.     return makeexpr_name("PORT", tp_integer);
  2874.     ex = p_expr(tp_integer);
  2875.     if (!wneedtok(TOK_RBR))
  2876.     skippasttotoken(TOK_RBR, TOK_SEMI);
  2877.     note("Reference to PORT [191]");
  2878.     return makeexpr_bicall_1("PORT", tp_ubyte, ex);
  2879. }
  2880.  
  2881.  
  2882.  
  2883. Static Expr *var_portw()
  2884. {
  2885.     Expr *ex;
  2886.  
  2887.     if (!wneedtok(TOK_LBR))
  2888.     return makeexpr_name("PORTW", tp_integer);
  2889.     ex = p_expr(tp_integer);
  2890.     if (!wneedtok(TOK_RBR))
  2891.     skippasttotoken(TOK_RBR, TOK_SEMI);
  2892.     note("Reference to PORTW [191]");
  2893.     return makeexpr_bicall_1("PORTW", tp_ushort, ex);
  2894. }
  2895.  
  2896.  
  2897.  
  2898. Static Expr *func_pos(ex)
  2899. Expr *ex;
  2900. {
  2901.     char *cp;
  2902.  
  2903.     cp = strposname;
  2904.     if (!*cp) {
  2905.         note("POS function used [192]");
  2906.         cp = "POS";
  2907.     } 
  2908.     return makeexpr_bicall_3(cp, tp_int,
  2909.                              ex->args[1], 
  2910.                              ex->args[0],
  2911.                              makeexpr_long(1));
  2912. }
  2913.  
  2914.  
  2915.  
  2916. Static Expr *func_ptr(ex)
  2917. Expr *ex;
  2918. {
  2919.     note("PTR function was used [193]");
  2920.     return ex;
  2921. }
  2922.  
  2923.  
  2924.  
  2925. Static Expr *func_position()
  2926. {
  2927.     return file_iofunc(2, seek_base);
  2928. }
  2929.  
  2930.  
  2931.  
  2932. Static Expr *func_pred()
  2933. {
  2934.     Expr *ex;
  2935.  
  2936.     if (wneedtok(TOK_LPAR)) {
  2937.     ex = p_ord_expr();
  2938.     skipcloseparen();
  2939.     } else
  2940.     ex = p_ord_expr();
  2941. #if 1
  2942.     ex = makeexpr_inc(ex, makeexpr_long(-1));
  2943. #else
  2944.     ex = makeexpr_cast(makeexpr_plus(ex, makeexpr_long(-1)), ex->val.type);
  2945. #endif
  2946.     return ex;
  2947. }
  2948.  
  2949.  
  2950.  
  2951. Static Stmt *proc_put()
  2952. {
  2953.     Expr *ex;
  2954.     Type *type;
  2955.  
  2956.     if (curtok == TOK_LPAR)
  2957.     ex = p_parexpr(tp_text);
  2958.     else
  2959.     ex = makeexpr_var(mp_output);
  2960.     requirefilebuffer(ex);
  2961.     type = ex->val.type;
  2962.     if (isfiletype(type, -1) && *charputname &&
  2963.     filebasetype(type)->kind == TK_CHAR)
  2964.     return makestmt_call(makeexpr_bicall_1(charputname, tp_void,
  2965.                            filebasename(ex)));
  2966.     else if (isfiletype(type, -1) && *arrayputname &&
  2967.          filebasetype(type)->kind == TK_ARRAY)
  2968.     return makestmt_call(makeexpr_bicall_2(arrayputname, tp_void,
  2969.                            filebasename(ex),
  2970.                            makeexpr_type(filebasetype(type))));
  2971.     else
  2972.     return makestmt_call(makeexpr_bicall_2(putname, tp_void,
  2973.                            filebasename(ex),
  2974.                            makeexpr_type(filebasetype(type))));
  2975. }
  2976.  
  2977.  
  2978.  
  2979. Static Expr *func_pwroften(ex)
  2980. Expr *ex;
  2981. {
  2982.     return makeexpr_bicall_2("pow", tp_longreal,
  2983.                  makeexpr_real("10.0"), grabarg(ex, 0));
  2984. }
  2985.  
  2986.  
  2987.  
  2988. Static Stmt *proc_reset()
  2989. {
  2990.     return handleopen(0);
  2991. }
  2992.  
  2993.  
  2994.  
  2995. Static Stmt *proc_rewrite()
  2996. {
  2997.     return handleopen(1);
  2998. }
  2999.  
  3000.  
  3001.  
  3002.  
  3003. Stmt *doseek(fex, ex)
  3004. Expr *fex, *ex;
  3005. {
  3006.     Expr *ex2;
  3007.     Type *basetype = filebasetype(fex->val.type);
  3008.  
  3009.     if (ansiC == 1)
  3010.         ex2 = makeexpr_name("SEEK_SET", tp_int);
  3011.     else
  3012.         ex2 = makeexpr_long(0);
  3013.     ex = makeexpr_bicall_3("fseek", tp_int,
  3014.                            filebasename(copyexpr(fex)),
  3015.                            makeexpr_arglong(
  3016.                                makeexpr_times(makeexpr_minus(ex,
  3017.                                                              makeexpr_long(seek_base)),
  3018.                                               makeexpr_sizeof(makeexpr_type(basetype), 0)),
  3019.                                1),
  3020.                            ex2);
  3021.     if (FCheck(checkfileseek)) {
  3022.         ex = makeexpr_bicall_2("~SETIO", tp_void,
  3023.                                makeexpr_rel(EK_EQ, ex, makeexpr_long(0)),
  3024.                    makeexpr_name(endoffilename, tp_int));
  3025.     }
  3026.     return makestmt_call(ex);
  3027. }
  3028.  
  3029.  
  3030.  
  3031.  
  3032. Static Expr *makegetchar(fex)
  3033. Expr *fex;
  3034. {
  3035.     if (isvar(fex, mp_input))
  3036.         return makeexpr_bicall_0("getchar", tp_char);
  3037.     else
  3038.         return makeexpr_bicall_1("getc", tp_char, filebasename(copyexpr(fex)));
  3039. }
  3040.  
  3041.  
  3042.  
  3043. Static Stmt *fixscanf(sp, fex)
  3044. Stmt *sp;
  3045. Expr *fex;
  3046. {
  3047.     int nargs, i, isstrread;
  3048.     char *cp;
  3049.     Expr *ex;
  3050.     Stmt *sp2;
  3051.  
  3052.     isstrread = (fex->val.type->kind == TK_STRING);
  3053.     if (sp->kind == SK_ASSIGN && sp->exp1->kind == EK_BICALL &&
  3054.         !strcmp(sp->exp1->val.s, "scanf")) {
  3055.         if (sp->exp1->args[0]->kind == EK_CONST &&
  3056.             !(sp->exp1->args[0]->val.i&1) && !isstrread) {
  3057.             cp = sp->exp1->args[0]->val.s;    /* scanf("%c%c") -> getchar;getchar */
  3058.             for (i = 0; cp[i] == '%' && cp[i+1] == 'c'; ) {
  3059.                 i += 2;
  3060.                 if (i == sp->exp1->args[0]->val.i) {
  3061.                     sp2 = NULL;
  3062.                     for (i = 1; i < sp->exp1->nargs; i++) {
  3063.                         ex = makeexpr_hat(sp->exp1->args[i], 0);
  3064.                         sp2 = makestmt_seq(sp2,
  3065.                                            makestmt_assign(copyexpr(ex),
  3066.                                                            makegetchar(fex)));
  3067.                         if (checkeof(fex)) {
  3068.                             sp2 = makestmt_seq(sp2,
  3069.                                 makestmt_call(makeexpr_bicall_2("~SETIO", tp_void,
  3070.                                                                 makeexpr_rel(EK_NE,
  3071.                                                                              ex,
  3072.                                                                              makeexpr_name("EOF", tp_char)),
  3073.                                 makeexpr_name(endoffilename, tp_int))));
  3074.                         } else
  3075.                             freeexpr(ex);
  3076.                     }
  3077.                     return sp2;
  3078.                 }
  3079.             }
  3080.         }
  3081.         nargs = sp->exp1->nargs - 1;
  3082.         if (isstrread) {
  3083.             strchange(&sp->exp1->val.s, "sscanf");
  3084.             insertarg(&sp->exp1, 0, copyexpr(fex));
  3085.         } else if (!isvar(fex, mp_input)) {
  3086.             strchange(&sp->exp1->val.s, "fscanf");
  3087.             insertarg(&sp->exp1, 0, filebasename(copyexpr(fex)));
  3088.         }
  3089.         if (FCheck(checkreadformat)) {
  3090.             if (checkeof(fex) && !isstrread)
  3091.                 ex = makeexpr_cond(makeexpr_rel(EK_NE,
  3092.                                                 makeexpr_bicall_1("feof",
  3093.                                   tp_int,
  3094.                                   filebasename(copyexpr(fex))),
  3095.                                                 makeexpr_long(0)),
  3096.                    makeexpr_name(endoffilename, tp_int),
  3097.                    makeexpr_name(badinputformatname, tp_int));
  3098.             else
  3099.         ex = makeexpr_name(badinputformatname, tp_int);
  3100.             sp->exp1 = makeexpr_bicall_2("~SETIO", tp_void,
  3101.                                          makeexpr_rel(EK_EQ,
  3102.                                                       sp->exp1,
  3103.                                                       makeexpr_long(nargs)),
  3104.                                          ex);
  3105.         } else if (checkeof(fex) && !isstrread) {
  3106.             sp->exp1 = makeexpr_bicall_2("~SETIO", tp_void,
  3107.                                          makeexpr_rel(EK_NE,
  3108.                                                       sp->exp1,
  3109.                                                       makeexpr_name("EOF", tp_int)),
  3110.                      makeexpr_name(endoffilename, tp_int));
  3111.         }
  3112.     }
  3113.     return sp;
  3114. }
  3115.  
  3116.  
  3117.  
  3118. Static Expr *makefgets(vex, lex, fex)
  3119. Expr *vex, *lex, *fex;
  3120. {
  3121.     Expr *ex;
  3122.  
  3123.     ex = makeexpr_bicall_3("fgets", tp_strptr,
  3124.                            vex,
  3125.                            lex,
  3126.                            filebasename(copyexpr(fex)));
  3127.     if (checkeof(fex)) {
  3128.         ex = makeexpr_bicall_2("~SETIO", tp_void,
  3129.                                makeexpr_rel(EK_NE, ex, makeexpr_nil()),
  3130.                    makeexpr_name(endoffilename, tp_int));
  3131.     }
  3132.     return ex;
  3133. }
  3134.  
  3135.  
  3136.  
  3137. Static Stmt *skipeoln(fex)
  3138. Expr *fex;
  3139. {
  3140.     Meaning *tvar;
  3141.     Expr *ex;
  3142.  
  3143.     if (!strcmp(readlnname, "fgets")) {
  3144.         tvar = makestmttempvar(tp_str255, name_STRING);
  3145.         return makestmt_call(makefgets(makeexpr_var(tvar),
  3146.                                        makeexpr_long(stringceiling+1),
  3147.                                        filebasename(fex)));
  3148.     } else if (!strcmp(readlnname, "scanf") || !*readlnname) {
  3149.         if (checkeof(fex))
  3150.             ex = makeexpr_bicall_2("~SETIO", tp_void,
  3151.                                    makeexpr_rel(EK_NE,
  3152.                                                 makegetchar(fex),
  3153.                                                 makeexpr_name("EOF", tp_char)),
  3154.                    makeexpr_name(endoffilename, tp_int));
  3155.         else
  3156.             ex = makegetchar(fex);
  3157.         return makestmt_seq(fixscanf(
  3158.                     makestmt_call(makeexpr_bicall_1("scanf", tp_int,
  3159.                                                     makeexpr_string("%*[^\n]"))), fex),
  3160.                     makestmt_call(ex));
  3161.     } else {
  3162.         return makestmt_call(makeexpr_bicall_1(readlnname, tp_void,
  3163.                                                filebasename(copyexpr(fex))));
  3164.     }
  3165. }
  3166.  
  3167.  
  3168.  
  3169. Static Stmt *handleread_text(fex, var, isreadln)
  3170. Expr *fex, *var;
  3171. int isreadln;
  3172. {
  3173.     Stmt *spbase, *spafter, *sp;
  3174.     Expr *ex = NULL, *exj = NULL;
  3175.     Type *type;
  3176.     Meaning *tvar, *tempcp, *mp;
  3177.     int i, isstrread, scanfmode, readlnflag, varstring, maxstring;
  3178.     int longstrsize = (longstringsize > 0) ? longstringsize : stringceiling;
  3179.     long rmin, rmax;
  3180.     char *fmt;
  3181.  
  3182.     spbase = NULL;
  3183.     spafter = NULL;
  3184.     sp = NULL;
  3185.     tempcp = NULL;
  3186.     if (fex->val.type->kind == TK_ARRAY)
  3187.     fex = makeexpr_sprintfify(fex);
  3188.     isstrread = (fex->val.type->kind == TK_STRING);
  3189.     if (isstrread) {
  3190.         exj = var;
  3191.         var = p_expr(NULL);
  3192.     }
  3193.     scanfmode = !strcmp(readlnname, "scanf") || !*readlnname || isstrread;
  3194.     for (;;) {
  3195.         readlnflag = isreadln && curtok == TOK_RPAR;
  3196.         if (var->val.type->kind == TK_STRING && !isstrread) {
  3197.             if (sp)
  3198.                 spbase = makestmt_seq(spbase, fixscanf(sp, fex));
  3199.             spbase = makestmt_seq(spbase, spafter);
  3200.             varstring = (varstrings && var->kind == EK_VAR &&
  3201.                          (mp = (Meaning *)var->val.i)->kind == MK_VARPARAM &&
  3202.                          mp->type == tp_strptr);
  3203.             maxstring = (strmax(var) >= longstrsize && !varstring);
  3204.             if (isvar(fex, mp_input) && maxstring && usegets && readlnflag) {
  3205.                 spbase = makestmt_seq(spbase,
  3206.                                       makestmt_call(makeexpr_bicall_1("gets", tp_str255,
  3207.                                                                       makeexpr_addr(var))));
  3208.                 isreadln = 0;
  3209.             } else if (scanfmode && !varstring &&
  3210.                        (*readlnname || !isreadln)) {
  3211.                 spbase = makestmt_seq(spbase, makestmt_assign(makeexpr_hat(copyexpr(var), 0),
  3212.                                                               makeexpr_char(0)));
  3213.                 if (maxstring && usegets)
  3214.                     ex = makeexpr_string("%[^\n]");
  3215.                 else
  3216.                     ex = makeexpr_string(format_d("%%%d[^\n]", strmax(var)));
  3217.                 ex = makeexpr_bicall_2("scanf", tp_int, ex, makeexpr_addr(var));
  3218.                 spbase = makestmt_seq(spbase, fixscanf(makestmt_call(ex), fex));
  3219.                 if (readlnflag && maxstring && usegets) {
  3220.                     spbase = makestmt_seq(spbase, makestmt_call(makegetchar(fex)));
  3221.                     isreadln = 0;
  3222.                 }
  3223.             } else {
  3224.                 ex = makeexpr_plus(strmax_func(var), makeexpr_long(1));
  3225.                 spbase = makestmt_seq(spbase,
  3226.                                       makestmt_call(makefgets(makeexpr_addr(copyexpr(var)),
  3227.                                                               ex,
  3228.                                                               fex)));
  3229.                 if (!tempcp)
  3230.                     tempcp = makestmttempvar(tp_charptr, name_TEMP);
  3231.                 spbase = makestmt_seq(spbase,
  3232.                                       makestmt_assign(makeexpr_var(tempcp),
  3233.                                                       makeexpr_bicall_2("strchr", tp_charptr,
  3234.                                                                         makeexpr_addr(copyexpr(var)),
  3235.                                                                         makeexpr_char('\n'))));
  3236.                 sp = makestmt_assign(makeexpr_hat(makeexpr_var(tempcp), 0),
  3237.                                      makeexpr_long(0));
  3238.                 if (readlnflag)
  3239.                     isreadln = 0;
  3240.                 else
  3241.                     sp = makestmt_seq(sp,
  3242.                                       makestmt_call(makeexpr_bicall_2("ungetc", tp_void,
  3243.                                                                       makeexpr_char('\n'),
  3244.                                                                       filebasename(copyexpr(fex)))));
  3245.                 spbase = makestmt_seq(spbase, makestmt_if(makeexpr_rel(EK_NE,
  3246.                                                                        makeexpr_var(tempcp),
  3247.                                                                        makeexpr_nil()),
  3248.                                                           sp,
  3249.                                                           NULL));
  3250.             }
  3251.             sp = NULL;
  3252.             spafter = NULL;
  3253.         } else if (var->val.type->kind == TK_ARRAY && !isstrread) {
  3254.             if (sp)
  3255.                 spbase = makestmt_seq(spbase, fixscanf(sp, fex));
  3256.             spbase = makestmt_seq(spbase, spafter);
  3257.         ex = makeexpr_sizeof(copyexpr(var), 0);
  3258.         if (readlnflag) {
  3259.         spbase = makestmt_seq(spbase,
  3260.              makestmt_call(
  3261.              makeexpr_bicall_3("P_readlnpaoc", tp_void,
  3262.                        filebasename(copyexpr(fex)),
  3263.                        makeexpr_addr(var),
  3264.                        makeexpr_arglong(ex, 0))));
  3265.         isreadln = 0;
  3266.         } else {
  3267.         spbase = makestmt_seq(spbase,
  3268.              makestmt_call(
  3269.              makeexpr_bicall_3("P_readpaoc", tp_void,
  3270.                        filebasename(copyexpr(fex)),
  3271.                        makeexpr_addr(var),
  3272.                        makeexpr_arglong(ex, 0))));
  3273.         }
  3274.             sp = NULL;
  3275.             spafter = NULL;
  3276.         } else {
  3277.             switch (ord_type(var->val.type)->kind) {
  3278.  
  3279.                 case TK_INTEGER:
  3280.             fmt = "d";
  3281.             if (curtok == TOK_COLON) {
  3282.             gettok();
  3283.             if (curtok == TOK_IDENT &&
  3284.                 !strcicmp(curtokbuf, "HEX")) {
  3285.                 fmt = "x";
  3286.             } else if (curtok == TOK_IDENT &&
  3287.                 !strcicmp(curtokbuf, "OCT")) {
  3288.                 fmt = "o";
  3289.             } else if (curtok == TOK_IDENT &&
  3290.                 !strcicmp(curtokbuf, "BIN")) {
  3291.                 fmt = "b";
  3292.                 note("Using %b for binary format in scanf [194]");
  3293.             } else
  3294.                 warning("Unrecognized format specified in READ [212]");
  3295.             gettok();
  3296.             }
  3297.                     type = findbasetype(var->val.type, ODECL_NOPRES);
  3298.                     if (exprlongness(var) > 0)
  3299.                         ex = makeexpr_string(format_s("%%l%s", fmt));
  3300.                     else if (type == tp_integer || type == tp_int ||
  3301.                              type == tp_uint || type == tp_sint)
  3302.                         ex = makeexpr_string(format_s("%%%s", fmt));
  3303.                     else if (type == tp_sshort || type == tp_ushort)
  3304.                         ex = makeexpr_string(format_s("%%h%s", fmt));
  3305.                     else {
  3306.                         tvar = makestmttempvar(tp_int, name_TEMP);
  3307.                         spafter = makestmt_seq(spafter,
  3308.                                                makestmt_assign(var,
  3309.                                                                makeexpr_var(tvar)));
  3310.                         var = makeexpr_var(tvar);
  3311.                         ex = makeexpr_string(format_s("%%%s", fmt));
  3312.                     }
  3313.                     break;
  3314.  
  3315.                 case TK_CHAR:
  3316.                     ex = makeexpr_string("%c");
  3317.                     if (newlinespace && !isstrread) {
  3318.                         spafter = makestmt_seq(spafter,
  3319.                                                makestmt_if(makeexpr_rel(EK_EQ,
  3320.                                                                         copyexpr(var),
  3321.                                                                         makeexpr_char('\n')),
  3322.                                                            makestmt_assign(copyexpr(var),
  3323.                                                                            makeexpr_char(' ')),
  3324.                                                            NULL));
  3325.                     }
  3326.                     break;
  3327.  
  3328.                 case TK_BOOLEAN:
  3329.                     tvar = makestmttempvar(tp_str255, name_STRING);
  3330.                     spafter = makestmt_seq(spafter,
  3331.                         makestmt_assign(var,
  3332.                                         makeexpr_or(makeexpr_rel(EK_EQ,
  3333.                                                                  makeexpr_hat(makeexpr_var(tvar), 0),
  3334.                                                                  makeexpr_char('T')),
  3335.                                                     makeexpr_rel(EK_EQ,
  3336.                                                                  makeexpr_hat(makeexpr_var(tvar), 0),
  3337.                                                                  makeexpr_char('t')))));
  3338.                     var = makeexpr_var(tvar);
  3339.                     ex = makeexpr_string(" %[a-zA-Z]");
  3340.                     break;
  3341.  
  3342.                 case TK_ENUM:
  3343.                     warning("READ on enumerated types not yet supported [213]");
  3344.                     if (useenum)
  3345.                         ex = makeexpr_string("%d");
  3346.                     else
  3347.                         ex = makeexpr_string("%hd");
  3348.                     break;
  3349.  
  3350.                 case TK_REAL:
  3351.             if (var->val.type == tp_longreal)
  3352.             ex = makeexpr_string("%lg");
  3353.             else
  3354.             ex = makeexpr_string("%g");
  3355.                     break;
  3356.  
  3357.                 case TK_STRING:     /* strread only */
  3358.                     ex = makeexpr_string(format_d("%%%lds", strmax(fex)));
  3359.                     break;
  3360.  
  3361.                 case TK_ARRAY:      /* strread only */
  3362.                     if (!ord_range(ex->val.type->indextype, &rmin, &rmax)) {
  3363.                         rmin = 1;
  3364.                         rmax = 1;
  3365.                         note("Can't determine length of packed array of chars [195]");
  3366.                     }
  3367.                     ex = makeexpr_string(format_d("%%%ldc", rmax-rmin+1));
  3368.                     break;
  3369.  
  3370.                 default:
  3371.                     note("Element has wrong type for WRITE statement [196]");
  3372.                     ex = NULL;
  3373.                     break;
  3374.  
  3375.             }
  3376.             if (ex) {
  3377.                 var = makeexpr_addr(var);
  3378.                 if (sp) {
  3379.                     sp->exp1->args[0] = makeexpr_concat(sp->exp1->args[0], ex, 0);
  3380.                     insertarg(&sp->exp1, sp->exp1->nargs, var);
  3381.                 } else {
  3382.                     sp = makestmt_call(makeexpr_bicall_2("scanf", tp_int, ex, var));
  3383.                 }
  3384.             }
  3385.         }
  3386.         if (curtok == TOK_COMMA) {
  3387.             gettok();
  3388.             var = p_expr(NULL);
  3389.         } else
  3390.             break;
  3391.     }
  3392.     if (sp) {
  3393.         if (isstrread && !FCheck(checkreadformat) &&
  3394.             ((i=0, checkstring(sp->exp1->args[0], "%d")) ||
  3395.              (i++, checkstring(sp->exp1->args[0], "%ld")) ||
  3396.              (i++, checkstring(sp->exp1->args[0], "%hd")) ||
  3397.              (i++, checkstring(sp->exp1->args[0], "%lg")))) {
  3398.             if (fullstrread != 0 && exj) {
  3399.                 tvar = makestmttempvar(tp_strptr, name_STRING);
  3400.                 sp->exp1 = makeexpr_assign(makeexpr_hat(sp->exp1->args[1], 0),
  3401.                                            (i == 3) ? makeexpr_bicall_2("strtod", tp_longreal,
  3402.                                                                         copyexpr(fex),
  3403.                                                                         makeexpr_addr(makeexpr_var(tvar)))
  3404.                                                     : makeexpr_bicall_3("strtol", tp_integer,
  3405.                                                                         copyexpr(fex),
  3406.                                                                         makeexpr_addr(makeexpr_var(tvar)),
  3407.                                                                         makeexpr_long(10)));
  3408.         spafter = makestmt_seq(spafter,
  3409.                        makestmt_assign(copyexpr(exj),
  3410.                                makeexpr_minus(makeexpr_var(tvar),
  3411.                                       makeexpr_addr(copyexpr(fex)))));
  3412.             } else {
  3413.                 sp->exp1 = makeexpr_assign(makeexpr_hat(sp->exp1->args[1], 0),
  3414.                                            makeexpr_bicall_1((i == 1) ? "atol" : (i == 3) ? "atof" : "atoi",
  3415.                                                              (i == 1) ? tp_integer : (i == 3) ? tp_longreal : tp_int,
  3416.                                                              copyexpr(fex)));
  3417.             }
  3418.         } else if (isstrread && fullstrread != 0 && exj) {
  3419.             sp->exp1->args[0] = makeexpr_concat(sp->exp1->args[0],
  3420.                                                 makeexpr_string(sizeof_int >= 32 ? "%n" : "%ln"), 0);
  3421.             insertarg(&sp->exp1, sp->exp1->nargs, makeexpr_addr(copyexpr(exj)));
  3422.         } else if (isreadln && scanfmode && !FCheck(checkreadformat)) {
  3423.             isreadln = 0;
  3424.             sp->exp1->args[0] = makeexpr_concat(sp->exp1->args[0],
  3425.                                                 makeexpr_string("%*[^\n]"), 0);
  3426.             spafter = makestmt_seq(makestmt_call(makegetchar(fex)), spafter);
  3427.         }
  3428.         spbase = makestmt_seq(spbase, fixscanf(sp, fex));
  3429.     }
  3430.     spbase = makestmt_seq(spbase, spafter);
  3431.     if (isreadln)
  3432.         spbase = makestmt_seq(spbase, skipeoln(fex));
  3433.     return spbase;
  3434. }
  3435.  
  3436.  
  3437.  
  3438. Static Stmt *handleread_bin(fex, var)
  3439. Expr *fex, *var;
  3440. {
  3441.     Type *basetype;
  3442.     Stmt *sp;
  3443.     Expr *ex, *tvardef = NULL;
  3444.  
  3445.     sp = NULL;
  3446.     basetype = filebasetype(fex->val.type);
  3447.     for (;;) {
  3448.         ex = makeexpr_bicall_4("fread", tp_integer, makeexpr_addr(var),
  3449.                                                     makeexpr_sizeof(makeexpr_type(basetype), 0),
  3450.                                                     makeexpr_long(1),
  3451.                                                     filebasename(copyexpr(fex)));
  3452.         if (checkeof(fex)) {
  3453.             ex = makeexpr_bicall_2("~SETIO", tp_void,
  3454.                                    makeexpr_rel(EK_EQ, ex, makeexpr_long(1)),
  3455.                    makeexpr_name(endoffilename, tp_int));
  3456.         }
  3457.         sp = makestmt_seq(sp, makestmt_call(ex));
  3458.         if (curtok == TOK_COMMA) {
  3459.             gettok();
  3460.             var = p_expr(NULL);
  3461.         } else
  3462.             break;
  3463.     }
  3464.     freeexpr(tvardef);
  3465.     return sp;
  3466. }
  3467.  
  3468.  
  3469.  
  3470. Static Stmt *proc_read()
  3471. {
  3472.     Expr *fex, *ex;
  3473.     Stmt *sp;
  3474.  
  3475.     if (!skipopenparen())
  3476.     return NULL;
  3477.     ex = p_expr(NULL);
  3478.     if (isfiletype(ex->val.type, -1) && wneedtok(TOK_COMMA)) {
  3479.         fex = ex;
  3480.         ex = p_expr(NULL);
  3481.     } else {
  3482.         fex = makeexpr_var(mp_input);
  3483.     }
  3484.     if (fex->val.type == tp_text || fex->val.type == tp_bigtext)
  3485.         sp = handleread_text(fex, ex, 0);
  3486.     else
  3487.         sp = handleread_bin(fex, ex);
  3488.     skipcloseparen();
  3489.     return wrapopencheck(sp, fex);
  3490. }
  3491.  
  3492.  
  3493.  
  3494. Static Stmt *proc_readdir()
  3495. {
  3496.     Expr *fex, *ex;
  3497.     Stmt *sp;
  3498.  
  3499.     if (!skipopenparen())
  3500.     return NULL;
  3501.     fex = p_expr(tp_text);
  3502.     if (!skipcomma())
  3503.     return NULL;
  3504.     ex = p_expr(tp_integer);
  3505.     sp = doseek(fex, ex);
  3506.     if (!skipopenparen())
  3507.     return sp;
  3508.     sp = makestmt_seq(sp, handleread_bin(fex, p_expr(NULL)));
  3509.     skipcloseparen();
  3510.     return wrapopencheck(sp, fex);
  3511. }
  3512.  
  3513.  
  3514.  
  3515. Static Stmt *proc_readln()
  3516. {
  3517.     Expr *fex, *ex;
  3518.     Stmt *sp;
  3519.  
  3520.     if (curtok != TOK_LPAR) {
  3521.         fex = makeexpr_var(mp_input);
  3522.         return wrapopencheck(skipeoln(copyexpr(fex)), fex);
  3523.     } else {
  3524.         gettok();
  3525.         ex = p_expr(NULL);
  3526.         if (isfiletype(ex->val.type, -1)) {
  3527.             fex = ex;
  3528.             if (curtok == TOK_RPAR || !wneedtok(TOK_COMMA)) {
  3529.                 skippasttotoken(TOK_RPAR, TOK_SEMI);
  3530.                 return wrapopencheck(skipeoln(copyexpr(fex)), fex);
  3531.             } else {
  3532.                 ex = p_expr(NULL);
  3533.             }
  3534.         } else {
  3535.             fex = makeexpr_var(mp_input);
  3536.         }
  3537.         sp = handleread_text(fex, ex, 1);
  3538.         skipcloseparen();
  3539.     }
  3540.     return wrapopencheck(sp, fex);
  3541. }
  3542.  
  3543.  
  3544.  
  3545. Static Stmt *proc_readv()
  3546. {
  3547.     Expr *vex;
  3548.     Stmt *sp;
  3549.  
  3550.     if (!skipopenparen())
  3551.     return NULL;
  3552.     vex = p_expr(tp_str255);
  3553.     if (!skipcomma())
  3554.     return NULL;
  3555.     sp = handleread_text(vex, NULL, 0);
  3556.     skipcloseparen();
  3557.     return sp;
  3558. }
  3559.  
  3560.  
  3561.  
  3562. Static Stmt *proc_strread()
  3563. {
  3564.     Expr *vex, *exi, *exj, *exjj, *ex;
  3565.     Stmt *sp, *sp2;
  3566.     Meaning *tvar, *jvar;
  3567.  
  3568.     if (!skipopenparen())
  3569.     return NULL;
  3570.     vex = p_expr(tp_str255);
  3571.     if (vex->kind != EK_VAR) {
  3572.         tvar = makestmttempvar(tp_str255, name_STRING);
  3573.         sp = makestmt_assign(makeexpr_var(tvar), vex);
  3574.         vex = makeexpr_var(tvar);
  3575.     } else
  3576.         sp = NULL;
  3577.     if (!skipcomma())
  3578.     return NULL;
  3579.     exi = p_expr(tp_integer);
  3580.     if (!skipcomma())
  3581.     return NULL;
  3582.     exj = p_expr(tp_integer);
  3583.     if (!skipcomma())
  3584.     return NULL;
  3585.     if (exprspeed(exi) >= 5 || !nosideeffects(exi, 0)) {
  3586.         sp = makestmt_seq(sp, makestmt_assign(copyexpr(exj), exi));
  3587.         exi = copyexpr(exj);
  3588.     }
  3589.     if (fullstrread != 0 &&
  3590.         ((ex = singlevar(exj)) == NULL || exproccurs(exi, ex))) {
  3591.         jvar = makestmttempvar(exj->val.type, name_TEMP);
  3592.         exjj = makeexpr_var(jvar);
  3593.     } else {
  3594.         exjj = copyexpr(exj);
  3595.         jvar = (exj->kind == EK_VAR) ? (Meaning *)exj->val.i : NULL;
  3596.     }
  3597.     sp2 = handleread_text(bumpstring(copyexpr(vex),
  3598.                                      copyexpr(exi), 1),
  3599.                           exjj, 0);
  3600.     sp = makestmt_seq(sp, sp2);
  3601.     skipcloseparen();
  3602.     if (fullstrread == 0) {
  3603.         sp = makestmt_seq(sp, makestmt_assign(exj,
  3604.                                               makeexpr_plus(makeexpr_bicall_1("strlen", tp_int,
  3605.                                                                               vex),
  3606.                                                             makeexpr_long(1))));
  3607.         freeexpr(exjj);
  3608.         freeexpr(exi);
  3609.     } else {
  3610.         sp = makestmt_seq(sp, makestmt_assign(exj,
  3611.                                               makeexpr_plus(exjj, exi)));
  3612.         if (fullstrread == 2)
  3613.             note("STRREAD was used [197]");
  3614.         freeexpr(vex);
  3615.     }
  3616.     return mixassignments(sp, jvar);
  3617. }
  3618.  
  3619.  
  3620.  
  3621.  
  3622. Static Expr *func_random()
  3623. {
  3624.     Expr *ex;
  3625.  
  3626.     if (curtok == TOK_LPAR) {
  3627.         gettok();
  3628.         ex = p_expr(tp_integer);
  3629.         skipcloseparen();
  3630.         return makeexpr_bicall_1(randintname, tp_integer, makeexpr_arglong(ex, 1));
  3631.     } else {
  3632.         return makeexpr_bicall_0(randrealname, tp_longreal);
  3633.     }
  3634. }
  3635.  
  3636.  
  3637.  
  3638. Static Stmt *proc_randomize()
  3639. {
  3640.     if (*randomizename)
  3641.         return makestmt_call(makeexpr_bicall_0(randomizename, tp_void));
  3642.     else
  3643.         return NULL;
  3644. }
  3645.  
  3646.  
  3647.  
  3648. Static Expr *func_round(ex)
  3649. Expr *ex;
  3650. {
  3651.     Meaning *tvar;
  3652.  
  3653.     ex = grabarg(ex, 0);
  3654.     if (ex->val.type->kind != TK_REAL)
  3655.     return ex;
  3656.     if (*roundname) {
  3657.         if (*roundname != '*' || (exprspeed(ex) < 5 && nosideeffects(ex, 0))) {
  3658.             return makeexpr_bicall_1(roundname, tp_integer, ex);
  3659.         } else {
  3660.             tvar = makestmttempvar(tp_longreal, name_TEMP);
  3661.             return makeexpr_comma(makeexpr_assign(makeexpr_var(tvar), ex),
  3662.                                   makeexpr_bicall_1(roundname, tp_integer, makeexpr_var(tvar)));
  3663.         }
  3664.     } else {
  3665.         return makeexpr_actcast(makeexpr_bicall_1("floor", tp_longreal,
  3666.                           makeexpr_plus(ex, makeexpr_real("0.5"))),
  3667.                                 tp_integer);
  3668.     }
  3669. }
  3670.  
  3671.  
  3672.  
  3673. Static Stmt *proc_unpack()
  3674. {
  3675.     Expr *exs, *exd, *exi, *mins;
  3676.     Meaning *tvar;
  3677.     Stmt *sp;
  3678.  
  3679.     if (!skipopenparen())
  3680.     return NULL;
  3681.     exs = p_expr(NULL);
  3682.     if (!skipcomma())
  3683.     return NULL;
  3684.     exd = p_expr(NULL);
  3685.     if (!skipcomma())
  3686.     return NULL;
  3687.     exi = p_ord_expr();
  3688.     skipcloseparen();
  3689.     if (exd->val.type->kind != TK_ARRAY ||
  3690.     (exs->val.type->kind != TK_ARRAY &&
  3691.      exs->val.type->kind != TK_SMALLARRAY)) {
  3692.     warning("Bad argument types for PACK/UNPACK [325]");
  3693.     return makestmt_call(makeexpr_bicall_3("unpack", tp_void,
  3694.                            exs, exd, exi));
  3695.     }
  3696.     if (exs->val.type->smax || exd->val.type->smax) {
  3697.     tvar = makestmttempvar(exs->val.type->indextype, name_TEMP);
  3698.     sp = makestmt(SK_FOR);
  3699.     if (exs->val.type->smin)
  3700.         mins = exs->val.type->smin;
  3701.     else
  3702.         mins = exs->val.type->indextype->smin;
  3703.     sp->exp1 = makeexpr_assign(makeexpr_var(tvar),
  3704.                    copyexpr(mins));
  3705.     sp->exp2 = makeexpr_rel(EK_LE, makeexpr_var(tvar),
  3706.                 copyexpr(exs->val.type->indextype->smax));
  3707.     sp->exp3 = makeexpr_assign(makeexpr_var(tvar),
  3708.                    makeexpr_plus(makeexpr_var(tvar),
  3709.                          makeexpr_long(1)));
  3710.     exi = makeexpr_minus(exi, copyexpr(mins));
  3711.     sp->stm1 = makestmt_assign(p_index(exd,
  3712.                        makeexpr_plus(makeexpr_var(tvar),
  3713.                              exi)),
  3714.                    p_index(exs, makeexpr_var(tvar)));
  3715.     return sp;
  3716.     } else {
  3717.     exi = gentle_cast(exi, exs->val.type->indextype);
  3718.     return makestmt_call(makeexpr_bicall_3("memcpy", exd->val.type,
  3719.                            exd,
  3720.                            makeexpr_addr(p_index(exs, exi)),
  3721.                            makeexpr_sizeof(copyexpr(exd), 0)));
  3722.     }
  3723. }
  3724.  
  3725.  
  3726.  
  3727. Static Expr *func_uround(ex)
  3728. Expr *ex;
  3729. {
  3730.     ex = grabarg(ex, 0);
  3731.     if (ex->val.type->kind != TK_REAL)
  3732.     return ex;
  3733.     return makeexpr_actcast(makeexpr_bicall_1("floor", tp_longreal,
  3734.                           makeexpr_plus(ex, makeexpr_real("0.5"))),
  3735.                 tp_unsigned);
  3736. }
  3737.  
  3738.  
  3739.  
  3740. Static Expr *func_scan()
  3741. {
  3742.     Expr *ex, *ex2, *ex3;
  3743.     char *name;
  3744.  
  3745.     if (!skipopenparen())
  3746.     return NULL;
  3747.     ex = p_expr(tp_integer);
  3748.     if (!skipcomma())
  3749.     return NULL;
  3750.     if (curtok == TOK_EQ)
  3751.     name = "P_scaneq";
  3752.     else 
  3753.     name = "P_scanne";
  3754.     gettok();
  3755.     ex2 = p_expr(tp_char);
  3756.     if (!skipcomma())
  3757.     return NULL;
  3758.     ex3 = p_expr(tp_str255);
  3759.     skipcloseparen();
  3760.     return makeexpr_bicall_3(name, tp_int,
  3761.                  makeexpr_arglong(ex, 0),
  3762.                  makeexpr_charcast(ex2), ex3);
  3763. }
  3764.  
  3765.  
  3766.  
  3767. Static Expr *func_scaneq(ex)
  3768. Expr *ex;
  3769. {
  3770.     return makeexpr_bicall_3("P_scaneq", tp_int,
  3771.                  makeexpr_arglong(ex->args[0], 0),
  3772.                  makeexpr_charcast(ex->args[1]),
  3773.                  ex->args[2]);
  3774. }
  3775.  
  3776.  
  3777. Static Expr *func_scanne(ex)
  3778. Expr *ex;
  3779. {
  3780.     return makeexpr_bicall_3("P_scanne", tp_int,
  3781.                  makeexpr_arglong(ex->args[0], 0),
  3782.                  makeexpr_charcast(ex->args[1]),
  3783.                  ex->args[2]);
  3784. }
  3785.  
  3786.  
  3787.  
  3788. Static Stmt *proc_seek()
  3789. {
  3790.     Expr *fex, *ex;
  3791.     Stmt *sp;
  3792.  
  3793.     if (!skipopenparen())
  3794.     return NULL;
  3795.     fex = p_expr(tp_text);
  3796.     if (!skipcomma())
  3797.     return NULL;
  3798.     ex = p_expr(tp_integer);
  3799.     skipcloseparen();
  3800.     sp = wrapopencheck(doseek(fex, ex), copyexpr(fex));
  3801.     if (*setupbufname && fileisbuffered(fex, 1))
  3802.     sp = makestmt_seq(sp,
  3803.          makestmt_call(
  3804.              makeexpr_bicall_2(setupbufname, tp_void,
  3805.                        filebasename(fex),
  3806.                        makeexpr_type(filebasetype(fex->val.type)))));
  3807.     else
  3808.     freeexpr(fex);
  3809.     return sp;
  3810. }
  3811.  
  3812.  
  3813.  
  3814. Static Expr *func_seekeof()
  3815. {
  3816.     Expr *ex;
  3817.  
  3818.     if (curtok == TOK_LPAR)
  3819.         ex = p_parexpr(tp_text);
  3820.     else
  3821.         ex = makeexpr_var(mp_input);
  3822.     if (*skipspacename)
  3823.         ex = makeexpr_bicall_1(skipspacename, tp_text, filebasename(ex));
  3824.     else
  3825.         note("SEEKEOF was used [198]");
  3826.     return iofunc(ex, 0);
  3827. }
  3828.  
  3829.  
  3830.  
  3831. Static Expr *func_seekeoln()
  3832. {
  3833.     Expr *ex;
  3834.  
  3835.     if (curtok == TOK_LPAR)
  3836.         ex = p_parexpr(tp_text);
  3837.     else
  3838.         ex = makeexpr_var(mp_input);
  3839.     if (*skipspacename)
  3840.         ex = makeexpr_bicall_1(skipspacename, tp_text, filebasename(ex));
  3841.     else
  3842.         note("SEEKEOLN was used [199]");
  3843.     return iofunc(ex, 1);
  3844. }
  3845.  
  3846.  
  3847.  
  3848. Static Stmt *proc_setstrlen()
  3849. {
  3850.     Expr *ex, *ex2;
  3851.  
  3852.     if (!skipopenparen())
  3853.     return NULL;
  3854.     ex = p_expr(tp_str255);
  3855.     if (!skipcomma())
  3856.     return NULL;
  3857.     ex2 = p_expr(tp_integer);
  3858.     skipcloseparen();
  3859.     return makestmt_assign(makeexpr_bicall_1("strlen", tp_int, ex),
  3860.                            ex2);
  3861. }
  3862.  
  3863.  
  3864.  
  3865. Static Stmt *proc_settextbuf()
  3866. {
  3867.     Expr *fex, *bex, *sex;
  3868.  
  3869.     if (!skipopenparen())
  3870.     return NULL;
  3871.     fex = p_expr(tp_text);
  3872.     if (!skipcomma())
  3873.     return NULL;
  3874.     bex = p_expr(NULL);
  3875.     if (curtok == TOK_COMMA) {
  3876.         gettok();
  3877.         sex = p_expr(tp_integer);
  3878.     } else
  3879.         sex = makeexpr_sizeof(copyexpr(bex), 0);
  3880.     skipcloseparen();
  3881.     note("Make sure setvbuf() call occurs when file is open [200]");
  3882.     return makestmt_call(makeexpr_bicall_4("setvbuf", tp_void,
  3883.                                            filebasename(fex),
  3884.                                            makeexpr_addr(bex),
  3885.                                            makeexpr_name("_IOFBF", tp_integer),
  3886.                                            sex));
  3887. }
  3888.  
  3889.  
  3890.  
  3891. Static Expr *func_sin(ex)
  3892. Expr *ex;
  3893. {
  3894.     return makeexpr_bicall_1("sin", tp_longreal, grabarg(ex, 0));
  3895. }
  3896.  
  3897.  
  3898. Static Expr *func_sinh(ex)
  3899. Expr *ex;
  3900. {
  3901.     return makeexpr_bicall_1("sinh", tp_longreal, grabarg(ex, 0));
  3902. }
  3903.  
  3904.  
  3905.  
  3906. Static Expr *func_sizeof()
  3907. {
  3908.     Expr *ex;
  3909.     Type *type;
  3910.     char *name, vbuf[1000];
  3911.     int lpar;
  3912.  
  3913.     lpar = (curtok == TOK_LPAR);
  3914.     if (lpar)
  3915.     gettok();
  3916.     if (curtok == TOK_IDENT && curtokmeaning && curtokmeaning->kind == MK_TYPE) {
  3917.         ex = makeexpr_type(curtokmeaning->type);
  3918.         gettok();
  3919.     } else
  3920.         ex = p_expr(NULL);
  3921.     type = ex->val.type;
  3922.     parse_special_variant(type, vbuf);
  3923.     if (lpar)
  3924.     skipcloseparen();
  3925.     name = find_special_variant(vbuf, "SpecialSizeOf", specialsizeofs, 1);
  3926.     if (name) {
  3927.     freeexpr(ex);
  3928.     return pc_expr_str(name);
  3929.     } else
  3930.     return makeexpr_sizeof(ex, 0);
  3931. }
  3932.  
  3933.  
  3934.  
  3935. Static Expr *func_statusv()
  3936. {
  3937.     return makeexpr_name(name_IORESULT, tp_integer);
  3938. }
  3939.  
  3940.  
  3941.  
  3942. Static Expr *func_str_hp(ex)
  3943. Expr *ex;
  3944. {
  3945.     return makeexpr_addr(makeexpr_substring(ex->args[0], ex->args[1], 
  3946.                                             ex->args[2], ex->args[3]));
  3947. }
  3948.  
  3949.  
  3950.  
  3951. Static Stmt *proc_strappend()
  3952. {
  3953.     Expr *ex, *ex2;
  3954.  
  3955.     if (!skipopenparen())
  3956.     return NULL;
  3957.     ex = p_expr(tp_str255);
  3958.     if (!skipcomma())
  3959.     return NULL;
  3960.     ex2 = p_expr(tp_str255);
  3961.     skipcloseparen();
  3962.     return makestmt_assign(ex, makeexpr_concat(copyexpr(ex), ex2, 0));
  3963. }
  3964.  
  3965.  
  3966.  
  3967. Static Stmt *proc_strdelete()
  3968. {
  3969.     Meaning *tvar = NULL, *tvari;
  3970.     Expr *ex, *ex2, *ex3, *ex4, *exi, *exn;
  3971.     Stmt *sp;
  3972.  
  3973.     if (!skipopenparen())
  3974.     return NULL;
  3975.     ex = p_expr(tp_str255);
  3976.     if (!skipcomma())
  3977.     return NULL;
  3978.     exi = p_expr(tp_integer);
  3979.     if (curtok == TOK_COMMA) {
  3980.     gettok();
  3981.     exn = p_expr(tp_integer);
  3982.     } else
  3983.     exn = makeexpr_long(1);
  3984.     skipcloseparen();
  3985.     if (exprspeed(exi) < 5 && nosideeffects(exi, 0))
  3986.         sp = NULL;
  3987.     else {
  3988.         tvari = makestmttempvar(tp_int, name_TEMP);
  3989.         sp = makestmt_assign(makeexpr_var(tvari), exi);
  3990.         exi = makeexpr_var(tvari);
  3991.     }
  3992.     ex3 = bumpstring(copyexpr(ex), copyexpr(exi), 1);
  3993.     ex4 = bumpstring(copyexpr(ex), makeexpr_plus(exi, exn), 1);
  3994.     if (strcpyleft) {
  3995.         ex2 = ex3;
  3996.     } else {
  3997.         tvar = makestmttempvar(tp_str255, name_STRING);
  3998.         ex2 = makeexpr_var(tvar);
  3999.     }
  4000.     sp = makestmt_seq(sp, makestmt_assign(ex2, ex4));
  4001.     if (!strcpyleft)
  4002.         sp = makestmt_seq(sp, makestmt_assign(ex3, makeexpr_var(tvar)));
  4003.     return sp;
  4004. }
  4005.  
  4006.  
  4007.  
  4008. Static Stmt *proc_strinsert()
  4009. {
  4010.     Meaning *tvari;
  4011.     Expr *exs, *exd, *exi;
  4012.     Stmt *sp;
  4013.  
  4014.     if (!skipopenparen())
  4015.     return NULL;
  4016.     exs = p_expr(tp_str255);
  4017.     if (!skipcomma())
  4018.     return NULL;
  4019.     exd = p_expr(tp_str255);
  4020.     if (!skipcomma())
  4021.     return NULL;
  4022.     exi = p_expr(tp_integer);
  4023.     skipcloseparen();
  4024. #if 0
  4025.     if (checkconst(exi, 1)) {
  4026.         freeexpr(exi);
  4027.         return makestmt_assign(exd,
  4028.                                makeexpr_concat(exs, copyexpr(exd)));
  4029.     }
  4030. #endif
  4031.     if (exprspeed(exi) < 5 && nosideeffects(exi, 0))
  4032.         sp = NULL;
  4033.     else {
  4034.         tvari = makestmttempvar(tp_int, name_TEMP);
  4035.         sp = makestmt_assign(makeexpr_var(tvari), exi);
  4036.         exi = makeexpr_var(tvari);
  4037.     }
  4038.     exd = bumpstring(exd, exi, 1);
  4039.     sp = makestmt_seq(sp, makestmt_assign(exd,
  4040.                                           makeexpr_concat(exs, copyexpr(exd), 0)));
  4041.     return sp;
  4042. }
  4043.  
  4044.  
  4045.  
  4046. Static Stmt *proc_strmove()
  4047. {
  4048.     Expr *exlen, *exs, *exsi, *exd, *exdi;
  4049.  
  4050.     if (!skipopenparen())
  4051.     return NULL;
  4052.     exlen = p_expr(tp_integer);
  4053.     if (!skipcomma())
  4054.     return NULL;
  4055.     exs = p_expr(tp_str255);
  4056.     if (!skipcomma())
  4057.     return NULL;
  4058.     exsi = p_expr(tp_integer);
  4059.     if (!skipcomma())
  4060.     return NULL;
  4061.     exd = p_expr(tp_str255);
  4062.     if (!skipcomma())
  4063.     return NULL;
  4064.     exdi = p_expr(tp_integer);
  4065.     skipcloseparen();
  4066.     exsi = makeexpr_arglong(exsi, 0);
  4067.     exdi = makeexpr_arglong(exdi, 0);
  4068.     return makestmt_call(makeexpr_bicall_5(strmovename, tp_str255,
  4069.                        exlen, exs, exsi, exd, exdi));
  4070. }
  4071.  
  4072.  
  4073.  
  4074. Static Expr *func_strlen(ex)
  4075. Expr *ex;
  4076. {
  4077.     return makeexpr_bicall_1("strlen", tp_int, grabarg(ex, 0));
  4078. }
  4079.  
  4080.  
  4081.  
  4082. Static Expr *func_strltrim(ex)
  4083. Expr *ex;
  4084. {
  4085.     return makeexpr_assign(makeexpr_hat(ex->args[0], 0),
  4086.                            makeexpr_bicall_1(strltrimname, tp_str255, ex->args[1]));
  4087. }
  4088.  
  4089.  
  4090.  
  4091. Static Expr *func_strmax(ex)
  4092. Expr *ex;
  4093. {
  4094.     return strmax_func(grabarg(ex, 0));
  4095. }
  4096.  
  4097.  
  4098.  
  4099. Static Expr *func_strpos(ex)
  4100. Expr *ex;
  4101. {
  4102.     char *cp;
  4103.  
  4104.     if (!switch_strpos)
  4105.         swapexprs(ex->args[0], ex->args[1]);
  4106.     cp = strposname;
  4107.     if (!*cp) {
  4108.         note("STRPOS function used [201]");
  4109.         cp = "STRPOS";
  4110.     } 
  4111.     return makeexpr_bicall_3(cp, tp_int,
  4112.                              ex->args[0], 
  4113.                              ex->args[1],
  4114.                              makeexpr_long(1));
  4115. }
  4116.  
  4117.  
  4118.  
  4119. Static Expr *func_strrpt(ex)
  4120. Expr *ex;
  4121. {
  4122.     if (ex->args[1]->kind == EK_CONST &&
  4123.         ex->args[1]->val.i == 1 && ex->args[1]->val.s[0] == ' ') {
  4124.         return makeexpr_bicall_4("sprintf", tp_strptr, ex->args[0],
  4125.                                  makeexpr_string("%*s"),
  4126.                                  makeexpr_longcast(ex->args[2], 0),
  4127.                                  makeexpr_string(""));
  4128.     } else
  4129.         return makeexpr_bicall_3(strrptname, tp_strptr, ex->args[0], ex->args[1],
  4130.                                  makeexpr_arglong(ex->args[2], 0));
  4131. }
  4132.  
  4133.  
  4134.  
  4135. Static Expr *func_strrtrim(ex)
  4136. Expr *ex;
  4137. {
  4138.     return makeexpr_bicall_1(strrtrimname, tp_strptr,
  4139.                              makeexpr_assign(makeexpr_hat(ex->args[0], 0),
  4140.                                              ex->args[1]));
  4141. }
  4142.  
  4143.  
  4144.  
  4145. Static Expr *func_succ()
  4146. {
  4147.     Expr *ex;
  4148.  
  4149.     if (wneedtok(TOK_LPAR)) {
  4150.     ex = p_ord_expr();
  4151.     skipcloseparen();
  4152.     } else
  4153.     ex = p_ord_expr();
  4154. #if 1
  4155.     ex = makeexpr_inc(ex, makeexpr_long(1));
  4156. #else
  4157.     ex = makeexpr_cast(makeexpr_plus(ex, makeexpr_long(1)), ex->val.type);
  4158. #endif
  4159.     return ex;
  4160. }
  4161.  
  4162.  
  4163.  
  4164. Static Expr *func_sqr()
  4165. {
  4166.     return makeexpr_sqr(p_parexpr(tp_integer), 0);
  4167. }
  4168.  
  4169.  
  4170.  
  4171. Static Expr *func_sqrt(ex)
  4172. Expr *ex;
  4173. {
  4174.     return makeexpr_bicall_1("sqrt", tp_longreal, grabarg(ex, 0));
  4175. }
  4176.  
  4177.  
  4178.  
  4179. Static Expr *func_swap(ex)
  4180. Expr *ex;
  4181. {
  4182.     char *cp;
  4183.  
  4184.     ex = grabarg(ex, 0);
  4185.     cp = swapname;
  4186.     if (!*cp) {
  4187.         note("SWAP function was used [202]");
  4188.         cp = "SWAP";
  4189.     }
  4190.     return makeexpr_bicall_1(swapname, tp_int, ex);
  4191. }
  4192.  
  4193.  
  4194.  
  4195. Static Expr *func_tan(ex)
  4196. Expr *ex;
  4197. {
  4198.     return makeexpr_bicall_1("tan", tp_longreal, grabarg(ex, 0));
  4199. }
  4200.  
  4201.  
  4202. Static Expr *func_tanh(ex)
  4203. Expr *ex;
  4204. {
  4205.     return makeexpr_bicall_1("tanh", tp_longreal, grabarg(ex, 0));
  4206. }
  4207.  
  4208.  
  4209.  
  4210. Static Expr *func_trunc(ex)
  4211. Expr *ex;
  4212. {
  4213.     return makeexpr_actcast(grabarg(ex, 0), tp_integer);
  4214. }
  4215.  
  4216.  
  4217.  
  4218. Static Expr *func_utrunc(ex)
  4219. Expr *ex;
  4220. {
  4221.     return makeexpr_actcast(grabarg(ex, 0), tp_unsigned);
  4222. }
  4223.  
  4224.  
  4225.  
  4226. Static Expr *func_uand()
  4227. {
  4228.     Expr *ex;
  4229.  
  4230.     if (!skipopenparen())
  4231.     return NULL;
  4232.     ex = p_expr(tp_unsigned);
  4233.     if (skipcomma()) {
  4234.     ex = makeexpr_bin(EK_BAND, ex->val.type, ex, p_expr(tp_unsigned));
  4235.     skipcloseparen();
  4236.     }
  4237.     return ex;
  4238. }
  4239.  
  4240.  
  4241.  
  4242. Static Expr *func_udec()
  4243. {
  4244.     return handle_vax_hex(NULL, "u", 0);
  4245. }
  4246.  
  4247.  
  4248.  
  4249. Static Expr *func_unot()
  4250. {
  4251.     Expr *ex;
  4252.  
  4253.     if (!skipopenparen())
  4254.     return NULL;
  4255.     ex = p_expr(tp_unsigned);
  4256.     ex = makeexpr_un(EK_BNOT, ex->val.type, ex);
  4257.     skipcloseparen();
  4258.     return ex;
  4259. }
  4260.  
  4261.  
  4262.  
  4263. Static Expr *func_uor()
  4264. {
  4265.     Expr *ex;
  4266.  
  4267.     if (!skipopenparen())
  4268.     return NULL;
  4269.     ex = p_expr(tp_unsigned);
  4270.     if (skipcomma()) {
  4271.     ex = makeexpr_bin(EK_BOR, ex->val.type, ex, p_expr(tp_unsigned));
  4272.     skipcloseparen();
  4273.     }
  4274.     return ex;
  4275. }
  4276.  
  4277.  
  4278.  
  4279. Static Expr *func_upcase(ex)
  4280. Expr *ex;
  4281. {
  4282.     return makeexpr_bicall_1("toupper", tp_char, grabarg(ex, 0));
  4283. }
  4284.  
  4285.  
  4286.  
  4287. Static Expr *func_upper()
  4288. {
  4289.     Expr *ex;
  4290.     Value val;
  4291.  
  4292.     if (!skipopenparen())
  4293.     return NULL;
  4294.     ex = p_expr(tp_integer);
  4295.     if (curtok == TOK_COMMA) {
  4296.     gettok();
  4297.     val = p_constant(tp_integer);
  4298.     if (!val.type || val.i != 1)
  4299.         note("UPPER(v,n) not supported for n>1 [190]");
  4300.     }
  4301.     skipcloseparen();
  4302.     return copyexpr(ex->val.type->indextype->smax);
  4303. }
  4304.  
  4305.  
  4306.  
  4307. Static Expr *func_uxor()
  4308. {
  4309.     Expr *ex;
  4310.  
  4311.     if (!skipopenparen())
  4312.     return NULL;
  4313.     ex = p_expr(tp_unsigned);
  4314.     if (skipcomma()) {
  4315.     ex = makeexpr_bin(EK_BXOR, ex->val.type, ex, p_expr(tp_unsigned));
  4316.     skipcloseparen();
  4317.     }
  4318.     return ex;
  4319. }
  4320.  
  4321.  
  4322.  
  4323. Static Expr *func_val_modula()
  4324. {
  4325.     Expr *ex;
  4326.     Type *tp;
  4327.  
  4328.     if (!skipopenparen())
  4329.     return NULL;
  4330.     tp = p_type(NULL);
  4331.     if (!skipcomma())
  4332.     return NULL;
  4333.     ex = p_expr(tp);
  4334.     skipcloseparen();
  4335.     return pascaltypecast(tp, ex);
  4336. }
  4337.  
  4338.  
  4339.  
  4340. Static Stmt *proc_val_turbo()
  4341. {
  4342.     Expr *ex, *vex, *code, *fmt;
  4343.  
  4344.     if (!skipopenparen())
  4345.     return NULL;
  4346.     ex = gentle_cast(p_expr(tp_str255), tp_str255);
  4347.     if (!skipcomma())
  4348.     return NULL;
  4349.     vex = p_expr(NULL);
  4350.     if (curtok == TOK_COMMA) {
  4351.     gettok();
  4352.     code = gentle_cast(p_expr(tp_integer), tp_integer);
  4353.     } else
  4354.     code = NULL;
  4355.     skipcloseparen();
  4356.     if (vex->val.type->kind == TK_REAL)
  4357.         fmt = makeexpr_string("%lg");
  4358.     else if (exprlongness(vex) > 0)
  4359.         fmt = makeexpr_string("%ld");
  4360.     else
  4361.         fmt = makeexpr_string("%d");
  4362.     ex = makeexpr_bicall_3("sscanf", tp_int,
  4363.                            ex, fmt, makeexpr_addr(vex));
  4364.     if (code) {
  4365.     ex = makeexpr_rel(EK_EQ, ex, makeexpr_long(0));
  4366.     return makestmt_assign(code, makeexpr_ord(ex));
  4367.     } else
  4368.     return makestmt_call(ex);
  4369. }
  4370.  
  4371.  
  4372.  
  4373.  
  4374.  
  4375.  
  4376.  
  4377. Static Expr *writestrelement(ex, wid, vex, code, needboth)
  4378. Expr *ex, *wid, *vex;
  4379. int code, needboth;
  4380. {
  4381.     if (formatstrings && needboth) {
  4382.         return makeexpr_bicall_5("sprintf", tp_str255, vex,
  4383.                                  makeexpr_string(format_d("%%*.*%c", code)),
  4384.                                  copyexpr(wid),
  4385.                                  wid,
  4386.                                  ex);
  4387.     } else {
  4388.         return makeexpr_bicall_4("sprintf", tp_str255, vex,
  4389.                                  makeexpr_string(format_d("%%*%c", code)),
  4390.                                  wid,
  4391.                                  ex);
  4392.     }
  4393. }
  4394.  
  4395.  
  4396.  
  4397. Static char *makeenumnames(tp)
  4398. Type *tp;
  4399. {
  4400.     Strlist *sp;
  4401.     char *name;
  4402.     Meaning *mp;
  4403.     int saveindent;
  4404.  
  4405.     for (sp = enumnames; sp && sp->value != (long)tp; sp = sp->next) ;
  4406.     if (!sp) {
  4407.         if (tp->meaning)
  4408.             name = format_s(name_ENUM, tp->meaning->name);
  4409.         else
  4410.             name = format_s(name_ENUM, format_d("_%d", ++enumnamecount));
  4411.         sp = strlist_insert(&enumnames, name);
  4412.         sp->value = (long)tp;
  4413.         outsection(2);
  4414.         output(format_s("static %s *", charname));
  4415.         output(sp->s);
  4416.         output("[] = {\n");
  4417.     saveindent = outindent;
  4418.     moreindent(tabsize);
  4419.     moreindent(structinitindent);
  4420.         for (mp = tp->fbase; mp; mp = mp->xnext) {
  4421.             output(makeCstring(mp->sym->name, strlen(mp->sym->name)));
  4422.             if (mp->xnext)
  4423.                 output(",\002 ");
  4424.         }
  4425.         outindent = saveindent;
  4426.         output("\n} ;\n");
  4427.         outsection(2);
  4428.     }
  4429.     return sp->s;
  4430. }
  4431.  
  4432.  
  4433.  
  4434.  
  4435.  
  4436. /* This function must return a "tempsprintf" */
  4437.  
  4438. Expr *writeelement(ex, wid, prec, base)
  4439. Expr *ex, *wid, *prec;
  4440. int base;
  4441. {
  4442.     Expr *vex, *ex1, *ex2;
  4443.     Meaning *tvar;
  4444.     char *fmtcode;
  4445.     Type *type;
  4446.  
  4447.     ex = makeexpr_charcast(ex);
  4448.     if (ex->val.type->kind == TK_POINTER) {
  4449.         ex = makeexpr_hat(ex, 0);   /* convert char *'s to strings */
  4450.         intwarning("writeelement", "got a char * instead of a string [214]");
  4451.     }
  4452.     if ((ex->val.type->kind == TK_STRING && !wid) ||
  4453.         (ord_type(ex->val.type)->kind == TK_CHAR && (!wid || checkconst(wid, 1)))) {
  4454.         return makeexpr_sprintfify(ex);
  4455.     }
  4456.     tvar = makestmttempvar(tp_str255, name_STRING);
  4457.     vex = makeexpr_var(tvar);
  4458.     if (wid)
  4459.         wid = makeexpr_longcast(wid, 0);
  4460.     if (prec)
  4461.         prec = makeexpr_longcast(prec, 0);
  4462. #if 0
  4463.     if (wid && (wid->kind == EK_CONST && wid->val.i < 0 ||
  4464.                 checkconst(wid, -1))) {
  4465.         freeexpr(wid);     /* P-system uses write(x:-1) to mean write(x) */
  4466.         wid = NULL;
  4467.     }
  4468.     if (prec && (prec->kind == EK_CONST && prec->val.i < 0 ||
  4469.                  checkconst(prec, -1))) {
  4470.         freeexpr(prec);
  4471.         prec = NULL;
  4472.     }
  4473. #endif
  4474.     switch (ord_type(ex->val.type)->kind) {
  4475.  
  4476.         case TK_INTEGER:
  4477.             if (!wid) {
  4478.         if (integerwidth < 0)
  4479.             integerwidth = (which_lang == LANG_TURBO) ? 1 : 12;
  4480.         wid = makeexpr_long(integerwidth);
  4481.         }
  4482.         type = findbasetype(ex->val.type, ODECL_NOPRES);
  4483.         if (base == 16)
  4484.         fmtcode = "x";
  4485.         else if (base == 8)
  4486.         fmtcode = "o";
  4487.         else if ((possiblesigns(wid) & (1|4)) == 1) {
  4488.         wid = makeexpr_neg(wid);
  4489.         fmtcode = "x";
  4490.         } else if (type == tp_unsigned ||
  4491.                type == tp_uint ||
  4492.                (type == tp_ushort && sizeof_int < 32))
  4493.         fmtcode = "u";
  4494.         else
  4495.         fmtcode = "d";
  4496.             ex = makeexpr_forcelongness(ex);
  4497.             if (checkconst(wid, 0) || checkconst(wid, 1)) {
  4498.                 ex = makeexpr_bicall_3("sprintf", tp_str255, vex,
  4499.                                        makeexpr_string(format_ss("%%%s%s",
  4500.                                  (exprlongness(ex) > 0) ? "l" : "",
  4501.                                  fmtcode)),
  4502.                                        ex);
  4503.             } else {
  4504.                 ex = makeexpr_bicall_4("sprintf", tp_str255, vex,
  4505.                                        makeexpr_string(format_ss("%%*%s%s",
  4506.                                  (exprlongness(ex) > 0) ? "l" : "",
  4507.                                  fmtcode)),
  4508.                                        wid,
  4509.                                        ex);
  4510.             }
  4511.             break;
  4512.  
  4513.         case TK_CHAR:
  4514.             ex = writestrelement(ex, wid, vex, 'c',
  4515.                                      (wid->kind != EK_CONST || wid->val.i < 1));
  4516.             break;
  4517.  
  4518.         case TK_BOOLEAN:
  4519.             if (!wid) {
  4520.                 ex = makeexpr_bicall_3("sprintf", tp_str255, vex,
  4521.                                        makeexpr_string("%s"),
  4522.                                        makeexpr_cond(ex,
  4523.                                                      makeexpr_string(" TRUE"),
  4524.                                                      makeexpr_string("FALSE")));
  4525.             } else if (checkconst(wid, 1)) {
  4526.                 ex = makeexpr_bicall_3("sprintf", tp_str255, vex,
  4527.                                        makeexpr_string("%c"),
  4528.                                        makeexpr_cond(ex,
  4529.                                                      makeexpr_char('T'),
  4530.                                                      makeexpr_char('F')));
  4531.             } else {
  4532.                 ex = writestrelement(makeexpr_cond(ex,
  4533.                                                    makeexpr_string("TRUE"),
  4534.                                                    makeexpr_string("FALSE")),
  4535.                                      wid, vex, 's',
  4536.                                      (wid->kind != EK_CONST || wid->val.i < 5));
  4537.             }
  4538.             break;
  4539.  
  4540.         case TK_ENUM:
  4541.             ex = makeexpr_bicall_3("sprintf", tp_str255, vex,
  4542.                                    makeexpr_string("%s"),
  4543.                                    makeexpr_index(makeexpr_name(makeenumnames(ex->val.type),
  4544.                                                                 tp_strptr),
  4545.                                                   ex, NULL));
  4546.             break;
  4547.  
  4548.         case TK_REAL:
  4549.             if (!wid)
  4550.                 wid = makeexpr_long(realwidth);
  4551.             if (prec && (possiblesigns(prec) & (1|4)) != 1) {
  4552.                 ex = makeexpr_bicall_5("sprintf", tp_str255, vex,
  4553.                                        makeexpr_string("%*.*f"),
  4554.                                        wid,
  4555.                                        prec,
  4556.                                        ex);
  4557.             } else {
  4558.         if (prec)
  4559.             prec = makeexpr_neg(prec);
  4560.         else
  4561.             prec = makeexpr_minus(copyexpr(wid),
  4562.                       makeexpr_long(7));
  4563.         if (prec->kind == EK_CONST) {
  4564.             if (prec->val.i <= 0)
  4565.             prec = makeexpr_long(1);
  4566.         } else {
  4567.             prec = makeexpr_bicall_2("P_max", tp_integer, prec,
  4568.                          makeexpr_long(1));
  4569.         }
  4570.                 if (wid->kind == EK_CONST && wid->val.i > 21) {
  4571.                     ex = makeexpr_bicall_5("sprintf", tp_str255, vex,
  4572.                                            makeexpr_string("%*.*E"),
  4573.                                            wid,
  4574.                        prec,
  4575.                                            ex);
  4576. #if 0
  4577.                 } else if (checkconst(wid, 7)) {
  4578.                     ex = makeexpr_bicall_3("sprintf", tp_str255, vex,
  4579.                                            makeexpr_string("%E"),
  4580.                                            ex);
  4581. #endif
  4582.                 } else {
  4583.                     ex = makeexpr_bicall_4("sprintf", tp_str255, vex,
  4584.                                            makeexpr_string("% .*E"),
  4585.                        prec,
  4586.                                            ex);
  4587.                 }
  4588.             }
  4589.             break;
  4590.  
  4591.         case TK_STRING:
  4592.             ex = writestrelement(ex, wid, vex, 's', 1);
  4593.             break;
  4594.  
  4595.         case TK_ARRAY:     /* assume packed array of char */
  4596.         ord_range_expr(ex->val.type->indextype, &ex1, &ex2);
  4597.         ex1 = makeexpr_plus(makeexpr_minus(copyexpr(ex2),
  4598.                            copyexpr(ex1)),
  4599.                 makeexpr_long(1));
  4600.         ex1 = makeexpr_longcast(ex1, 0);
  4601.         fmtcode = "%.*s";
  4602.             if (!wid) {
  4603.         wid = ex1;
  4604.             } else {
  4605.         if (isliteralconst(wid, NULL) == 2 &&
  4606.             isliteralconst(ex1, NULL) == 2) {
  4607.             if (wid->val.i > ex1->val.i) {
  4608.             fmtcode = format_ds("%*s%%.*s",
  4609.                         wid->val.i - ex1->val.i, "");
  4610.             wid = ex1;
  4611.             }
  4612.         } else
  4613.             note("Format for packed-array-of-char will work only if width < length [321]");
  4614.         }
  4615.             ex = makeexpr_bicall_4("sprintf", tp_str255, vex,
  4616.                                    makeexpr_string(fmtcode),
  4617.                                    wid,
  4618.                                    makeexpr_addr(ex));
  4619.             break;
  4620.  
  4621.         default:
  4622.             note("Element has wrong type for WRITE statement [196]");
  4623.             ex = makeexpr_bicall_2("sprintf", tp_str255, vex, makeexpr_string("<meef>"));
  4624.             break;
  4625.  
  4626.     }
  4627.     return ex;
  4628. }
  4629.  
  4630.  
  4631.  
  4632. Static Stmt *handlewrite_text(fex, ex, iswriteln)
  4633. Expr *fex, *ex;
  4634. int iswriteln;
  4635. {
  4636.     Expr *print, *wid, *prec;
  4637.     unsigned char *ucp;
  4638.     int i, done, base;
  4639.  
  4640.     print = NULL;
  4641.     for (;;) {
  4642.         wid = NULL;
  4643.         prec = NULL;
  4644.     base = 10;
  4645.     if (curtok == TOK_COLON && iswriteln >= 0) {
  4646.         gettok();
  4647.         wid = p_expr(tp_integer);
  4648.         if (curtok == TOK_COLON) {
  4649.         gettok();
  4650.         prec = p_expr(tp_integer);
  4651.         }
  4652.     }
  4653.     if (curtok == TOK_IDENT &&
  4654.         !strcicmp(curtokbuf, "OCT")) {
  4655.         base = 8;
  4656.         gettok();
  4657.     } else if (curtok == TOK_IDENT &&
  4658.            !strcicmp(curtokbuf, "HEX")) {
  4659.         base = 16;
  4660.         gettok();
  4661.     }
  4662.         ex = writeelement(ex, wid, prec, base);
  4663.         print = makeexpr_concat(print, cleansprintf(ex), 1);
  4664.         if (curtok == TOK_COMMA && iswriteln >= 0) {
  4665.             gettok();
  4666.             ex = p_expr(NULL);
  4667.         } else
  4668.             break;
  4669.     }
  4670.     if (fex->val.type->kind != TK_STRING) {      /* not strwrite */
  4671.         switch (iswriteln) {
  4672.             case 1:
  4673.             case -1:
  4674.                 print = makeexpr_concat(print, makeexpr_string("\n"), 1);
  4675.                 break;
  4676.             case 2:
  4677.             case -2:
  4678.                 print = makeexpr_concat(print, makeexpr_string("\r"), 1);
  4679.                 break;
  4680.         }
  4681.         if (isvar(fex, mp_output)) {
  4682.             ucp = (unsigned char *)print->args[1]->val.s;
  4683.             for (i = 0; i < print->args[1]->val.i; i++) {
  4684.                 if (ucp[i] >= 128 && ucp[i] < 144) {
  4685.                     note("WRITE statement contains color/attribute characters [203]");
  4686.             break;
  4687.         }
  4688.             }
  4689.         }
  4690.         if ((i = sprintflength(print, 0)) > 0 && print->nargs == 2 && printfonly != 1) {
  4691.             print = makeexpr_unsprintfify(print);
  4692.             done = 1;
  4693.             if (isvar(fex, mp_output)) {
  4694.                 if (i == 1) {
  4695.                     print = makeexpr_bicall_1("putchar", tp_int,
  4696.                                               makeexpr_charcast(print));
  4697.                 } else {
  4698.                     if (printfonly == 0) {
  4699.                         if (print->val.s[print->val.i-1] == '\n') {
  4700.                 print->val.s[--(print->val.i)] = 0;
  4701.                             print = makeexpr_bicall_1("puts", tp_int, print);
  4702.                         } else {
  4703.                             print = makeexpr_bicall_2("fputs", tp_int,
  4704.                                                       print,
  4705.                                                       copyexpr(fex));
  4706.                         }
  4707.                     } else {
  4708.                         print = makeexpr_sprintfify(print);
  4709.                         done = 0;
  4710.                     }
  4711.                 }
  4712.             } else {
  4713.                 if (i == 1) {
  4714.                     print = makeexpr_bicall_2("putc", tp_int,
  4715.                                               makeexpr_charcast(print),
  4716.                                               filebasename(copyexpr(fex)));
  4717.                 } else if (printfonly == 0) {
  4718.                     print = makeexpr_bicall_2("fputs", tp_int,
  4719.                                               print,
  4720.                                               filebasename(copyexpr(fex)));
  4721.                 } else {
  4722.                     print = makeexpr_sprintfify(print);
  4723.                     done = 0;
  4724.                 }
  4725.             }
  4726.         } else
  4727.             done = 0;
  4728.         if (!done) {
  4729.             canceltempvar(istempvar(print->args[0]));
  4730.             if (checkstring(print->args[1], "%s") && printfonly != 1) {
  4731.                 print = makeexpr_bicall_2("fputs", tp_int,
  4732.                                           grabarg(print, 2),
  4733.                                           filebasename(copyexpr(fex)));
  4734.             } else if (checkstring(print->args[1], "%c") && printfonly != 1 &&
  4735.                        !nosideeffects(print->args[2], 0)) {
  4736.                 print = makeexpr_bicall_2("fputc", tp_int,
  4737.                                           grabarg(print, 2),
  4738.                                           filebasename(copyexpr(fex)));
  4739.             } else if (isvar(fex, mp_output)) {
  4740.                 if (checkstring(print->args[1], "%s\n") && printfonly != 1) {
  4741.                     print = makeexpr_bicall_1("puts", tp_int, grabarg(print, 2));
  4742.                 } else if (checkstring(print->args[1], "%c") && printfonly != 1) {
  4743.                     print = makeexpr_bicall_1("putchar", tp_int, grabarg(print, 2));
  4744.                 } else {
  4745.                     strchange(&print->val.s, "printf");
  4746.                     delfreearg(&print, 0);
  4747.                     print->val.type = tp_int;
  4748.                 }
  4749.             } else {
  4750.                 if (checkstring(print->args[1], "%c") && printfonly != 1) {
  4751.                     print = makeexpr_bicall_2("putc", tp_int,
  4752.                                               grabarg(print, 2),
  4753.                                               filebasename(copyexpr(fex)));
  4754.                 } else {
  4755.                     strchange(&print->val.s, "fprintf");
  4756.                     freeexpr(print->args[0]);
  4757.                     print->args[0] = filebasename(copyexpr(fex));
  4758.                     print->val.type = tp_int;
  4759.                 }
  4760.             }
  4761.         }
  4762.         if (FCheck(checkfilewrite)) {
  4763.             print = makeexpr_bicall_2("~SETIO", tp_void,
  4764.                                       makeexpr_rel(EK_GE, print, makeexpr_long(0)),
  4765.                       makeexpr_name(filewriteerrorname, tp_int));
  4766.         }
  4767.     }
  4768.     return makestmt_call(print);
  4769. }
  4770.  
  4771.  
  4772.  
  4773. Static Stmt *handlewrite_bin(fex, ex)
  4774. Expr *fex, *ex;
  4775. {
  4776.     Type *basetype;
  4777.     Stmt *sp;
  4778.     Expr *tvardef = NULL;
  4779.     Meaning *tvar = NULL;
  4780.  
  4781.     sp = NULL;
  4782.     basetype = filebasetype(fex->val.type);
  4783.     for (;;) {
  4784.         if (!expr_has_address(ex) || ex->val.type != basetype) {
  4785.             if (!tvar)
  4786.                 tvar = makestmttempvar(basetype, name_TEMP);
  4787.             if (!tvardef || !exprsame(tvardef, ex, 1)) {
  4788.                 freeexpr(tvardef);
  4789.                 tvardef = copyexpr(ex);
  4790.                 sp = makestmt_seq(sp, makestmt_assign(makeexpr_var(tvar),
  4791.                                                       ex));
  4792.             } else
  4793.                 freeexpr(ex);
  4794.             ex = makeexpr_var(tvar);
  4795.         }
  4796.         ex = makeexpr_bicall_4("fwrite", tp_integer, makeexpr_addr(ex),
  4797.                                                      makeexpr_sizeof(makeexpr_type(basetype), 0),
  4798.                                                      makeexpr_long(1),
  4799.                                          filebasename(copyexpr(fex)));
  4800.         if (FCheck(checkfilewrite)) {
  4801.             ex = makeexpr_bicall_2("~SETIO", tp_void,
  4802.                                    makeexpr_rel(EK_EQ, ex, makeexpr_long(1)),
  4803.                    makeexpr_name(filewriteerrorname, tp_int));
  4804.         }
  4805.         sp = makestmt_seq(sp, makestmt_call(ex));
  4806.         if (curtok == TOK_COMMA) {
  4807.             gettok();
  4808.             ex = p_expr(NULL);
  4809.         } else
  4810.             break;
  4811.     }
  4812.     freeexpr(tvardef);
  4813.     return sp;
  4814. }
  4815.  
  4816.  
  4817.  
  4818. Static Stmt *proc_write()
  4819. {
  4820.     Expr *fex, *ex;
  4821.     Stmt *sp;
  4822.  
  4823.     if (!skipopenparen())
  4824.     return NULL;
  4825.     ex = p_expr(NULL);
  4826.     if (isfiletype(ex->val.type, -1) && wneedtok(TOK_COMMA)) {
  4827.         fex = ex;
  4828.         ex = p_expr(NULL);
  4829.     } else {
  4830.         fex = makeexpr_var(mp_output);
  4831.     }
  4832.     if (fex->val.type == tp_text || fex->val.type == tp_bigtext)
  4833.         sp = handlewrite_text(fex, ex, 0);
  4834.     else
  4835.         sp = handlewrite_bin(fex, ex);
  4836.     skipcloseparen();
  4837.     return wrapopencheck(sp, fex);
  4838. }
  4839.  
  4840.  
  4841.  
  4842. Static Stmt *handle_modula_write(fmt)
  4843. char *fmt;
  4844. {
  4845.     Expr *ex, *wid;
  4846.  
  4847.     if (!skipopenparen())
  4848.     return NULL;
  4849.     ex = makeexpr_forcelongness(p_expr(NULL));
  4850.     if (skipcomma())
  4851.     wid = p_expr(tp_integer);
  4852.     else
  4853.     wid = makeexpr_long(1);
  4854.     if (checkconst(wid, 0) || checkconst(wid, 1))
  4855.     ex = makeexpr_bicall_2("printf", tp_str255,
  4856.                    makeexpr_string(format_ss("%%%s%s",
  4857.                              (exprlongness(ex) > 0) ? "l" : "",
  4858.                              fmt)),
  4859.                    ex);
  4860.     else
  4861.     ex = makeexpr_bicall_3("printf", tp_str255,
  4862.                    makeexpr_string(format_ss("%%*%s%s",
  4863.                              (exprlongness(ex) > 0) ? "l" : "",
  4864.                              fmt)),
  4865.                    makeexpr_arglong(wid, 0),
  4866.                    ex);
  4867.     skipcloseparen();
  4868.     return makestmt_call(ex);
  4869. }
  4870.  
  4871.  
  4872. Static Stmt *proc_writecard()
  4873. {
  4874.     return handle_modula_write("u");
  4875. }
  4876.  
  4877.  
  4878. Static Stmt *proc_writeint()
  4879. {
  4880.     return handle_modula_write("d");
  4881. }
  4882.  
  4883.  
  4884. Static Stmt *proc_writehex()
  4885. {
  4886.     return handle_modula_write("x");
  4887. }
  4888.  
  4889.  
  4890. Static Stmt *proc_writeoct()
  4891. {
  4892.     return handle_modula_write("o");
  4893. }
  4894.  
  4895.  
  4896. Static Stmt *proc_writereal()
  4897. {
  4898.     return handle_modula_write("f");
  4899. }
  4900.  
  4901.  
  4902.  
  4903. Static Stmt *proc_writedir()
  4904. {
  4905.     Expr *fex, *ex;
  4906.     Stmt *sp;
  4907.  
  4908.     if (!skipopenparen())
  4909.     return NULL;
  4910.     fex = p_expr(tp_text);
  4911.     if (!skipcomma())
  4912.     return NULL;
  4913.     ex = p_expr(tp_integer);
  4914.     sp = doseek(fex, ex);
  4915.     if (!skipcomma())
  4916.     return sp;
  4917.     sp = makestmt_seq(sp, handlewrite_bin(fex, p_expr(NULL)));
  4918.     skipcloseparen();
  4919.     return wrapopencheck(sp, fex);
  4920. }
  4921.  
  4922.  
  4923.  
  4924. Static Stmt *handlewriteln(iswriteln)
  4925. int iswriteln;
  4926. {
  4927.     Expr *fex, *ex;
  4928.     Stmt *sp;
  4929.     Meaning *deffile = mp_output;
  4930.  
  4931.     sp = NULL;
  4932.     if (iswriteln == 3) {
  4933.     iswriteln = 1;
  4934.     if (messagestderr)
  4935.         deffile = mp_stderr;
  4936.     }
  4937.     if (curtok != TOK_LPAR) {
  4938.         fex = makeexpr_var(deffile);
  4939.         if (iswriteln)
  4940.             sp = handlewrite_text(fex, makeexpr_string(""), -iswriteln);
  4941.     } else {
  4942.         gettok();
  4943.         ex = p_expr(NULL);
  4944.         if (isfiletype(ex->val.type, -1)) {
  4945.             fex = ex;
  4946.             if (curtok == TOK_RPAR || !wneedtok(TOK_COMMA)) {
  4947.                 if (iswriteln)
  4948.                     ex = makeexpr_string("");
  4949.                 else
  4950.                     ex = NULL;
  4951.             } else {
  4952.                 ex = p_expr(NULL);
  4953.             }
  4954.         } else {
  4955.             fex = makeexpr_var(deffile);
  4956.         }
  4957.         if (ex)
  4958.             sp = handlewrite_text(fex, ex, iswriteln);
  4959.         skipcloseparen();
  4960.     }
  4961.     if (iswriteln == 0) {
  4962.         sp = makestmt_seq(sp, makestmt_call(makeexpr_bicall_1("fflush", tp_void,
  4963.                                                               filebasename(copyexpr(fex)))));
  4964.     }
  4965.     return wrapopencheck(sp, fex);
  4966. }
  4967.  
  4968.  
  4969.  
  4970. Static Stmt *proc_overprint()
  4971. {
  4972.     return handlewriteln(2);
  4973. }
  4974.  
  4975.  
  4976.  
  4977. Static Stmt *proc_prompt()
  4978. {
  4979.     return handlewriteln(0);
  4980. }
  4981.  
  4982.  
  4983.  
  4984. Static Stmt *proc_writeln()
  4985. {
  4986.     return handlewriteln(1);
  4987. }
  4988.  
  4989.  
  4990. Static Stmt *proc_message()
  4991. {
  4992.     return handlewriteln(3);
  4993. }
  4994.  
  4995.  
  4996.  
  4997. Static Stmt *proc_writev()
  4998. {
  4999.     Expr *vex, *ex;
  5000.     Stmt *sp;
  5001.     Meaning *mp;
  5002.  
  5003.     if (!skipopenparen())
  5004.     return NULL;
  5005.     vex = p_expr(tp_str255);
  5006.     if (curtok == TOK_RPAR) {
  5007.     gettok();
  5008.     return makestmt_assign(vex, makeexpr_string(""));
  5009.     }
  5010.     if (!skipcomma())
  5011.     return NULL;
  5012.     sp = handlewrite_text(vex, p_expr(NULL), 0);
  5013.     skipcloseparen();
  5014.     ex = sp->exp1;
  5015.     if (ex->kind == EK_BICALL && !strcmp(ex->val.s, "sprintf") &&
  5016.         (mp = istempvar(ex->args[0])) != NULL) {
  5017.         canceltempvar(mp);
  5018.         ex->args[0] = vex;
  5019.     } else
  5020.         sp->exp1 = makeexpr_assign(vex, ex);
  5021.     return sp;
  5022. }
  5023.  
  5024.  
  5025. Static Stmt *proc_strwrite(mp_x, spbase)
  5026. Meaning *mp_x;
  5027. Stmt *spbase;
  5028. {
  5029.     Expr *vex, *exi, *exj, *ex;
  5030.     Stmt *sp;
  5031.     Meaning *mp;
  5032.  
  5033.     if (!skipopenparen())
  5034.     return NULL;
  5035.     vex = p_expr(tp_str255);
  5036.     if (!skipcomma())
  5037.     return NULL;
  5038.     exi = p_expr(tp_integer);
  5039.     if (!skipcomma())
  5040.     return NULL;
  5041.     exj = p_expr(tp_integer);
  5042.     if (!skipcomma())
  5043.     return NULL;
  5044.     sp = handlewrite_text(vex, p_expr(NULL), 0);
  5045.     skipcloseparen();
  5046.     ex = sp->exp1;
  5047.     FREE(sp);
  5048.     if (checkconst(exi, 1)) {
  5049.         sp = spbase;
  5050.         while (sp && sp->next)
  5051.             sp = sp->next;
  5052.         if (sp && sp->kind == SK_ASSIGN && sp->exp1->kind == EK_ASSIGN &&
  5053.              (sp->exp1->args[0]->kind == EK_HAT ||
  5054.               sp->exp1->args[0]->kind == EK_INDEX) &&
  5055.              exprsame(sp->exp1->args[0]->args[0], vex, 1) &&
  5056.              checkconst(sp->exp1->args[1], 0)) {
  5057.             nukestmt(sp);     /* remove preceding bogus setstrlen */
  5058.         }
  5059.     }
  5060.     if (ex->kind == EK_BICALL && !strcmp(ex->val.s, "sprintf") &&
  5061.         (mp = istempvar(ex->args[0])) != NULL) {
  5062.         canceltempvar(mp);
  5063.         ex->args[0] = bumpstring(copyexpr(vex), exi, 1);
  5064.         sp = makestmt_call(ex);
  5065.     } else
  5066.         sp = makestmt_assign(bumpstring(copyexpr(vex), exi, 1), ex);
  5067.     if (fullstrwrite != 0) {
  5068.         sp = makestmt_seq(sp, makestmt_assign(exj,
  5069.                                               makeexpr_plus(makeexpr_bicall_1("strlen", tp_int, vex),
  5070.                                                             makeexpr_long(1))));
  5071.         if (fullstrwrite == 1)
  5072.             note("FullStrWrite=1 not yet supported [204]");
  5073.         if (fullstrwrite == 2)
  5074.             note("STRWRITE was used [205]");
  5075.     } else {
  5076.         freeexpr(vex);
  5077.     }
  5078.     return mixassignments(sp, NULL);
  5079. }
  5080.  
  5081.  
  5082.  
  5083. Static Stmt *proc_str_turbo()
  5084. {
  5085.     Expr *ex, *wid, *prec;
  5086.  
  5087.     if (!skipopenparen())
  5088.     return NULL;
  5089.     ex = p_expr(NULL);
  5090.     wid = NULL;
  5091.     prec = NULL;
  5092.     if (curtok == TOK_COLON) {
  5093.         gettok();
  5094.         wid = p_expr(tp_integer);
  5095.         if (curtok == TOK_COLON) {
  5096.             gettok();
  5097.             prec = p_expr(tp_integer);
  5098.         }
  5099.     }
  5100.     ex = writeelement(ex, wid, prec, 10);
  5101.     if (!skipcomma())
  5102.     return NULL;
  5103.     wid = p_expr(tp_str255);
  5104.     skipcloseparen();
  5105.     return makestmt_assign(wid, ex);
  5106. }
  5107.  
  5108.  
  5109.  
  5110. Static Stmt *proc_time()
  5111. {
  5112.     Expr *ex;
  5113.  
  5114.     if (!skipopenparen())
  5115.     return NULL;
  5116.     ex = p_expr(tp_str255);
  5117.     skipcloseparen();
  5118.     return makestmt_call(makeexpr_bicall_1("VAXtime", tp_integer, ex));
  5119. }
  5120.  
  5121.  
  5122. Static Expr *func_xor()
  5123. {
  5124.     Expr *ex, *ex2;
  5125.     Type *type;
  5126.     Meaning *tvar;
  5127.  
  5128.     if (!skipopenparen())
  5129.     return NULL;
  5130.     ex = p_expr(NULL);
  5131.     if (!skipcomma())
  5132.     return ex;
  5133.     ex2 = p_expr(ex->val.type);
  5134.     skipcloseparen();
  5135.     if (ex->val.type->kind != TK_SET &&
  5136.     ex->val.type->kind != TK_SMALLSET) {
  5137.     ex = makeexpr_bin(EK_BXOR, ex->val.type, ex, ex2);
  5138.     } else {
  5139.     type = mixsets(&ex, &ex2);
  5140.     tvar = makestmttempvar(type, name_SET);
  5141.     ex = makeexpr_bicall_3(setxorname, type,
  5142.                    makeexpr_var(tvar),
  5143.                    ex, ex2);
  5144.     }
  5145.     return ex;
  5146. }
  5147.  
  5148.  
  5149.  
  5150.  
  5151.  
  5152.  
  5153.  
  5154. void decl_builtins()
  5155. {
  5156.     makespecialfunc( "ABS",           func_abs);
  5157.     makespecialfunc( "ADDR",          func_addr);
  5158.     if (!modula2)
  5159.     makespecialfunc( "ADDRESS",   func_addr);
  5160.     makespecialfunc( "ADDTOPOINTER",  func_addtopointer);
  5161.     makespecialfunc( "ADR",           func_addr);
  5162.     makespecialfunc( "ASL",          func_lsl);
  5163.     makespecialfunc( "ASR",          func_asr);
  5164.     makespecialfunc( "BADDRESS",      func_iaddress);
  5165.     makespecialfunc( "BAND",          func_uand);
  5166.     makespecialfunc( "BIN",           func_bin);
  5167.     makespecialfunc( "BITNEXT",          func_bitnext);
  5168.     makespecialfunc( "BITSIZE",          func_bitsize);
  5169.     makespecialfunc( "BITSIZEOF",     func_bitsize);
  5170. mp_blockread_ucsd =
  5171.     makespecialfunc( "BLOCKREAD",     func_blockread);
  5172. mp_blockwrite_ucsd =
  5173.     makespecialfunc( "BLOCKWRITE",    func_blockwrite);
  5174.     makespecialfunc( "BNOT",          func_unot);
  5175.     makespecialfunc( "BOR",          func_uor);
  5176.     makespecialfunc( "BSL",          func_bsl);
  5177.     makespecialfunc( "BSR",          func_bsr);
  5178.     makespecialfunc( "BTST",          func_btst);
  5179.     makespecialfunc( "BXOR",          func_uxor);
  5180.     makespecialfunc( "BYTEREAD",      func_byteread);
  5181.     makespecialfunc( "BYTEWRITE",     func_bytewrite);
  5182.     makespecialfunc( "BYTE_OFFSET",   func_byte_offset);
  5183.     makespecialfunc( "CHR",           func_chr);         
  5184.     makespecialfunc( "CONCAT",        func_concat);
  5185.     makespecialfunc( "DBLE",          func_float);
  5186. mp_dec_dec =
  5187.     makespecialfunc( "DEC",           func_dec);
  5188.     makespecialfunc( "EOF",           func_eof);
  5189.     makespecialfunc( "EOLN",          func_eoln);
  5190.     makespecialfunc( "FCALL",         func_fcall);
  5191.     makespecialfunc( "FILEPOS",       func_filepos);
  5192.     makespecialfunc( "FILESIZE",      func_filesize);
  5193.     makespecialfunc( "FLOAT",          func_float);
  5194.     makespecialfunc( "HEX",           func_hex);         
  5195.     makespecialfunc( "HI",            func_hi);
  5196.     makespecialfunc( "HIWORD",        func_hiword);
  5197.     makespecialfunc( "HIWRD",         func_hiword);
  5198.     makespecialfunc( "HIGH",          func_high);
  5199.     makespecialfunc( "IADDRESS",      func_iaddress);
  5200.     makespecialfunc( "INT",           func_int);         
  5201.     makespecialfunc( "LAND",          func_uand);
  5202.     makespecialfunc( "LNOT",          func_unot);
  5203.     makespecialfunc( "LO",            func_lo);
  5204.     makespecialfunc( "LOOPHOLE",      func_loophole);
  5205.     makespecialfunc( "LOR",          func_uor);
  5206.     makespecialfunc( "LOWER",          func_lower);
  5207.     makespecialfunc( "LOWORD",        func_loword);
  5208.     makespecialfunc( "LOWRD",         func_loword);
  5209.     makespecialfunc( "LSL",          func_lsl);
  5210.     makespecialfunc( "LSR",          func_lsr);
  5211.     makespecialfunc( "MAX",          func_max);
  5212.     makespecialfunc( "MAXPOS",        func_maxpos);
  5213.     makespecialfunc( "MIN",          func_min);
  5214.     makespecialfunc( "NEXT",          func_sizeof);
  5215.     makespecialfunc( "OCT",           func_oct);
  5216.     makespecialfunc( "ORD",           func_ord);
  5217.     makespecialfunc( "ORD4",          func_ord4);
  5218.     makespecialfunc( "PI",          func_pi);
  5219.     makespecialfunc( "POSITION",      func_position);
  5220.     makespecialfunc( "PRED",          func_pred);
  5221.     makespecialfunc( "QUAD",          func_float);
  5222.     makespecialfunc( "RANDOM",        func_random);
  5223.     makespecialfunc( "REF",          func_addr);
  5224.     makespecialfunc( "SCAN",          func_scan);
  5225.     makespecialfunc( "SEEKEOF",       func_seekeof);
  5226.     makespecialfunc( "SEEKEOLN",      func_seekeoln);
  5227.     makespecialfunc( "SIZE",          func_sizeof);
  5228.     makespecialfunc( "SIZEOF",        func_sizeof);
  5229.     makespecialfunc( "SNGL",          func_sngl);
  5230.     makespecialfunc( "SQR",           func_sqr);
  5231.     makespecialfunc( "STATUSV",          func_statusv);
  5232.     makespecialfunc( "SUCC",          func_succ);
  5233.     makespecialfunc( "TSIZE",         func_sizeof);
  5234.     makespecialfunc( "UAND",          func_uand);
  5235.     makespecialfunc( "UDEC",          func_udec);
  5236.     makespecialfunc( "UINT",          func_uint);         
  5237.     makespecialfunc( "UNOT",          func_unot);
  5238.     makespecialfunc( "UOR",          func_uor);
  5239.     makespecialfunc( "UPPER",          func_upper);
  5240.     makespecialfunc( "UXOR",          func_uxor);
  5241. mp_val_modula =
  5242.     makespecialfunc( "VAL",          func_val_modula);
  5243.     makespecialfunc( "WADDRESS",      func_iaddress);
  5244.     makespecialfunc( "XOR",          func_xor);
  5245.  
  5246.     makestandardfunc("ARCTAN",        func_arctan);
  5247.     makestandardfunc("ARCTANH",       func_arctanh);
  5248.     makestandardfunc("BINARY",        func_binary);      
  5249.     makestandardfunc("CAP",           func_upcase);
  5250.     makestandardfunc("COPY",          func_copy);        
  5251.     makestandardfunc("COS",           func_cos);         
  5252.     makestandardfunc("COSH",          func_cosh);         
  5253.     makestandardfunc("EXP",           func_exp);         
  5254.     makestandardfunc("EXP10",         func_pwroften);
  5255.     makestandardfunc("EXPO",          func_expo);         
  5256.     makestandardfunc("FRAC",          func_frac);        
  5257.     makestandardfunc("INDEX",         func_strpos);      
  5258.     makestandardfunc("LASTPOS",       NULL);             
  5259.     makestandardfunc("LINEPOS",       NULL);             
  5260.     makestandardfunc("LENGTH",        func_strlen);      
  5261.     makestandardfunc("LN",            func_ln);          
  5262.     makestandardfunc("LOG",           func_log);
  5263.     makestandardfunc("LOG10",         func_log);
  5264.     makestandardfunc("MAXAVAIL",      func_maxavail);
  5265.     makestandardfunc("MEMAVAIL",      func_memavail);
  5266.     makestandardfunc("OCTAL",         func_octal);       
  5267.     makestandardfunc("ODD",           func_odd);         
  5268.     makestandardfunc("PAD",           func_pad);
  5269.     makestandardfunc("PARAMCOUNT",    func_paramcount);
  5270.     makestandardfunc("PARAMSTR",      func_paramstr);    
  5271.     makestandardfunc("POS",           func_pos);         
  5272.     makestandardfunc("PTR",           func_ptr);
  5273.     makestandardfunc("PWROFTEN",      func_pwroften);
  5274.     makestandardfunc("ROUND",         func_round);       
  5275.     makestandardfunc("SCANEQ",        func_scaneq);
  5276.     makestandardfunc("SCANNE",        func_scanne);
  5277.     makestandardfunc("SIN",           func_sin);         
  5278.     makestandardfunc("SINH",          func_sinh);         
  5279.     makestandardfunc("SQRT",          func_sqrt);        
  5280. mp_str_hp =
  5281.     makestandardfunc("STR",           func_str_hp);
  5282.     makestandardfunc("STRLEN",        func_strlen);      
  5283.     makestandardfunc("STRLTRIM",      func_strltrim);    
  5284.     makestandardfunc("STRMAX",        func_strmax);      
  5285.     makestandardfunc("STRPOS",        func_strpos);      
  5286.     makestandardfunc("STRRPT",        func_strrpt);      
  5287.     makestandardfunc("STRRTRIM",      func_strrtrim);    
  5288.     makestandardfunc("SUBSTR",        func_str_hp);
  5289.     makestandardfunc("SWAP",          func_swap);        
  5290.     makestandardfunc("TAN",           func_tan);       
  5291.     makestandardfunc("TANH",          func_tanh);       
  5292.     makestandardfunc("TRUNC",         func_trunc);       
  5293.     makestandardfunc("UPCASE",        func_upcase);      
  5294.     makestandardfunc("UROUND",        func_uround);
  5295.     makestandardfunc("UTRUNC",        func_utrunc);
  5296.  
  5297.     makespecialproc( "APPEND",        proc_append);
  5298.     makespecialproc( "ARGV",          proc_argv);
  5299.     makespecialproc( "ASSERT",        proc_assert);
  5300.     makespecialproc( "ASSIGN",        proc_assign);
  5301.     makespecialproc( "BCLR",          proc_bclr);
  5302. mp_blockread_turbo =
  5303.     makespecialproc( "BLOCKREAD_TURBO", proc_blockread);
  5304. mp_blockwrite_turbo =
  5305.     makespecialproc( "BLOCKWRITE_TURBO", proc_blockwrite);
  5306.     makespecialproc( "BREAK",         proc_flush);
  5307.     makespecialproc( "BSET",          proc_bset);
  5308.     makespecialproc( "CALL",          proc_call);
  5309.     makespecialproc( "CLOSE",         proc_close);
  5310.     makespecialproc( "CONNECT",       proc_assign);
  5311.     makespecialproc( "CYCLE",          proc_cycle);
  5312.     makespecialproc( "DATE",          proc_date);
  5313. mp_dec_turbo =
  5314.     makespecialproc( "DEC_TURBO",     proc_dec);
  5315.     makespecialproc( "DISPOSE",       proc_dispose);
  5316.     makespecialproc( "ESCAPE",        proc_escape);
  5317.     makespecialproc( "EXCL",          proc_excl);
  5318.     makespecialproc( "EXIT",          proc_exit);
  5319.     makespecialproc( "FILLCHAR",      proc_fillchar);
  5320.     makespecialproc( "FLUSH",         proc_flush);
  5321.     makespecialproc( "GET",           proc_get);
  5322.     makespecialproc( "HALT",          proc_escape);
  5323.     makespecialproc( "INC",           proc_inc);
  5324.     makespecialproc( "INCL",          proc_incl);
  5325.     makespecialproc( "LEAVE",          proc_leave);
  5326.     makespecialproc( "LOCATE",        proc_seek);
  5327.     makespecialproc( "MESSAGE",       proc_message);
  5328.     makespecialproc( "MOVE_FAST",     proc_move_fast);        
  5329.     makespecialproc( "MOVE_L_TO_R",   proc_move_fast);        
  5330.     makespecialproc( "MOVE_R_TO_L",   proc_move_fast);        
  5331.     makespecialproc( "NEW",           proc_new);
  5332.     if (which_lang != LANG_VAX)
  5333.     makespecialproc( "OPEN",      proc_open);
  5334.     makespecialproc( "OVERPRINT",     proc_overprint);
  5335.     makespecialproc( "PACK",          proc_pack);
  5336.     makespecialproc( "PAGE",          proc_page);
  5337.     makespecialproc( "PUT",           proc_put);
  5338.     makespecialproc( "PROMPT",        proc_prompt);
  5339.     makespecialproc( "RANDOMIZE",     proc_randomize);
  5340.     makespecialproc( "READ",          proc_read);
  5341.     makespecialproc( "READDIR",       proc_readdir);
  5342.     makespecialproc( "READLN",        proc_readln);
  5343.     makespecialproc( "READV",         proc_readv);
  5344.     makespecialproc( "RESET",         proc_reset);
  5345.     makespecialproc( "REWRITE",       proc_rewrite);
  5346.     makespecialproc( "SEEK",          proc_seek);
  5347.     makespecialproc( "SETSTRLEN",     proc_setstrlen);
  5348.     makespecialproc( "SETTEXTBUF",    proc_settextbuf);
  5349. mp_str_turbo =
  5350.     makespecialproc( "STR_TURBO",     proc_str_turbo);
  5351.     makespecialproc( "STRAPPEND",     proc_strappend);
  5352.     makespecialproc( "STRDELETE",     proc_strdelete);
  5353.     makespecialproc( "STRINSERT",     proc_strinsert);
  5354.     makespecialproc( "STRMOVE",       proc_strmove);
  5355.     makespecialproc( "STRREAD",       proc_strread);
  5356.     makespecialproc( "STRWRITE",      proc_strwrite);
  5357.     makespecialproc( "TIME",          proc_time);
  5358.     makespecialproc( "UNPACK",        proc_unpack);
  5359.     makespecialproc( "WRITE",         proc_write);
  5360.     makespecialproc( "WRITEDIR",      proc_writedir);
  5361.     makespecialproc( "WRITELN",       proc_writeln);
  5362.     makespecialproc( "WRITEV",        proc_writev);
  5363. mp_val_turbo =
  5364.     makespecialproc( "VAL_TURBO",     proc_val_turbo);
  5365.  
  5366.     makestandardproc("DELETE",        proc_delete);      
  5367.     makestandardproc("FREEMEM",       proc_freemem);     
  5368.     makestandardproc("GETMEM",        proc_getmem);
  5369.     makestandardproc("GOTOXY",        proc_gotoxy);      
  5370.     makestandardproc("INSERT",        proc_insert);      
  5371.     makestandardproc("MARK",          NULL);             
  5372.     makestandardproc("MOVE",          proc_move);        
  5373.     makestandardproc("MOVELEFT",      proc_move);        
  5374.     makestandardproc("MOVERIGHT",     proc_move);        
  5375.     makestandardproc("RELEASE",       NULL);             
  5376.  
  5377.     makespecialvar(  "MEM",           var_mem);
  5378.     makespecialvar(  "MEMW",          var_memw);
  5379.     makespecialvar(  "MEML",          var_meml);
  5380.     makespecialvar(  "PORT",          var_port);
  5381.     makespecialvar(  "PORTW",         var_portw);
  5382.  
  5383.     /* Modula-2 standard I/O procedures (case-sensitive!) */
  5384.     makespecialproc( "Read",          proc_read);
  5385.     makespecialproc( "ReadCard",      proc_read);
  5386.     makespecialproc( "ReadInt",       proc_read);
  5387.     makespecialproc( "ReadReal",      proc_read);
  5388.     makespecialproc( "ReadString",    proc_read);
  5389.     makespecialproc( "Write",         proc_write);
  5390.     makespecialproc( "WriteCard",     proc_writecard);
  5391.     makespecialproc( "WriteHex",      proc_writehex);
  5392.     makespecialproc( "WriteInt",      proc_writeint);
  5393.     makespecialproc( "WriteOct",      proc_writeoct);
  5394.     makespecialproc( "WriteLn",       proc_writeln);
  5395.     makespecialproc( "WriteReal",     proc_writereal);
  5396.     makespecialproc( "WriteString",   proc_write);
  5397. }
  5398.  
  5399.  
  5400.  
  5401.  
  5402. /* End. */
  5403.  
  5404.  
  5405.  
  5406.