home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume21 / p2c / part21 < prev    next >
Text File  |  1990-04-05  |  52KB  |  2,030 lines
  1. Subject:  v21i066:  Pascal to C translator, Part21/32
  2. Newsgroups: comp.sources.unix
  3. Approved: rsalz@uunet.UU.NET
  4. X-Checksum-Snefru: ca6695f9 9e8d6867 f5aecc09 b3aae984
  5.  
  6. Submitted-by: Dave Gillespie <daveg@csvax.caltech.edu>
  7. Posting-number: Volume 21, Issue 66
  8. Archive-name: p2c/part21
  9.  
  10. #! /bin/sh
  11. # This is a shell archive.  Remove anything before this line, then unpack
  12. # it by saving it into a file and typing "sh file".  To overwrite existing
  13. # files, type "sh file -c".  You can also feed this as standard input via
  14. # unshar, or by typing "sh <file", e.g..  If this archive is complete, you
  15. # will see the following message at the end:
  16. #        "End of archive 21 (of 32)."
  17. # Contents:  src/funcs.c.1
  18. # Wrapped by rsalz@litchi.bbn.com on Mon Mar 26 14:29:44 1990
  19. PATH=/bin:/usr/bin:/usr/ucb ; export PATH
  20. if test -f 'src/funcs.c.1' -a "${1}" != "-c" ; then 
  21.   echo shar: Will not clobber existing file \"'src/funcs.c.1'\"
  22. else
  23. echo shar: Extracting \"'src/funcs.c.1'\" \(48548 characters\)
  24. sed "s/^X//" >'src/funcs.c.1' <<'END_OF_FILE'
  25. X/* "p2c", a Pascal to C translator.
  26. X   Copyright (C) 1989 David Gillespie.
  27. X   Author's address: daveg@csvax.caltech.edu; 256-80 Caltech/Pasadena CA 91125.
  28. X
  29. XThis program is free software; you can redistribute it and/or modify
  30. Xit under the terms of the GNU General Public License as published by
  31. Xthe Free Software Foundation (any version).
  32. X
  33. XThis program is distributed in the hope that it will be useful,
  34. Xbut WITHOUT ANY WARRANTY; without even the implied warranty of
  35. XMERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  36. XGNU General Public License for more details.
  37. X
  38. XYou should have received a copy of the GNU General Public License
  39. Xalong with this program; see the file COPYING.  If not, write to
  40. Xthe Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
  41. X
  42. X
  43. X
  44. X#define PROTO_FUNCS_C
  45. X#include "trans.h"
  46. X
  47. X
  48. X
  49. X
  50. XStatic Strlist *enumnames;
  51. XStatic int enumnamecount;
  52. X
  53. X
  54. X
  55. Xvoid setup_funcs()
  56. X{
  57. X    enumnames = NULL;
  58. X    enumnamecount = 0;
  59. X}
  60. X
  61. X
  62. X
  63. X
  64. X
  65. Xint isvar(ex, mp)
  66. XExpr *ex;
  67. XMeaning *mp;
  68. X{
  69. X    return (ex->kind == EK_VAR && (Meaning *)ex->val.i == mp);
  70. X}
  71. X
  72. X
  73. X
  74. X
  75. Xchar *getstring(ex)
  76. XExpr *ex;
  77. X{
  78. X    ex = makeexpr_stringify(ex);
  79. X    if (ex->kind != EK_CONST || ex->val.type->kind != TK_STRING) {
  80. X        intwarning("getstring", "Not a string literal [206]");
  81. X    return "";
  82. X    }
  83. X    return ex->val.s;
  84. X}
  85. X
  86. X
  87. X
  88. X
  89. XExpr *p_parexpr(target)
  90. XType *target;
  91. X{
  92. X    Expr *ex;
  93. X
  94. X    if (wneedtok(TOK_LPAR)) {
  95. X    ex = p_expr(target);
  96. X    if (!wneedtok(TOK_RPAR))
  97. X        skippasttotoken(TOK_RPAR, TOK_SEMI);
  98. X    } else
  99. X    ex = p_expr(target);
  100. X    return ex;
  101. X}
  102. X
  103. X
  104. X
  105. XType *argbasetype(ex)
  106. XExpr *ex;
  107. X{
  108. X    if (ex->kind == EK_CAST)
  109. X        ex = ex->args[0];
  110. X    if (ex->val.type->kind == TK_POINTER)
  111. X        return ex->val.type->basetype;
  112. X    else
  113. X        return ex->val.type;
  114. X}
  115. X
  116. X
  117. X
  118. XType *choosetype(t1, t2)
  119. XType *t1, *t2;
  120. X{
  121. X    if (t1 == tp_void ||
  122. X        (type_sizeof(t2, 1) && !type_sizeof(t1, 1)))
  123. X        return t2;
  124. X    else
  125. X        return t1;
  126. X}
  127. X
  128. X
  129. X
  130. XExpr *convert_offset(type, ex2)
  131. XType *type;
  132. XExpr *ex2;
  133. X{
  134. X    long size;
  135. X    int i;
  136. X    Value val;
  137. X    Expr *ex3;
  138. X
  139. X    if (type->kind == TK_POINTER ||
  140. X        type->kind == TK_ARRAY ||
  141. X        type->kind == TK_SET ||
  142. X        type->kind == TK_STRING)
  143. X        type = type->basetype;
  144. X    size = type_sizeof(type, 1);
  145. X    if (size == 1)
  146. X        return ex2;
  147. X    val = eval_expr_pasc(ex2);
  148. X    if (val.type) {
  149. X        if (val.i == 0)
  150. X            return ex2;
  151. X        if (size && val.i % size == 0) {
  152. X            freeexpr(ex2);
  153. X            return makeexpr_long(val.i / size);
  154. X        }
  155. X    } else {     /* look for terms like "n*sizeof(foo)" */
  156. X    while (ex2->kind == EK_CAST || ex2->kind == EK_ACTCAST)
  157. X        ex2 = ex2->args[0];
  158. X        if (ex2->kind == EK_TIMES) {
  159. X        for (i = 0; i < ex2->nargs; i++) {
  160. X        ex3 = convert_offset(type, ex2->args[i]);
  161. X        if (ex3) {
  162. X            ex2->args[i] = ex3;
  163. X            return resimplify(ex2);
  164. X        }
  165. X        }
  166. X            for (i = 0;
  167. X                 i < ex2->nargs && ex2->args[i]->kind != EK_SIZEOF;
  168. X                 i++) ;
  169. X            if (i < ex2->nargs) {
  170. X                if (ex2->args[i]->args[0]->val.type == type) {
  171. X                    delfreearg(&ex2, i);
  172. X                    if (ex2->nargs == 1)
  173. X                        return ex2->args[0];
  174. X                    else
  175. X                        return ex2;
  176. X                }
  177. X            }
  178. X        } else if (ex2->kind == EK_PLUS) {
  179. X        ex3 = copyexpr(ex2);
  180. X        for (i = 0; i < ex2->nargs; i++) {
  181. X        ex3->args[i] = convert_offset(type, ex3->args[i]);
  182. X        if (!ex3->args[i]) {
  183. X            freeexpr(ex3);
  184. X            return NULL;
  185. X        }
  186. X        }
  187. X        freeexpr(ex2);
  188. X        return resimplify(ex3);
  189. X        } else if (ex2->kind == EK_SIZEOF) {
  190. X            if (ex2->args[0]->val.type == type) {
  191. X                freeexpr(ex2);
  192. X                return makeexpr_long(1);
  193. X            }
  194. X        } else if (ex2->kind == EK_NEG) {
  195. X        ex3 = convert_offset(type, ex2->args[0]);
  196. X        if (ex3)
  197. X                return makeexpr_neg(ex3);
  198. X        }
  199. X    }
  200. X    return NULL;
  201. X}
  202. X
  203. X
  204. X
  205. XExpr *convert_size(type, ex, name)
  206. XType *type;
  207. XExpr *ex;
  208. Xchar *name;
  209. X{
  210. X    long size;
  211. X    Expr *ex2;
  212. X    int i, okay;
  213. X    Value val;
  214. X
  215. X    if (debug>2) { fprintf(outf,"convert_size("); dumpexpr(ex); fprintf(outf,")\n"); }
  216. X    while (type->kind == TK_ARRAY || type->kind == TK_STRING)
  217. X        type = type->basetype;
  218. X    if (type == tp_void)
  219. X        return ex;
  220. X    size = type_sizeof(type, 1);
  221. X    if (size == 1)
  222. X        return ex;
  223. X    while (ex->kind == EK_CAST || ex->kind == EK_ACTCAST)
  224. X    ex = ex->args[0];
  225. X    switch (ex->kind) {
  226. X
  227. X        case EK_TIMES:
  228. X            for (i = 0; i < ex->nargs; i++) {
  229. X                ex2 = convert_size(type, ex->args[i], NULL);
  230. X                if (ex2) {
  231. X                    ex->args[i] = ex2;
  232. X                    return resimplify(ex);
  233. X                }
  234. X            }
  235. X            break;
  236. X
  237. X        case EK_PLUS:
  238. X            okay = 1;
  239. X            for (i = 0; i < ex->nargs; i++) {
  240. X                ex2 = convert_size(type, ex->args[i], NULL);
  241. X                if (ex2)
  242. X                    ex->args[i] = ex2;
  243. X                else
  244. X                    okay = 0;
  245. X            }
  246. X            ex = distribute_plus(ex);
  247. X            if ((ex->kind != EK_TIMES || !okay) && name)
  248. X                note(format_s("Suspicious mixture of sizes in %s [173]", name));
  249. X            return ex;
  250. X
  251. X        case EK_SIZEOF:
  252. X            return ex;
  253. X
  254. X    default:
  255. X        break;
  256. X    }
  257. X    val = eval_expr_pasc(ex);
  258. X    if (val.type) {
  259. X        if (val.i == 0)
  260. X            return ex;
  261. X        if (size && val.i % size == 0) {
  262. X            freeexpr(ex);
  263. X            return makeexpr_times(makeexpr_long(val.i / size),
  264. X                                  makeexpr_sizeof(makeexpr_type(type), 0));
  265. X        }
  266. X    }
  267. X    if (name) {
  268. X        note(format_s("Can't interpret size in %s [174]", name));
  269. X        return ex;
  270. X    } else
  271. X        return NULL;
  272. X}
  273. X
  274. X
  275. X
  276. X
  277. X
  278. X
  279. X
  280. X
  281. X
  282. X
  283. X
  284. X
  285. XStatic Expr *func_abs()
  286. X{
  287. X    Expr *ex;
  288. X    Meaning *tvar;
  289. X    int lness;
  290. X
  291. X    ex = p_parexpr(tp_integer);
  292. X    if (ex->val.type->kind == TK_REAL)
  293. X        return makeexpr_bicall_1("fabs", tp_longreal, ex);
  294. X    else {
  295. X        lness = exprlongness(ex);
  296. X        if (lness < 0)
  297. X            return makeexpr_bicall_1("abs", tp_int, ex);
  298. X        else if (lness > 0 && *absname) {
  299. X            if (ansiC > 0) {
  300. X                return makeexpr_bicall_1("labs", tp_integer, ex);
  301. X            } else if (*absname == '*' && (exprspeed(ex) >= 5 || !nosideeffects(ex, 0))) {
  302. X                tvar = makestmttempvar(tp_integer, name_TEMP);
  303. X                return makeexpr_comma(makeexpr_assign(makeexpr_var(tvar),
  304. X                                                      ex),
  305. X                                      makeexpr_bicall_1(absname, tp_integer,
  306. X                                                        makeexpr_var(tvar)));
  307. X            } else {
  308. X                return makeexpr_bicall_1(absname, tp_integer, ex);
  309. X            }
  310. X        } else if (exprspeed(ex) < 5 && nosideeffects(ex, 0)) {
  311. X            return makeexpr_cond(makeexpr_rel(EK_LT, copyexpr(ex),
  312. X                                                     makeexpr_long(0)),
  313. X                                 makeexpr_neg(copyexpr(ex)),
  314. X                                 ex);
  315. X        } else {
  316. X            tvar = makestmttempvar(tp_integer, name_TEMP);
  317. X            return makeexpr_cond(makeexpr_rel(EK_LT, makeexpr_assign(makeexpr_var(tvar),
  318. X                                                                     ex),
  319. X                                                     makeexpr_long(0)),
  320. X                                 makeexpr_neg(makeexpr_var(tvar)),
  321. X                                 makeexpr_var(tvar));
  322. X        }
  323. X    }
  324. X}
  325. X
  326. X
  327. X
  328. XStatic Expr *func_addr()
  329. X{
  330. X    Expr *ex, *ex2, *ex3;
  331. X    Type *type, *tp2;
  332. X    int haspar;
  333. X
  334. X    haspar = wneedtok(TOK_LPAR);
  335. X    ex = p_expr(tp_proc);
  336. X    if (curtok == TOK_COMMA) {
  337. X        gettok();
  338. X        ex2 = p_expr(tp_integer);
  339. X        ex3 = convert_offset(ex->val.type, ex2);
  340. X        if (checkconst(ex3, 0)) {
  341. X            ex = makeexpr_addrf(ex);
  342. X        } else {
  343. X            ex = makeexpr_addrf(ex);
  344. X            if (ex3) {
  345. X                ex = makeexpr_plus(ex, ex3);
  346. X            } else {
  347. X                note("Don't know how to reduce offset for ADDR [175]");
  348. X                type = makepointertype(tp_abyte);
  349. X        tp2 = ex->val.type;
  350. X                ex = makeexpr_cast(makeexpr_plus(makeexpr_cast(ex, type), ex2), tp2);
  351. X            }
  352. X        }
  353. X    } else {
  354. X    if ((ex->val.type->kind != TK_PROCPTR &&
  355. X         ex->val.type->kind != TK_CPROCPTR) ||
  356. X        (ex->kind == EK_VAR &&
  357. X         ex->val.type == ((Meaning *)ex->val.i)->type))
  358. X        ex = makeexpr_addrf(ex);
  359. X    }
  360. X    if (haspar) {
  361. X    if (!wneedtok(TOK_RPAR))
  362. X        skippasttotoken(TOK_RPAR, TOK_SEMI);
  363. X    }
  364. X    return ex;
  365. X}
  366. X
  367. X
  368. XStatic Expr *func_iaddress()
  369. X{
  370. X    return makeexpr_cast(func_addr(), tp_integer);
  371. X}
  372. X
  373. X
  374. X
  375. XStatic Expr *func_addtopointer()
  376. X{
  377. X    Expr *ex, *ex2, *ex3;
  378. X    Type *type, *tp2;
  379. X
  380. X    if (!skipopenparen())
  381. X    return NULL;
  382. X    ex = p_expr(tp_anyptr);
  383. X    if (skipcomma()) {
  384. X    ex2 = p_expr(tp_integer);
  385. X    } else
  386. X    ex2 = makeexpr_long(0);
  387. X    skipcloseparen();
  388. X    ex3 = convert_offset(ex->val.type, ex2);
  389. X    if (!checkconst(ex3, 0)) {
  390. X    if (ex3) {
  391. X        ex = makeexpr_plus(ex, ex3);
  392. X    } else {
  393. X        note("Don't know how to reduce offset for ADDTOPOINTER [175]");
  394. X        type = makepointertype(tp_abyte);
  395. X        tp2 = ex->val.type;
  396. X        ex = makeexpr_cast(makeexpr_plus(makeexpr_cast(ex, type), ex2), tp2);
  397. X    }
  398. X    }
  399. X    return ex;
  400. X}
  401. X
  402. X
  403. X
  404. XStmt *proc_assert()
  405. X{
  406. X    Expr *ex;
  407. X
  408. X    ex = p_parexpr(tp_boolean);
  409. X    return makestmt_call(makeexpr_bicall_1("assert", tp_void, ex));
  410. X}
  411. X
  412. X
  413. X
  414. XStmt *wrapopencheck(sp, fex)
  415. XStmt *sp;
  416. XExpr *fex;
  417. X{
  418. X    Stmt *sp2;
  419. X
  420. X    if (FCheck(checkfileisopen) && !is_std_file(fex)) {
  421. X        sp2 = makestmt(SK_IF);
  422. X        sp2->exp1 = makeexpr_rel(EK_NE, fex, makeexpr_nil());
  423. X        sp2->stm1 = sp;
  424. X        if (iocheck_flag) {
  425. X            sp2->stm2 = makestmt_call(makeexpr_bicall_1(name_ESCIO, tp_integer,
  426. X                            makeexpr_name(filenotopenname, tp_int)));
  427. X        } else {
  428. X            sp2->stm2 = makestmt_assign(makeexpr_var(mp_ioresult),
  429. X                    makeexpr_name(filenotopenname, tp_int));
  430. X        }
  431. X        return sp2;
  432. X    } else {
  433. X        freeexpr(fex);
  434. X        return sp;
  435. X    }
  436. X}
  437. X
  438. X
  439. X
  440. XStatic Expr *checkfilename(nex)
  441. XExpr *nex;
  442. X{
  443. X    Expr *ex;
  444. X
  445. X    nex = makeexpr_stringcast(nex);
  446. X    if (nex->kind == EK_CONST && nex->val.type->kind == TK_STRING) {
  447. X        switch (which_lang) {
  448. X
  449. X            case LANG_HP:
  450. X                if (!strncmp(nex->val.s, "#1:", 3) ||
  451. X                    !strncmp(nex->val.s, "console:", 8) ||
  452. X                    !strncmp(nex->val.s, "CONSOLE:", 8)) {
  453. X                    freeexpr(nex);
  454. X                    nex = makeexpr_string("/dev/tty");
  455. X                } else if (!strncmp(nex->val.s, "#2:", 3) ||
  456. X                           !strncmp(nex->val.s, "systerm:", 8) ||
  457. X                           !strncmp(nex->val.s, "SYSTERM:", 8)) {
  458. X                    freeexpr(nex);
  459. X                    nex = makeexpr_string("/dev/tty");     /* should do more? */
  460. X                } else if (!strncmp(nex->val.s, "#6:", 3) ||
  461. X                           !strncmp(nex->val.s, "printer:", 8) ||
  462. X                           !strncmp(nex->val.s, "PRINTER:", 8)) {
  463. X                    note("Opening a file named PRINTER: [176]");
  464. X                } else if (my_strchr(nex->val.s, ':')) {
  465. X                    note("Opening a file whose name contains a ':' [177]");
  466. X                }
  467. X                break;
  468. X
  469. X            case LANG_TURBO:
  470. X                if (checkstring(nex, "con") ||
  471. X                    checkstring(nex, "CON") ||
  472. X                    checkstring(nex, "")) {
  473. X                    freeexpr(nex);
  474. X                    nex = makeexpr_string("/dev/tty");
  475. X                } else if (checkstring(nex, "nul") ||
  476. X                           checkstring(nex, "NUL")) {
  477. X                    freeexpr(nex);
  478. X                    nex = makeexpr_string("/dev/null");
  479. X                } else if (checkstring(nex, "lpt1") ||
  480. X                           checkstring(nex, "LPT1") ||
  481. X                           checkstring(nex, "lpt2") ||
  482. X                           checkstring(nex, "LPT2") ||
  483. X                           checkstring(nex, "lpt3") ||
  484. X                           checkstring(nex, "LPT3") ||
  485. X                           checkstring(nex, "com1") ||
  486. X                           checkstring(nex, "COM1") ||
  487. X                           checkstring(nex, "com2") ||
  488. X                           checkstring(nex, "COM2")) {
  489. X                    note("Opening a DOS device file name [178]");
  490. X                }
  491. X                break;
  492. X
  493. X        default:
  494. X        break;
  495. X        }
  496. X    } else {
  497. X    if (*filenamefilter && strcmp(filenamefilter, "0")) {
  498. X        ex = makeexpr_sizeof(copyexpr(nex), 0);
  499. X        nex = makeexpr_bicall_2(filenamefilter, tp_str255, nex, ex);
  500. X    } else
  501. X        nex = makeexpr_stringify(nex);
  502. X    }
  503. X    return nex;
  504. X}
  505. X
  506. X
  507. X
  508. XStatic Stmt *assignfilename(fex, nex)
  509. XExpr *fex, *nex;
  510. X{
  511. X    Meaning *mp;
  512. X
  513. X    mp = isfilevar(fex);
  514. X    if (mp && mp->namedfile) {
  515. X        freeexpr(fex);
  516. X        return makestmt_call(makeexpr_assign(makeexpr_name(format_s(name_FNVAR, mp->name),
  517. X                                                           tp_str255),
  518. X                                             nex));
  519. X    } else {
  520. X        if (mp)
  521. X            warning("Don't know how to ASSIGN to a non-explicit file variable [207]");
  522. X        else
  523. X            note("Encountered an ASSIGN statement [179]");
  524. X        return makestmt_call(makeexpr_bicall_2("assign", tp_void, fex, nex));
  525. X    }
  526. X}
  527. X
  528. X
  529. X
  530. XStatic Stmt *proc_assign()
  531. X{
  532. X    Expr *fex, *nex;
  533. X
  534. X    if (!skipopenparen())
  535. X    return NULL;
  536. X    fex = p_expr(tp_text);
  537. X    if (!skipcomma())
  538. X    return NULL;
  539. X    nex = checkfilename(p_expr(tp_str255));
  540. X    skipcloseparen();
  541. X    return assignfilename(fex, nex);
  542. X}
  543. X
  544. X
  545. X
  546. XStatic Stmt *handleopen(code)
  547. Xint code;
  548. X{
  549. X    Stmt *sp, *spassign;
  550. X    Expr *fex, *nex, *ex;
  551. X    Meaning *fmp;
  552. X    int storefilename, needcheckopen = 1;
  553. X    char modebuf[5], *cp;
  554. X
  555. X    if (!skipopenparen())
  556. X    return NULL;
  557. X    fex = p_expr(tp_text);
  558. X    fmp = isfilevar(fex);
  559. X    storefilename = (fmp && fmp->namedfile);
  560. X    spassign = NULL;
  561. X    if (curtok == TOK_COMMA) {
  562. X        gettok();
  563. X        ex = p_expr(tp_str255);
  564. X    } else
  565. X        ex = NULL;
  566. X    if (ex && (ex->val.type->kind == TK_STRING ||
  567. X           ex->val.type->kind == TK_ARRAY)) {
  568. X        nex = checkfilename(ex);
  569. X        if (storefilename) {
  570. X            spassign = assignfilename(copyexpr(fex), nex);
  571. X            nex = makeexpr_name(format_s(name_FNVAR, fmp->name), tp_str255);
  572. X        }
  573. X        if (curtok == TOK_COMMA) {
  574. X            gettok();
  575. X            ex = p_expr(tp_str255);
  576. X        } else
  577. X            ex = NULL;
  578. X    } else if (storefilename) {
  579. X        nex = makeexpr_name(format_s(name_FNVAR, fmp->name), tp_str255);
  580. X    } else {
  581. X    switch (code) {
  582. X        case 0:
  583. X            if (ex)
  584. X            note("Can't interpret name argument in RESET [180]");
  585. X        break;
  586. X          case 1:
  587. X            note("REWRITE does not specify a name [181]");
  588. X        break;
  589. X        case 2:
  590. X        note("OPEN does not specify a name [181]");
  591. X        break;
  592. X        case 3:
  593. X        note("APPEND does not specify a name [181]");
  594. X        break;
  595. X    }
  596. X    nex = NULL;
  597. X    }
  598. X    if (ex) {
  599. X        if (ord_type(ex->val.type)->kind == TK_INTEGER) {
  600. X        if (!checkconst(ex, 1))
  601. X        note("Ignoring block size in binary file [182]");
  602. X            freeexpr(ex);
  603. X        } else {
  604. X        if (ex->kind == EK_CONST && ex->val.type->kind == TK_STRING) {
  605. X        cp = getstring(ex);
  606. X        if (strcicmp(cp, "SHARED"))
  607. X            note(format_s("Ignoring option string \"%s\" in open [183]", cp));
  608. X        } else
  609. X        note("Ignoring option string in open [183]");
  610. X        }
  611. X    }
  612. X    switch (code) {
  613. X
  614. X        case 0:  /* reset */
  615. X            strcpy(modebuf, "r");
  616. X            break;
  617. X
  618. X        case 1:  /* rewrite */
  619. X            strcpy(modebuf, "w");
  620. X            break;
  621. X
  622. X        case 2:  /* open */
  623. X            strcpy(modebuf, openmode);
  624. X            break;
  625. X
  626. X        case 3:  /* append */
  627. X            strcpy(modebuf, "a");
  628. X            break;
  629. X
  630. X    }
  631. X    if (!*modebuf) {
  632. X        strcpy(modebuf, "r+");
  633. X    }
  634. X    if (readwriteopen == 2 ||
  635. X    (readwriteopen && fex->val.type != tp_text)) {
  636. X    if (!my_strchr(modebuf, '+'))
  637. X        strcat(modebuf, "+");
  638. X    }
  639. X    if (fex->val.type != tp_text && binarymode != 0) {
  640. X        if (binarymode == 1)
  641. X            strcat(modebuf, "b");
  642. X        else
  643. X            note("Opening a binary file [184]");
  644. X    }
  645. X    if (!nex && fmp &&
  646. X    !is_std_file(fex) &&
  647. X    (literalfilesflag == 1 ||
  648. X     strlist_cifind(literalfiles, fmp->name))) {
  649. X    nex = makeexpr_string(fmp->name);
  650. X    }
  651. X    if (!nex) {
  652. X    if (isvar(fex, mp_output)) {
  653. X        note("RESET/REWRITE ignored for file OUTPUT [319]");
  654. X        sp = NULL;
  655. X    } else {
  656. X        sp = makestmt_call(makeexpr_bicall_1("rewind", tp_void,
  657. X                         copyexpr(fex)));
  658. X        if (code == 0 || is_std_file(fex)) {
  659. X        sp = wrapopencheck(sp, copyexpr(fex));
  660. X        needcheckopen = 0;
  661. X        } else
  662. X        sp = makestmt_if(makeexpr_rel(EK_NE, copyexpr(fex),
  663. X                          makeexpr_nil()),
  664. X                 sp,
  665. X                 makestmt_assign(copyexpr(fex),
  666. X                         makeexpr_bicall_0("tmpfile",
  667. X                                   tp_text)));
  668. X    }
  669. X    } else if (!strcmp(freopenname, "fclose") ||
  670. X           !strcmp(freopenname, "fopen")) {
  671. X        sp = makestmt_assign(copyexpr(fex),
  672. X                             makeexpr_bicall_2("fopen", tp_text,
  673. X                                               copyexpr(nex),
  674. X                                               makeexpr_string(modebuf)));
  675. X        if (!strcmp(freopenname, "fclose")) {
  676. X            sp = makestmt_seq(makestmt_if(makeexpr_rel(EK_NE, copyexpr(fex), makeexpr_nil()),
  677. X                                          makestmt_call(makeexpr_bicall_1("fclose", tp_void,
  678. X                                                                          copyexpr(fex))),
  679. X                                          NULL),
  680. X                              sp);
  681. X        }
  682. X    } else {
  683. X        sp = makestmt_assign(copyexpr(fex),
  684. X                             makeexpr_bicall_3((*freopenname) ? freopenname : "freopen",
  685. X                                               tp_text,
  686. X                                               copyexpr(nex),
  687. X                                               makeexpr_string(modebuf),
  688. X                                               copyexpr(fex)));
  689. X        if (!*freopenname) {
  690. X            sp = makestmt_if(makeexpr_rel(EK_NE, copyexpr(fex), makeexpr_nil()),
  691. X                             sp,
  692. X                             makestmt_assign(copyexpr(fex),
  693. X                                             makeexpr_bicall_2("fopen", tp_text,
  694. X                                                               copyexpr(nex),
  695. X                                                               makeexpr_string(modebuf))));
  696. X        }
  697. X    }
  698. X    if (code == 2 && !*openmode && nex) {
  699. X        sp = makestmt_seq(sp, makestmt_if(makeexpr_rel(EK_EQ, copyexpr(fex), makeexpr_nil()),
  700. X                                          makestmt_assign(copyexpr(fex),
  701. X                                                          makeexpr_bicall_2("fopen", tp_text,
  702. X                                                                            copyexpr(nex),
  703. X                                                                            makeexpr_string("w+"))),
  704. X                                          NULL));
  705. X    }
  706. X    if (nex)
  707. X    freeexpr(nex);
  708. X    if (FCheck(checkfileopen) && needcheckopen) {
  709. X        sp = makestmt_seq(sp, makestmt_call(makeexpr_bicall_2("~SETIO", tp_void,
  710. X                                                              makeexpr_rel(EK_NE, copyexpr(fex), makeexpr_nil()),
  711. X                                  makeexpr_name(filenotfoundname, tp_int))));
  712. X    }
  713. X    sp = makestmt_seq(spassign, sp);
  714. X    cp = (code == 0) ? resetbufname : setupbufname;
  715. X    if (*cp && fmp)   /* (may be eaten later, if buffering isn't needed) */
  716. X    sp = makestmt_seq(sp,
  717. X             makestmt_call(
  718. X                     makeexpr_bicall_2(cp, tp_void, fex,
  719. X             makeexpr_type(fex->val.type->basetype->basetype))));
  720. X    else
  721. X    freeexpr(fex);
  722. X    skipcloseparen();
  723. X    return sp;
  724. X}
  725. X
  726. X
  727. X
  728. XStatic Stmt *proc_append()
  729. X{
  730. X    return handleopen(3);
  731. X}
  732. X
  733. X
  734. X
  735. XStatic Expr *func_arccos(ex)
  736. XExpr *ex;
  737. X{
  738. X    return makeexpr_bicall_1("acos", tp_longreal, grabarg(ex, 0));
  739. X}
  740. X
  741. X
  742. XStatic Expr *func_arcsin(ex)
  743. XExpr *ex;
  744. X{
  745. X    return makeexpr_bicall_1("asin", tp_longreal, grabarg(ex, 0));
  746. X}
  747. X
  748. X
  749. XStatic Expr *func_arctan(ex)
  750. XExpr *ex;
  751. X{
  752. X    ex = grabarg(ex, 0);
  753. X    if (atan2flag && ex->kind == EK_DIVIDE)
  754. X        return makeexpr_bicall_2("atan2", tp_longreal, 
  755. X                                 ex->args[0], ex->args[1]);
  756. X    return makeexpr_bicall_1("atan", tp_longreal, ex);
  757. X}
  758. X
  759. X
  760. XStatic Expr *func_arctanh(ex)
  761. XExpr *ex;
  762. X{
  763. X    return makeexpr_bicall_1("atanh", tp_longreal, grabarg(ex, 0));
  764. X}
  765. X
  766. X
  767. X
  768. XStatic Stmt *proc_argv()
  769. X{
  770. X    Expr *ex, *aex, *lex;
  771. X
  772. X    if (!skipopenparen())
  773. X    return NULL;
  774. X    ex = p_expr(tp_integer);
  775. X    if (skipcomma()) {
  776. X    aex = p_expr(tp_str255);
  777. X    } else
  778. X    return NULL;
  779. X    skipcloseparen();
  780. X    lex = makeexpr_sizeof(copyexpr(aex), 0);
  781. X    aex = makeexpr_addrstr(aex);
  782. X    return makestmt_call(makeexpr_bicall_3("P_sun_argv", tp_void,
  783. X                       aex, lex, makeexpr_arglong(ex, 0)));
  784. X}
  785. X
  786. X
  787. XStatic Expr *func_asr()
  788. X{
  789. X    Expr *ex;
  790. X
  791. X    if (!skipopenparen())
  792. X    return NULL;
  793. X    ex = p_expr(tp_integer);
  794. X    if (skipcomma()) {
  795. X        if (signedshift == 0 || signedshift == 2) {
  796. X            ex = makeexpr_bicall_2("P_asr", ex->val.type, ex,
  797. X                   p_expr(tp_unsigned));
  798. X    } else {
  799. X        ex = force_signed(ex);
  800. X        ex = makeexpr_bin(EK_RSH, ex->val.type, ex, p_expr(tp_unsigned));
  801. X        if (signedshift != 1)
  802. X        note("Assuming >> is an arithmetic shift [320]");
  803. X    }
  804. X    skipcloseparen();
  805. X    }
  806. X    return ex;
  807. X}
  808. X
  809. X
  810. XStatic Expr *func_lsl()
  811. X{
  812. X    Expr *ex;
  813. X
  814. X    if (!skipopenparen())
  815. X    return NULL;
  816. X    ex = p_expr(tp_integer);
  817. X    if (skipcomma()) {
  818. X    ex = makeexpr_bin(EK_LSH, ex->val.type, ex, p_expr(tp_unsigned));
  819. X    skipcloseparen();
  820. X    }
  821. X    return ex;
  822. X}
  823. X
  824. X
  825. XStatic Expr *func_lsr()
  826. X{
  827. X    Expr *ex;
  828. X
  829. X    if (!skipopenparen())
  830. X    return NULL;
  831. X    ex = p_expr(tp_integer);
  832. X    if (skipcomma()) {
  833. X    ex = force_unsigned(ex);
  834. X    ex = makeexpr_bin(EK_RSH, ex->val.type, ex, p_expr(tp_unsigned));
  835. X    skipcloseparen();
  836. X    }
  837. X    return ex;
  838. X}
  839. X
  840. X
  841. X
  842. XStatic Expr *func_bin()
  843. X{
  844. X    note("Using %b for binary printf format [185]");
  845. X    return handle_vax_hex(NULL, "b", 1);
  846. X}
  847. X
  848. X
  849. X
  850. XStatic Expr *func_binary(ex)
  851. XExpr *ex;
  852. X{
  853. X    char *cp;
  854. X
  855. X    ex = grabarg(ex, 0);
  856. X    if (ex->kind == EK_CONST) {
  857. X        cp = getstring(ex);
  858. X        ex = makeexpr_long(my_strtol(cp, NULL, 2));
  859. X        insertarg(&ex, 0, makeexpr_name("%#lx", tp_integer));
  860. X        return ex;
  861. X    } else {
  862. X        return makeexpr_bicall_3("strtol", tp_integer, 
  863. X                                 ex, makeexpr_nil(), makeexpr_long(2));
  864. X    }
  865. X}
  866. X
  867. X
  868. X
  869. XStatic Expr *handle_bitsize(next)
  870. Xint next;
  871. X{
  872. X    Expr *ex;
  873. X    Type *type;
  874. X    int lpar;
  875. X    long psize;
  876. X
  877. X    lpar = (curtok == TOK_LPAR);
  878. X    if (lpar)
  879. X    gettok();
  880. X    if (curtok == TOK_IDENT && curtokmeaning &&
  881. X    curtokmeaning->kind == MK_TYPE) {
  882. X        ex = makeexpr_type(curtokmeaning->type);
  883. X        gettok();
  884. X    } else
  885. X        ex = p_expr(NULL);
  886. X    type = ex->val.type;
  887. X    if (lpar)
  888. X    skipcloseparen();
  889. X    psize = 0;
  890. X    packedsize(NULL, &type, &psize, 0);
  891. X    if (psize > 0 && psize < 32 && next) {
  892. X    if (psize > 16)
  893. X        psize = 32;
  894. X    else if (psize > 8)
  895. X        psize = 16;
  896. X    else if (psize > 4)
  897. X        psize = 8;
  898. X    else if (psize > 2)
  899. X        psize = 4;
  900. X    else if (psize > 1)
  901. X        psize = 2;
  902. X    else
  903. X        psize = 1;
  904. X    }
  905. X    if (psize)
  906. X    return makeexpr_long(psize);
  907. X    else
  908. X    return makeexpr_times(makeexpr_sizeof(ex, 0),
  909. X                  makeexpr_long(sizeof_char ? sizeof_char : 8));
  910. X}
  911. X
  912. X
  913. XStatic Expr *func_bitsize()
  914. X{
  915. X    return handle_bitsize(0);
  916. X}
  917. X
  918. X
  919. XStatic Expr *func_bitnext()
  920. X{
  921. X    return handle_bitsize(1);
  922. X}
  923. X
  924. X
  925. X
  926. XStatic Expr *func_blockread()
  927. X{
  928. X    Expr *ex, *ex2, *vex, *sex, *fex;
  929. X    Type *type;
  930. X
  931. X    if (!skipopenparen())
  932. X    return NULL;
  933. X    fex = p_expr(tp_text);
  934. X    if (!skipcomma())
  935. X    return NULL;
  936. X    vex = p_expr(NULL);
  937. X    if (!skipcomma())
  938. X    return NULL;
  939. X    ex2 = p_expr(tp_integer);
  940. X    if (curtok == TOK_COMMA) {
  941. X        gettok();
  942. X        sex = p_expr(tp_integer);
  943. X    sex = doseek(copyexpr(fex),
  944. X             makeexpr_times(sex, makeexpr_long(512)))->exp1;
  945. X    } else
  946. X        sex = NULL;
  947. X    skipcloseparen();
  948. X    type = vex->val.type;
  949. X    ex = makeexpr_bicall_4("fread", tp_integer,
  950. X               makeexpr_addr(vex),
  951. X               makeexpr_long(512),
  952. X               convert_size(type, ex2, "BLOCKREAD"),
  953. X               copyexpr(fex));
  954. X    return makeexpr_comma(sex, ex);
  955. X}
  956. X
  957. X
  958. X
  959. XStatic Expr *func_blockwrite()
  960. X{
  961. X    Expr *ex, *ex2, *vex, *sex, *fex;
  962. X    Type *type;
  963. X
  964. X    if (!skipopenparen())
  965. X    return NULL;
  966. X    fex = p_expr(tp_text);
  967. X    if (!skipcomma())
  968. X    return NULL;
  969. X    vex = p_expr(NULL);
  970. X    if (!skipcomma())
  971. X    return NULL;
  972. X    ex2 = p_expr(tp_integer);
  973. X    if (curtok == TOK_COMMA) {
  974. X        gettok();
  975. X        sex = p_expr(tp_integer);
  976. X    sex = doseek(copyexpr(fex),
  977. X             makeexpr_times(sex, makeexpr_long(512)))->exp1;
  978. X    } else
  979. X        sex = NULL;
  980. X    skipcloseparen();
  981. X    type = vex->val.type;
  982. X    ex = makeexpr_bicall_4("fwrite", tp_integer,
  983. X               makeexpr_addr(vex),
  984. X               makeexpr_long(512),
  985. X               convert_size(type, ex2, "BLOCKWRITE"),
  986. X               copyexpr(fex));
  987. X    return makeexpr_comma(sex, ex);
  988. X}
  989. X
  990. X
  991. X
  992. X
  993. XStatic Stmt *proc_blockread()
  994. X{
  995. X    Expr *ex, *ex2, *vex, *rex, *fex;
  996. X    Type *type;
  997. X
  998. X    if (!skipopenparen())
  999. X    return NULL;
  1000. X    fex = p_expr(tp_text);
  1001. X    if (!skipcomma())
  1002. X    return NULL;
  1003. X    vex = p_expr(NULL);
  1004. X    if (!skipcomma())
  1005. X    return NULL;
  1006. X    ex2 = p_expr(tp_integer);
  1007. X    if (curtok == TOK_COMMA) {
  1008. X        gettok();
  1009. X        rex = p_expr(tp_integer);
  1010. X    } else
  1011. X        rex = NULL;
  1012. X    skipcloseparen();
  1013. X    type = vex->val.type;
  1014. X    if (rex) {
  1015. X        ex = makeexpr_bicall_4("fread", tp_integer,
  1016. X                               makeexpr_addr(vex),
  1017. X                               makeexpr_long(1),
  1018. X                               convert_size(type, ex2, "BLOCKREAD"),
  1019. X                               copyexpr(fex));
  1020. X        ex = makeexpr_assign(rex, ex);
  1021. X        if (!iocheck_flag)
  1022. X            ex = makeexpr_comma(ex,
  1023. X                                makeexpr_assign(makeexpr_var(mp_ioresult),
  1024. X                                                makeexpr_long(0)));
  1025. X    } else {
  1026. X        ex = makeexpr_bicall_4("fread", tp_integer,
  1027. X                               makeexpr_addr(vex),
  1028. X                               convert_size(type, ex2, "BLOCKREAD"),
  1029. X                               makeexpr_long(1),
  1030. X                               copyexpr(fex));
  1031. X        if (checkeof(fex)) {
  1032. X            ex = makeexpr_bicall_2(name_SETIO, tp_void,
  1033. X                                   makeexpr_rel(EK_EQ, ex, makeexpr_long(1)),
  1034. X                   makeexpr_name(endoffilename, tp_int));
  1035. X        }
  1036. X    }
  1037. X    return wrapopencheck(makestmt_call(ex), fex);
  1038. X}
  1039. X
  1040. X
  1041. X
  1042. X
  1043. XStatic Stmt *proc_blockwrite()
  1044. X{
  1045. X    Expr *ex, *ex2, *vex, *rex, *fex;
  1046. X    Type *type;
  1047. X
  1048. X    if (!skipopenparen())
  1049. X    return NULL;
  1050. X    fex = p_expr(tp_text);
  1051. X    if (!skipcomma())
  1052. X    return NULL;
  1053. X    vex = p_expr(NULL);
  1054. X    if (!skipcomma())
  1055. X    return NULL;
  1056. X    ex2 = p_expr(tp_integer);
  1057. X    if (curtok == TOK_COMMA) {
  1058. X        gettok();
  1059. X        rex = p_expr(tp_integer);
  1060. X    } else
  1061. X        rex = NULL;
  1062. X    skipcloseparen();
  1063. X    type = vex->val.type;
  1064. X    if (rex) {
  1065. X        ex = makeexpr_bicall_4("fwrite", tp_integer,
  1066. X                               makeexpr_addr(vex),
  1067. X                               makeexpr_long(1),
  1068. X                               convert_size(type, ex2, "BLOCKWRITE"),
  1069. X                               copyexpr(fex));
  1070. X        ex = makeexpr_assign(rex, ex);
  1071. X        if (!iocheck_flag)
  1072. X            ex = makeexpr_comma(ex,
  1073. X                                makeexpr_assign(makeexpr_var(mp_ioresult),
  1074. X                                                makeexpr_long(0)));
  1075. X    } else {
  1076. X        ex = makeexpr_bicall_4("fwrite", tp_integer,
  1077. X                               makeexpr_addr(vex),
  1078. X                               convert_size(type, ex2, "BLOCKWRITE"),
  1079. X                               makeexpr_long(1),
  1080. X                               copyexpr(fex));
  1081. X        if (FCheck(checkfilewrite)) {
  1082. X            ex = makeexpr_bicall_2(name_SETIO, tp_void,
  1083. X                                   makeexpr_rel(EK_EQ, ex, makeexpr_long(1)),
  1084. X                   makeexpr_name(filewriteerrorname, tp_int));
  1085. X        }
  1086. X    }
  1087. X    return wrapopencheck(makestmt_call(ex), fex);
  1088. X}
  1089. X
  1090. X
  1091. X
  1092. XStatic Stmt *proc_bclr()
  1093. X{
  1094. X    Expr *ex, *ex2;
  1095. X
  1096. X    if (!skipopenparen())
  1097. X    return NULL;
  1098. X    ex = p_expr(tp_integer);
  1099. X    if (!skipcomma())
  1100. X    return NULL;
  1101. X    ex2 = p_expr(tp_integer);
  1102. X    skipcloseparen();
  1103. X    return makestmt_assign(ex,
  1104. X               makeexpr_bin(EK_BAND, ex->val.type,
  1105. X                    copyexpr(ex),
  1106. X                    makeexpr_un(EK_BNOT, ex->val.type,
  1107. X                    makeexpr_bin(EK_LSH, tp_integer,
  1108. X                             makeexpr_arglong(
  1109. X                                 makeexpr_long(1), 1),
  1110. X                             ex2))));
  1111. X}
  1112. X
  1113. X
  1114. X
  1115. XStatic Stmt *proc_bset()
  1116. X{
  1117. X    Expr *ex, *ex2;
  1118. X
  1119. X    if (!skipopenparen())
  1120. X    return NULL;
  1121. X    ex = p_expr(tp_integer);
  1122. X    if (!skipcomma())
  1123. X    return NULL;
  1124. X    ex2 = p_expr(tp_integer);
  1125. X    skipcloseparen();
  1126. X    return makestmt_assign(ex,
  1127. X               makeexpr_bin(EK_BOR, ex->val.type,
  1128. X                    copyexpr(ex),
  1129. X                    makeexpr_bin(EK_LSH, tp_integer,
  1130. X                             makeexpr_arglong(
  1131. X                                 makeexpr_long(1), 1),
  1132. X                             ex2)));
  1133. X}
  1134. X
  1135. X
  1136. X
  1137. XStatic Expr *func_bsl()
  1138. X{
  1139. X    Expr *ex, *ex2;
  1140. X
  1141. X    if (!skipopenparen())
  1142. X    return NULL;
  1143. X    ex = p_expr(tp_integer);
  1144. X    if (!skipcomma())
  1145. X    return NULL;
  1146. X    ex2 = p_expr(tp_integer);
  1147. X    skipcloseparen();
  1148. X    return makeexpr_bin(EK_LSH, tp_integer, ex, ex2);
  1149. X}
  1150. X
  1151. X
  1152. X
  1153. XStatic Expr *func_bsr()
  1154. X{
  1155. X    Expr *ex, *ex2;
  1156. X
  1157. X    if (!skipopenparen())
  1158. X    return NULL;
  1159. X    ex = p_expr(tp_integer);
  1160. X    if (!skipcomma())
  1161. X    return NULL;
  1162. X    ex2 = p_expr(tp_integer);
  1163. X    skipcloseparen();
  1164. X    return makeexpr_bin(EK_RSH, tp_integer, force_unsigned(ex), ex2);
  1165. X}
  1166. X
  1167. X
  1168. X
  1169. XStatic Expr *func_btst()
  1170. X{
  1171. X    Expr *ex, *ex2;
  1172. X
  1173. X    if (!skipopenparen())
  1174. X    return NULL;
  1175. X    ex = p_expr(tp_integer);
  1176. X    if (!skipcomma())
  1177. X    return NULL;
  1178. X    ex2 = p_expr(tp_integer);
  1179. X    skipcloseparen();
  1180. X    return makeexpr_rel(EK_NE,
  1181. X            makeexpr_bin(EK_BAND, tp_integer,
  1182. X                     ex,
  1183. X                     makeexpr_bin(EK_LSH, tp_integer,
  1184. X                          makeexpr_arglong(
  1185. X                              makeexpr_long(1), 1),
  1186. X                          ex2)),
  1187. X            makeexpr_long(0));
  1188. X}
  1189. X
  1190. X
  1191. X
  1192. XStatic Expr *func_byteread()
  1193. X{
  1194. X    Expr *ex, *ex2, *vex, *sex, *fex;
  1195. X    Type *type;
  1196. X
  1197. X    if (!skipopenparen())
  1198. X    return NULL;
  1199. X    fex = p_expr(tp_text);
  1200. X    if (!skipcomma())
  1201. X    return NULL;
  1202. X    vex = p_expr(NULL);
  1203. X    if (!skipcomma())
  1204. X    return NULL;
  1205. X    ex2 = p_expr(tp_integer);
  1206. X    if (curtok == TOK_COMMA) {
  1207. X        gettok();
  1208. X        sex = p_expr(tp_integer);
  1209. X    sex = doseek(copyexpr(fex), sex)->exp1;
  1210. X    } else
  1211. X        sex = NULL;
  1212. X    skipcloseparen();
  1213. X    type = vex->val.type;
  1214. X    ex = makeexpr_bicall_4("fread", tp_integer,
  1215. X               makeexpr_addr(vex),
  1216. X               makeexpr_long(1),
  1217. X               convert_size(type, ex2, "BYTEREAD"),
  1218. X               copyexpr(fex));
  1219. X    return makeexpr_comma(sex, ex);
  1220. X}
  1221. X
  1222. X
  1223. X
  1224. XStatic Expr *func_bytewrite()
  1225. X{
  1226. X    Expr *ex, *ex2, *vex, *sex, *fex;
  1227. X    Type *type;
  1228. X
  1229. X    if (!skipopenparen())
  1230. X    return NULL;
  1231. X    fex = p_expr(tp_text);
  1232. X    if (!skipcomma())
  1233. X    return NULL;
  1234. X    vex = p_expr(NULL);
  1235. X    if (!skipcomma())
  1236. X    return NULL;
  1237. X    ex2 = p_expr(tp_integer);
  1238. X    if (curtok == TOK_COMMA) {
  1239. X        gettok();
  1240. X        sex = p_expr(tp_integer);
  1241. X    sex = doseek(copyexpr(fex), sex)->exp1;
  1242. X    } else
  1243. X        sex = NULL;
  1244. X    skipcloseparen();
  1245. X    type = vex->val.type;
  1246. X    ex = makeexpr_bicall_4("fwrite", tp_integer,
  1247. X               makeexpr_addr(vex),
  1248. X               makeexpr_long(1),
  1249. X               convert_size(type, ex2, "BYTEWRITE"),
  1250. X               copyexpr(fex));
  1251. X    return makeexpr_comma(sex, ex);
  1252. X}
  1253. X
  1254. X
  1255. X
  1256. XStatic Expr *func_byte_offset()
  1257. X{
  1258. X    Type *tp;
  1259. X    Meaning *mp;
  1260. X    Expr *ex;
  1261. X
  1262. X    if (!skipopenparen())
  1263. X    return NULL;
  1264. X    tp = p_type(NULL);
  1265. X    if (!skipcomma())
  1266. X    return NULL;
  1267. X    if (!wexpecttok(TOK_IDENT))
  1268. X    return NULL;
  1269. X    mp = curtoksym->fbase;
  1270. X    while (mp && mp->rectype != tp)
  1271. X    mp = mp->snext;
  1272. X    if (!mp)
  1273. X    ex = makeexpr_name(curtokcase, tp_integer);
  1274. X    else
  1275. X    ex = makeexpr_name(mp->name, tp_integer);
  1276. X    gettok();
  1277. X    skipcloseparen();
  1278. X    return makeexpr_bicall_2("OFFSETOF", (size_t_long) ? tp_integer : tp_int,
  1279. X                 makeexpr_type(tp), ex);
  1280. X}
  1281. X
  1282. X
  1283. X
  1284. XStatic Stmt *proc_call()
  1285. X{
  1286. X    Expr *ex, *ex2, *ex3;
  1287. X    Type *type, *tp;
  1288. X    Meaning *mp;
  1289. X
  1290. X    if (!skipopenparen())
  1291. X    return NULL;
  1292. X    ex2 = p_expr(tp_proc);
  1293. X    type = ex2->val.type;
  1294. X    if (type->kind != TK_PROCPTR && type->kind != TK_CPROCPTR) {
  1295. X        warning("CALL requires a procedure variable [208]");
  1296. X    type = tp_proc;
  1297. X    }
  1298. X    ex = makeexpr(EK_SPCALL, 1);
  1299. X    ex->val.type = tp_void;
  1300. X    ex->args[0] = copyexpr(ex2);
  1301. X    if (type->escale != 0)
  1302. X    ex->args[0] = makeexpr_cast(makeexpr_dotq(ex2, "proc", tp_anyptr),
  1303. X                    makepointertype(type->basetype));
  1304. X    mp = type->basetype->fbase;
  1305. X    if (mp) {
  1306. X        if (wneedtok(TOK_COMMA))
  1307. X        ex = p_funcarglist(ex, mp, 0, 0);
  1308. X    }
  1309. X    skipcloseparen();
  1310. X    if (type->escale != 1 || hasstaticlinks == 2) {
  1311. X    freeexpr(ex2);
  1312. X    return makestmt_call(ex);
  1313. X    }
  1314. X    ex2 = makeexpr_dotq(ex2, "link", tp_anyptr),
  1315. X    ex3 = copyexpr(ex);
  1316. X    insertarg(&ex3, ex3->nargs, copyexpr(ex2));
  1317. X    tp = maketype(TK_FUNCTION);
  1318. X    tp->basetype = type->basetype->basetype;
  1319. X    tp->fbase = type->basetype->fbase;
  1320. X    tp->issigned = 1;
  1321. X    ex3->args[0]->val.type = makepointertype(tp);
  1322. X    return makestmt_if(makeexpr_rel(EK_NE, ex2, makeexpr_nil()),
  1323. X                       makestmt_call(ex3),
  1324. X                       makestmt_call(ex));
  1325. X}
  1326. X
  1327. X
  1328. X
  1329. XStatic Expr *func_chr()
  1330. X{
  1331. X    Expr *ex;
  1332. X
  1333. X    ex = p_expr(tp_integer);
  1334. X    if ((exprlongness(ex) < 0 || ex->kind == EK_CAST) && ex->kind != EK_ACTCAST)
  1335. X        ex->val.type = tp_char;
  1336. X    else
  1337. X        ex = makeexpr_cast(ex, tp_char);
  1338. X    return ex;
  1339. X}
  1340. X
  1341. X
  1342. X
  1343. XStatic Stmt *proc_close()
  1344. X{
  1345. X    Stmt *sp;
  1346. X    Expr *fex, *ex;
  1347. X    char *opt;
  1348. X
  1349. X    if (!skipopenparen())
  1350. X    return NULL;
  1351. X    fex = p_expr(tp_text);
  1352. X    sp = makestmt_if(makeexpr_rel(EK_NE, copyexpr(fex), makeexpr_nil()),
  1353. X                     makestmt_call(makeexpr_bicall_1("fclose", tp_void,
  1354. X                                                     copyexpr(fex))),
  1355. X                     (FCheck(checkfileisopen))
  1356. X                 ? makestmt_call(
  1357. X                 makeexpr_bicall_1(name_ESCIO,
  1358. X                           tp_integer,
  1359. X                           makeexpr_name(filenotopenname,
  1360. X                                 tp_int)))
  1361. X                         : NULL);
  1362. X    if (curtok == TOK_COMMA) {
  1363. X        gettok();
  1364. X    opt = "";
  1365. X    if (curtok == TOK_IDENT &&
  1366. X        (!strcicmp(curtokbuf, "LOCK") ||
  1367. X         !strcicmp(curtokbuf, "PURGE") ||
  1368. X         !strcicmp(curtokbuf, "NORMAL") ||
  1369. X         !strcicmp(curtokbuf, "CRUNCH"))) {
  1370. X        opt = stralloc(curtokbuf);
  1371. X        gettok();
  1372. X    } else {
  1373. X        ex = p_expr(tp_str255);
  1374. X        if (ex->kind == EK_CONST && ex->val.type->kind == TK_STRING)
  1375. X        opt = ex->val.s;
  1376. X    }
  1377. X    if (!strcicmp(opt, "PURGE")) {
  1378. X        note("File is being closed with PURGE option [186]");
  1379. X        }
  1380. X    }
  1381. X    sp = makestmt_seq(sp, makestmt_assign(fex, makeexpr_nil()));
  1382. X    skipcloseparen();
  1383. X    return sp;
  1384. X}
  1385. X
  1386. X
  1387. X
  1388. XStatic Expr *func_concat()
  1389. X{
  1390. X    Expr *ex;
  1391. X
  1392. X    if (!skipopenparen())
  1393. X    return makeexpr_string("oops");
  1394. X    ex = p_expr(tp_str255);
  1395. X    while (curtok == TOK_COMMA) {
  1396. X        gettok();
  1397. X        ex = makeexpr_concat(ex, p_expr(tp_str255), 0);
  1398. X    }
  1399. X    skipcloseparen();
  1400. X    return ex;
  1401. X}
  1402. X
  1403. X
  1404. X
  1405. XStatic Expr *func_copy(ex)
  1406. XExpr *ex;
  1407. X{
  1408. X    if (isliteralconst(ex->args[3], NULL) == 2 &&
  1409. X        ex->args[3]->val.i >= stringceiling) {
  1410. X        return makeexpr_bicall_3("sprintf", ex->val.type,
  1411. X                                 ex->args[0],
  1412. X                                 makeexpr_string("%s"),
  1413. X                                 bumpstring(ex->args[1], 
  1414. X                                            makeexpr_unlongcast(ex->args[2]), 1));
  1415. X    }
  1416. X    if (checkconst(ex->args[2], 1)) {
  1417. X        return makeexpr_addr(makeexpr_substring(ex->args[0], ex->args[1], 
  1418. X                                                ex->args[2], ex->args[3]));
  1419. X    }
  1420. X    return makeexpr_bicall_4(strsubname, ex->val.type,
  1421. X                             ex->args[0],
  1422. X                             ex->args[1],
  1423. X                             makeexpr_arglong(ex->args[2], 0),
  1424. X                             makeexpr_arglong(ex->args[3], 0));
  1425. X}
  1426. X
  1427. X
  1428. X
  1429. XStatic Expr *func_cos(ex)
  1430. XExpr *ex;
  1431. X{
  1432. X    return makeexpr_bicall_1("cos", tp_longreal, grabarg(ex, 0));
  1433. X}
  1434. X
  1435. X
  1436. XStatic Expr *func_cosh(ex)
  1437. XExpr *ex;
  1438. X{
  1439. X    return makeexpr_bicall_1("cosh", tp_longreal, grabarg(ex, 0));
  1440. X}
  1441. X
  1442. X
  1443. X
  1444. XStatic Stmt *proc_cycle()
  1445. X{
  1446. X    return makestmt(SK_CONTINUE);
  1447. X}
  1448. X
  1449. X
  1450. X
  1451. XStatic Stmt *proc_dec()
  1452. X{
  1453. X    Expr *vex, *ex;
  1454. X
  1455. X    if (!skipopenparen())
  1456. X    return NULL;
  1457. X    vex = p_expr(NULL);
  1458. X    if (curtok == TOK_COMMA) {
  1459. X        gettok();
  1460. X        ex = p_expr(tp_integer);
  1461. X    } else
  1462. X        ex = makeexpr_long(1);
  1463. X    skipcloseparen();
  1464. X    return makestmt_assign(vex, makeexpr_minus(copyexpr(vex), ex));
  1465. X}
  1466. X
  1467. X
  1468. X
  1469. XStatic Expr *func_dec()
  1470. X{
  1471. X    return handle_vax_hex(NULL, "d", 0);
  1472. X}
  1473. X
  1474. X
  1475. X
  1476. XStatic Stmt *proc_delete(ex)
  1477. XExpr *ex;
  1478. X{
  1479. X    if (ex->nargs == 1)   /* Kludge for Oregon Software Pascal's delete(f) */
  1480. X    return makestmt_call(makeexpr_bicall_1(strdeletename, tp_void, ex->args[0]));
  1481. X    return makestmt_call(makeexpr_bicall_3(strdeletename, tp_void,
  1482. X                                           ex->args[0], 
  1483. X                                           makeexpr_arglong(ex->args[1], 0),
  1484. X                                           makeexpr_arglong(ex->args[2], 0)));
  1485. X}
  1486. X
  1487. X
  1488. X
  1489. Xvoid parse_special_variant(tp, buf)
  1490. XType *tp;
  1491. Xchar *buf;
  1492. X{
  1493. X    char *cp;
  1494. X    Expr *ex;
  1495. X
  1496. X    if (!tp)
  1497. X    intwarning("parse_special_variant", "tp == NULL");
  1498. X    if (!tp || tp->meaning == NULL) {
  1499. X    *buf = 0;
  1500. X    if (curtok == TOK_COMMA) {
  1501. X        skiptotoken(TOK_RPAR);
  1502. X    }
  1503. X    return;
  1504. X    }
  1505. X    strcpy(buf, tp->meaning->name);
  1506. X    while (curtok == TOK_COMMA) {
  1507. X    gettok();
  1508. X    cp = buf + strlen(buf);
  1509. X    *cp++ = '.';
  1510. X    if (curtok == TOK_MINUS) {
  1511. X        *cp++ = '-';
  1512. X        gettok();
  1513. X    }
  1514. X    if (curtok == TOK_INTLIT ||
  1515. X        curtok == TOK_HEXLIT ||
  1516. X        curtok == TOK_OCTLIT) {
  1517. X        sprintf(cp, "%ld", curtokint);
  1518. X        gettok();
  1519. X    } else if (curtok == TOK_HAT || curtok == TOK_STRLIT) {
  1520. X        ex = makeexpr_charcast(accumulate_strlit());
  1521. X        if (ex->kind == EK_CONST) {
  1522. X        if (ex->val.i <= 32 || ex->val.i > 126 ||
  1523. X            ex->val.i == '\'' || ex->val.i == '\\' ||
  1524. X            ex->val.i == '=' || ex->val.i == '}')
  1525. X            sprintf(cp, "%ld", ex->val.i);
  1526. X        else
  1527. X            strcpy(cp, makeCchar(ex->val.i));
  1528. X        } else {
  1529. X        *buf = 0;
  1530. X        *cp = 0;
  1531. X        }
  1532. X        freeexpr(ex);
  1533. X    } else {
  1534. X        if (!wexpecttok(TOK_IDENT)) {
  1535. X        skiptotoken(TOK_RPAR);
  1536. X        return;
  1537. X        }
  1538. X        if (curtokmeaning)
  1539. X        strcpy(cp, curtokmeaning->name);
  1540. X        else
  1541. X        strcpy(cp, curtokbuf);
  1542. X        gettok();
  1543. X    }
  1544. X    }
  1545. X}
  1546. X
  1547. X
  1548. Xchar *find_special_variant(buf, spname, splist, need)
  1549. Xchar *buf, *spname;
  1550. XStrlist *splist;
  1551. Xint need;
  1552. X{
  1553. X    Strlist *best = NULL;
  1554. X    int len, bestlen = -1;
  1555. X    char *cp, *cp2;
  1556. X
  1557. X    if (!*buf)
  1558. X    return NULL;
  1559. X    while (splist) {
  1560. X    cp = splist->s;
  1561. X    cp2 = buf;
  1562. X    while (*cp && toupper(*cp) == toupper(*cp2))
  1563. X        cp++, cp2++;
  1564. X    len = cp2 - buf;
  1565. X    if (!*cp && (!*cp2 || *cp2 == '.') && len > bestlen) {
  1566. X        best = splist;
  1567. X        bestlen = len;
  1568. X    }
  1569. X    splist = splist->next;
  1570. X    }
  1571. X    if (bestlen != strlen(buf) && my_strchr(buf, '.')) {
  1572. X    if ((need & 1) || bestlen >= 0) {
  1573. X        if (need & 2)
  1574. X        return NULL;
  1575. X        if (spname)
  1576. X        note(format_ss("No %s form known for %s [187]",
  1577. X                   spname, strupper(buf)));
  1578. X    }
  1579. X    }
  1580. X    if (bestlen >= 0)
  1581. X    return (char *)best->value;
  1582. X    else
  1583. X    return NULL;
  1584. X}
  1585. X
  1586. X
  1587. X
  1588. XStatic char *choose_free_func(ex)
  1589. XExpr *ex;
  1590. X{
  1591. X    if (!*freename) {
  1592. X    if (!*freervaluename)
  1593. X        return "free";
  1594. X    else
  1595. X        return freervaluename;
  1596. X    }
  1597. X    if (!*freervaluename)
  1598. X    return freervaluename;
  1599. X    if (expr_is_lvalue(ex))
  1600. X    return freename;
  1601. X    else
  1602. X    return freervaluename;
  1603. X}
  1604. X
  1605. X
  1606. XStatic Stmt *proc_dispose()
  1607. X{
  1608. X    Expr *ex;
  1609. X    Type *type;
  1610. X    char *name, vbuf[1000];
  1611. X
  1612. X    if (!skipopenparen())
  1613. X    return NULL;
  1614. X    ex = p_expr(tp_anyptr);
  1615. X    type = ex->val.type->basetype;
  1616. X    parse_special_variant(type, vbuf);
  1617. X    skipcloseparen();
  1618. X    name = find_special_variant(vbuf, "SpecialFree", specialfrees, 0);
  1619. X    if (!name)
  1620. X    name = choose_free_func(ex);
  1621. X    return makestmt_call(makeexpr_bicall_1(name, tp_void, ex));
  1622. X}
  1623. X
  1624. X
  1625. X
  1626. XStatic Expr *func_exp(ex)
  1627. XExpr *ex;
  1628. X{
  1629. X    return makeexpr_bicall_1("exp", tp_longreal, grabarg(ex, 0));
  1630. X}
  1631. X
  1632. X
  1633. X
  1634. XStatic Expr *func_expo(ex)
  1635. XExpr *ex;
  1636. X{
  1637. X    Meaning *tvar;
  1638. X
  1639. X    tvar = makestmttempvar(tp_int, name_TEMP);
  1640. X    return makeexpr_comma(makeexpr_bicall_2("frexp", tp_longreal,
  1641. X                        grabarg(ex, 0),
  1642. X                        makeexpr_addr(makeexpr_var(tvar))),
  1643. X              makeexpr_var(tvar));
  1644. X}
  1645. X
  1646. X
  1647. X
  1648. Xint is_std_file(ex)
  1649. XExpr *ex;
  1650. X{
  1651. X    return isvar(ex, mp_input) || isvar(ex, mp_output) ||
  1652. X           isvar(ex, mp_stderr);
  1653. X}
  1654. X
  1655. X
  1656. X
  1657. XStatic Expr *iofunc(ex, code)
  1658. XExpr *ex;
  1659. Xint code;
  1660. X{
  1661. X    Expr *ex2 = NULL, *ex3 = NULL;
  1662. X    Meaning *tvar = NULL;
  1663. X
  1664. X    if (FCheck(checkfileisopen) && !is_std_file(ex)) {
  1665. X        if (exprspeed(ex) < 5 && nosideeffects(ex, 0)) {
  1666. X            ex2 = copyexpr(ex);
  1667. X        } else {
  1668. X            ex3 = ex;
  1669. X            tvar = makestmttempvar(ex->val.type, name_TEMP);
  1670. X            ex2 = makeexpr_var(tvar);
  1671. X            ex = makeexpr_var(tvar);
  1672. X        }
  1673. X    }
  1674. X    switch (code) {
  1675. X
  1676. X        case 0:  /* eof */
  1677. X        if (*eofname)
  1678. X        ex = makeexpr_bicall_1(eofname, tp_boolean, ex);
  1679. X        else
  1680. X        ex = makeexpr_rel(EK_NE, makeexpr_bicall_1("feof", tp_int, ex),
  1681. X                         makeexpr_long(0));
  1682. X            break;
  1683. X
  1684. X        case 1:  /* eoln */
  1685. X            ex = makeexpr_bicall_1(eolnname, tp_boolean, ex);
  1686. X            break;
  1687. X
  1688. X        case 2:  /* position or filepos */
  1689. X            ex = makeexpr_bicall_1(fileposname, tp_integer, ex);
  1690. X            break;
  1691. X
  1692. X        case 3:  /* maxpos or filesize */
  1693. X            ex = makeexpr_bicall_1(maxposname, tp_integer, ex);
  1694. X            break;
  1695. X
  1696. X    }
  1697. X    if (ex2) {
  1698. X        ex = makeexpr_bicall_4("~CHKIO",
  1699. X                               (code == 0 || code == 1) ? tp_boolean : tp_integer,
  1700. X                               makeexpr_rel(EK_NE, ex2, makeexpr_nil()),
  1701. X                   makeexpr_name("FileNotOpen", tp_int),
  1702. X                               ex, makeexpr_long(0));
  1703. X    }
  1704. X    if (ex3)
  1705. X        ex = makeexpr_comma(makeexpr_assign(makeexpr_var(tvar), ex3), ex);
  1706. X    return ex;
  1707. X}
  1708. X
  1709. X
  1710. X
  1711. XStatic Expr *func_eof()
  1712. X{
  1713. X    Expr *ex;
  1714. X
  1715. X    if (curtok == TOK_LPAR)
  1716. X        ex = p_parexpr(tp_text);
  1717. X    else
  1718. X        ex = makeexpr_var(mp_input);
  1719. X    return iofunc(ex, 0);
  1720. X}
  1721. X
  1722. X
  1723. X
  1724. XStatic Expr *func_eoln()
  1725. X{
  1726. X    Expr *ex;
  1727. X
  1728. X    if (curtok == TOK_LPAR)
  1729. X        ex = p_parexpr(tp_text);
  1730. X    else
  1731. X        ex = makeexpr_var(mp_input);
  1732. X    return iofunc(ex, 1);
  1733. X}
  1734. X
  1735. X
  1736. X
  1737. XStatic Stmt *proc_escape()
  1738. X{
  1739. X    Expr *ex;
  1740. X
  1741. X    if (curtok == TOK_LPAR)
  1742. X        ex = p_parexpr(tp_integer);
  1743. X    else
  1744. X        ex = makeexpr_long(0);
  1745. X    return makestmt_call(makeexpr_bicall_1(name_ESCAPE, tp_int, 
  1746. X                                           makeexpr_arglong(ex, 0)));
  1747. X}
  1748. X
  1749. X
  1750. X
  1751. XStatic Stmt *proc_excl()
  1752. X{
  1753. X    Expr *vex, *ex;
  1754. X
  1755. X    if (!skipopenparen())
  1756. X    return NULL;
  1757. X    vex = p_expr(NULL);
  1758. X    if (!skipcomma())
  1759. X    return NULL;
  1760. X    ex = p_expr(vex->val.type->indextype);
  1761. X    skipcloseparen();
  1762. X    if (vex->val.type->kind == TK_SMALLSET)
  1763. X    return makestmt_assign(vex, makeexpr_bin(EK_BAND, vex->val.type,
  1764. X                         copyexpr(vex),
  1765. X                         makeexpr_un(EK_BNOT, vex->val.type,
  1766. X                                 makeexpr_bin(EK_LSH, vex->val.type,
  1767. X                                      makeexpr_longcast(makeexpr_long(1), 1),
  1768. X                                      ex))));
  1769. X    else
  1770. X    return makestmt_call(makeexpr_bicall_2(setremname, tp_void, vex,
  1771. X                           makeexpr_arglong(enum_to_int(ex), 0)));
  1772. X}
  1773. X
  1774. X
  1775. X
  1776. XStmt *proc_exit()
  1777. X{
  1778. X    Stmt *sp;
  1779. X
  1780. X    if (modula2) {
  1781. X    return makestmt(SK_BREAK);
  1782. X    }
  1783. X    if (curtok == TOK_LPAR) {
  1784. X        gettok();
  1785. X    if (curtok == TOK_PROGRAM ||
  1786. X        (curtok == TOK_IDENT && curtokmeaning->kind == MK_MODULE)) {
  1787. X        gettok();
  1788. X        skipcloseparen();
  1789. X        return makestmt_call(makeexpr_bicall_1("exit", tp_void,
  1790. X                           makeexpr_long(0)));
  1791. X    }
  1792. X        if (curtok != TOK_IDENT || !curtokmeaning || curtokmeaning != curctx)
  1793. X            note("Attempting to EXIT beyond this function [188]");
  1794. X        gettok();
  1795. X    skipcloseparen();
  1796. X    }
  1797. X    sp = makestmt(SK_RETURN);
  1798. X    if (curctx->kind == MK_FUNCTION && curctx->isfunction) {
  1799. X        sp->exp1 = makeexpr_var(curctx->cbase);
  1800. X        curctx->cbase->refcount++;
  1801. X    }
  1802. X    return sp;
  1803. X}
  1804. X
  1805. X
  1806. X
  1807. XStatic Expr *file_iofunc(code, base)
  1808. Xint code;
  1809. Xlong base;
  1810. X{
  1811. X    Expr *ex;
  1812. X    Type *basetype;
  1813. X
  1814. X    if (curtok == TOK_LPAR)
  1815. X    ex = p_parexpr(tp_text);
  1816. X    else
  1817. X    ex = makeexpr_var(mp_input);
  1818. X    if (!ex->val.type || !ex->val.type->basetype ||
  1819. X    !ex->val.type->basetype->basetype)
  1820. X    basetype = tp_char;
  1821. X    else
  1822. X    basetype = ex->val.type->basetype->basetype;
  1823. X    return makeexpr_plus(makeexpr_div(iofunc(ex, code),
  1824. X                                      makeexpr_sizeof(makeexpr_type(basetype), 0)),
  1825. X                         makeexpr_long(base));
  1826. X}
  1827. X
  1828. X
  1829. X
  1830. XStatic Expr *func_fcall()
  1831. X{
  1832. X    Expr *ex, *ex2, *ex3;
  1833. X    Type *type, *tp;
  1834. X    Meaning *mp, *tvar = NULL;
  1835. X    int firstarg = 0;
  1836. X
  1837. X    if (!skipopenparen())
  1838. X    return NULL;
  1839. X    ex2 = p_expr(tp_proc);
  1840. X    type = ex2->val.type;
  1841. X    if (type->kind != TK_PROCPTR && type->kind != TK_CPROCPTR) {
  1842. X        warning("FCALL requires a function variable [209]");
  1843. X    type = tp_proc;
  1844. X    }
  1845. X    ex = makeexpr(EK_SPCALL, 1);
  1846. X    ex->val.type = type->basetype->basetype;
  1847. X    ex->args[0] = copyexpr(ex2);
  1848. X    if (type->escale != 0)
  1849. X    ex->args[0] = makeexpr_cast(makeexpr_dotq(ex2, "proc", tp_anyptr),
  1850. X                    makepointertype(type->basetype));
  1851. X    mp = type->basetype->fbase;
  1852. X    if (mp && mp->isreturn) {    /* pointer to buffer for return value */
  1853. X        tvar = makestmttempvar(ex->val.type->basetype,
  1854. X            (ex->val.type->basetype->kind == TK_STRING) ? name_STRING : name_TEMP);
  1855. X        insertarg(&ex, 1, makeexpr_addr(makeexpr_var(tvar)));
  1856. X        mp = mp->xnext;
  1857. X    firstarg++;
  1858. X    }
  1859. X    if (mp) {
  1860. X        if (wneedtok(TOK_COMMA))
  1861. X        ex = p_funcarglist(ex, mp, 0, 0);
  1862. X    }
  1863. X    if (tvar)
  1864. X    ex = makeexpr_hat(ex, 0);    /* returns pointer to structured result */
  1865. X    skipcloseparen();
  1866. X    if (type->escale != 1 || hasstaticlinks == 2) {
  1867. X    freeexpr(ex2);
  1868. X    return ex;
  1869. X    }
  1870. X    ex2 = makeexpr_dotq(ex2, "link", tp_anyptr),
  1871. X    ex3 = copyexpr(ex);
  1872. X    insertarg(&ex3, ex3->nargs, copyexpr(ex2));
  1873. X    tp = maketype(TK_FUNCTION);
  1874. X    tp->basetype = type->basetype->basetype;
  1875. X    tp->fbase = type->basetype->fbase;
  1876. X    tp->issigned = 1;
  1877. X    ex3->args[0]->val.type = makepointertype(tp);
  1878. X    return makeexpr_cond(makeexpr_rel(EK_NE, ex2, makeexpr_nil()),
  1879. X             ex3, ex);
  1880. X}
  1881. X
  1882. X
  1883. X
  1884. XStatic Expr *func_filepos()
  1885. X{
  1886. X    return file_iofunc(2, seek_base);
  1887. X}
  1888. X
  1889. X
  1890. X
  1891. XStatic Expr *func_filesize()
  1892. X{
  1893. X    return file_iofunc(3, 1L);
  1894. X}
  1895. X
  1896. X
  1897. X
  1898. XStatic Stmt *proc_fillchar()
  1899. X{
  1900. X    Expr *vex, *ex, *cex;
  1901. X
  1902. X    if (!skipopenparen())
  1903. X    return NULL;
  1904. X    vex = gentle_cast(makeexpr_addr(p_expr(NULL)), tp_anyptr);
  1905. X    if (!skipcomma())
  1906. X    return NULL;
  1907. X    ex = convert_size(argbasetype(vex), p_expr(tp_integer), "FILLCHAR");
  1908. X    if (!skipcomma())
  1909. X    return NULL;
  1910. X    cex = makeexpr_charcast(p_expr(tp_integer));
  1911. X    skipcloseparen();
  1912. X    return makestmt_call(makeexpr_bicall_3("memset", tp_void,
  1913. X                                           vex,
  1914. X                                           makeexpr_arglong(cex, 0),
  1915. X                                           makeexpr_arglong(ex, (size_t_long != 0))));
  1916. X}
  1917. X
  1918. X
  1919. X
  1920. XStatic Expr *func_sngl()
  1921. X{
  1922. X    Expr *ex;
  1923. X
  1924. X    ex = p_parexpr(tp_real);
  1925. X    return makeexpr_cast(ex, tp_real);
  1926. X}
  1927. X
  1928. X
  1929. X
  1930. XStatic Expr *func_float()
  1931. X{
  1932. X    Expr *ex;
  1933. X
  1934. X    ex = p_parexpr(tp_longreal);
  1935. X    return makeexpr_cast(ex, tp_longreal);
  1936. X}
  1937. X
  1938. X
  1939. X
  1940. XStatic Stmt *proc_flush()
  1941. X{
  1942. X    Expr *ex;
  1943. X    Stmt *sp;
  1944. X
  1945. X    ex = p_parexpr(tp_text);
  1946. X    sp = makestmt_call(makeexpr_bicall_1("fflush", tp_void, ex));
  1947. X    if (iocheck_flag)
  1948. X        sp = makestmt_seq(sp, makestmt_assign(makeexpr_var(mp_ioresult), 
  1949. X                                              makeexpr_long(0)));
  1950. X    return sp;
  1951. X}
  1952. X
  1953. X
  1954. X
  1955. XStatic Expr *func_frac(ex)
  1956. XExpr *ex;
  1957. X{
  1958. X    Meaning *tvar;
  1959. X
  1960. X    tvar = makestmttempvar(tp_longreal, name_DUMMY);
  1961. X    return makeexpr_bicall_2("modf", tp_longreal, 
  1962. X                             grabarg(ex, 0),
  1963. X                             makeexpr_addr(makeexpr_var(tvar)));
  1964. X}
  1965. X
  1966. X
  1967. X
  1968. XStatic Stmt *proc_freemem(ex)
  1969. XExpr *ex;
  1970. X{
  1971. X    Stmt *sp;
  1972. X    Expr *vex;
  1973. X
  1974. X    vex = makeexpr_hat(eatcasts(ex->args[0]), 0);
  1975. X    sp = makestmt_call(makeexpr_bicall_1(choose_free_func(vex),
  1976. X                     tp_void, copyexpr(vex)));
  1977. X    if (alloczeronil) {
  1978. X        sp = makestmt_if(makeexpr_rel(EK_NE, vex, makeexpr_nil()),
  1979. X                         sp, NULL);
  1980. X    } else
  1981. X        freeexpr(vex);
  1982. X    return sp;
  1983. X}
  1984. X
  1985. X
  1986. X
  1987. XStatic Stmt *proc_get()
  1988. X{
  1989. X    Expr *ex;
  1990. X    Type *type;
  1991. X
  1992. X    if (curtok == TOK_LPAR)
  1993. X    ex = p_parexpr(tp_text);
  1994. X    else
  1995. X    ex = makeexpr_var(mp_input);
  1996. X    requirefilebuffer(ex);
  1997. X    type = ex->val.type;
  1998. X    if (isfiletype(type) && *chargetname &&
  1999. X    type->basetype->basetype->kind == TK_CHAR)
  2000. X    return makestmt_call(makeexpr_bicall_1(chargetname, tp_void, ex));
  2001. X    else if (isfiletype(type) && *arraygetname &&
  2002. X         type->basetype->basetype->kind == TK_ARRAY)
  2003. X    return makestmt_call(makeexpr_bicall_2(arraygetname, tp_void, ex,
  2004. X                           makeexpr_type(type->basetype->basetype)));
  2005. X    else
  2006. END_OF_FILE
  2007. if test 48548 -ne `wc -c <'src/funcs.c.1'`; then
  2008.     echo shar: \"'src/funcs.c.1'\" unpacked with wrong size!
  2009. fi
  2010. # end of 'src/funcs.c.1'
  2011. fi
  2012. echo shar: End of archive 21 \(of 32\).
  2013. cp /dev/null ark21isdone
  2014. MISSING=""
  2015. for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 ; do
  2016.     if test ! -f ark${I}isdone ; then
  2017.     MISSING="${MISSING} ${I}"
  2018.     fi
  2019. done
  2020. if test "${MISSING}" = "" ; then
  2021.     echo You have unpacked all 32 archives.
  2022.     echo "Now see PACKNOTES and the README"
  2023.     rm -f ark[1-9]isdone ark[1-9][0-9]isdone
  2024. else
  2025.     echo You still need to unpack the following archives:
  2026.     echo "        " ${MISSING}
  2027. fi
  2028. ##  End of shell archive.
  2029. exit 0
  2030.