home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / unix / volume21 / p2c / part17 < prev    next >
Encoding:
Internet Message Format  |  1990-04-05  |  44.4 KB
  1. Subject:  v21i062:  Pascal to C translator, Part17/32
  2. Newsgroups: comp.sources.unix
  3. Approved: rsalz@uunet.UU.NET
  4. X-Checksum-Snefru: 579585ce 6856789a f42dfa4a ff11df4a
  5.  
  6. Submitted-by: Dave Gillespie <daveg@csvax.caltech.edu>
  7. Posting-number: Volume 21, Issue 62
  8. Archive-name: p2c/part17
  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 17 (of 32)."
  17. # Contents:  src/funcs.c.3
  18. # Wrapped by rsalz@litchi.bbn.com on Mon Mar 26 14:29:39 1990
  19. PATH=/bin:/usr/bin:/usr/ucb ; export PATH
  20. if test -f 'src/funcs.c.3' -a "${1}" != "-c" ; then 
  21.   echo shar: Will not clobber existing file \"'src/funcs.c.3'\"
  22. else
  23. echo shar: Extracting \"'src/funcs.c.3'\" \(42271 characters\)
  24. sed "s/^X//" >'src/funcs.c.3' <<'END_OF_FILE'
  25. X    ex2 = p_expr(tp_str255);
  26. X    skipcloseparen();
  27. X    return makestmt_assign(ex, makeexpr_concat(copyexpr(ex), ex2, 0));
  28. X}
  29. X
  30. X
  31. X
  32. XStatic Stmt *proc_strdelete()
  33. X{
  34. X    Meaning *tvar = NULL, *tvari;
  35. X    Expr *ex, *ex2, *ex3, *ex4, *exi, *exn;
  36. X    Stmt *sp;
  37. X
  38. X    if (!skipopenparen())
  39. X    return NULL;
  40. X    ex = p_expr(tp_str255);
  41. X    if (!skipcomma())
  42. X    return NULL;
  43. X    exi = p_expr(tp_integer);
  44. X    if (curtok == TOK_COMMA) {
  45. X    gettok();
  46. X    exn = p_expr(tp_integer);
  47. X    } else
  48. X    exn = makeexpr_long(1);
  49. X    skipcloseparen();
  50. X    if (exprspeed(exi) < 5 && nosideeffects(exi, 0))
  51. X        sp = NULL;
  52. X    else {
  53. X        tvari = makestmttempvar(tp_int, name_TEMP);
  54. X        sp = makestmt_assign(makeexpr_var(tvari), exi);
  55. X        exi = makeexpr_var(tvari);
  56. X    }
  57. X    ex3 = bumpstring(copyexpr(ex), copyexpr(exi), 1);
  58. X    ex4 = bumpstring(copyexpr(ex), makeexpr_plus(exi, exn), 1);
  59. X    if (strcpyleft) {
  60. X        ex2 = ex3;
  61. X    } else {
  62. X        tvar = makestmttempvar(tp_str255, name_STRING);
  63. X        ex2 = makeexpr_var(tvar);
  64. X    }
  65. X    sp = makestmt_seq(sp, makestmt_assign(ex2, ex4));
  66. X    if (!strcpyleft)
  67. X        sp = makestmt_seq(sp, makestmt_assign(ex3, makeexpr_var(tvar)));
  68. X    return sp;
  69. X}
  70. X
  71. X
  72. X
  73. XStatic Stmt *proc_strinsert()
  74. X{
  75. X    Meaning *tvari;
  76. X    Expr *exs, *exd, *exi;
  77. X    Stmt *sp;
  78. X
  79. X    if (!skipopenparen())
  80. X    return NULL;
  81. X    exs = p_expr(tp_str255);
  82. X    if (!skipcomma())
  83. X    return NULL;
  84. X    exd = p_expr(tp_str255);
  85. X    if (!skipcomma())
  86. X    return NULL;
  87. X    exi = p_expr(tp_integer);
  88. X    skipcloseparen();
  89. X#if 0
  90. X    if (checkconst(exi, 1)) {
  91. X        freeexpr(exi);
  92. X        return makestmt_assign(exd,
  93. X                               makeexpr_concat(exs, copyexpr(exd)));
  94. X    }
  95. X#endif
  96. X    if (exprspeed(exi) < 5 && nosideeffects(exi, 0))
  97. X        sp = NULL;
  98. X    else {
  99. X        tvari = makestmttempvar(tp_int, name_TEMP);
  100. X        sp = makestmt_assign(makeexpr_var(tvari), exi);
  101. X        exi = makeexpr_var(tvari);
  102. X    }
  103. X    exd = bumpstring(exd, exi, 1);
  104. X    sp = makestmt_seq(sp, makestmt_assign(exd,
  105. X                                          makeexpr_concat(exs, copyexpr(exd), 0)));
  106. X    return sp;
  107. X}
  108. X
  109. X
  110. X
  111. XStatic Stmt *proc_strmove()
  112. X{
  113. X    Expr *exlen, *exs, *exsi, *exd, *exdi;
  114. X
  115. X    if (!skipopenparen())
  116. X    return NULL;
  117. X    exlen = p_expr(tp_integer);
  118. X    if (!skipcomma())
  119. X    return NULL;
  120. X    exs = p_expr(tp_str255);
  121. X    if (!skipcomma())
  122. X    return NULL;
  123. X    exsi = p_expr(tp_integer);
  124. X    if (!skipcomma())
  125. X    return NULL;
  126. X    exd = p_expr(tp_str255);
  127. X    if (!skipcomma())
  128. X    return NULL;
  129. X    exdi = p_expr(tp_integer);
  130. X    skipcloseparen();
  131. X    exsi = makeexpr_arglong(exsi, 0);
  132. X    exdi = makeexpr_arglong(exdi, 0);
  133. X    return makestmt_call(makeexpr_bicall_5(strmovename, tp_str255,
  134. X                       exlen, exs, exsi, exd, exdi));
  135. X}
  136. X
  137. X
  138. X
  139. XStatic Expr *func_strlen(ex)
  140. XExpr *ex;
  141. X{
  142. X    return makeexpr_bicall_1("strlen", tp_int, grabarg(ex, 0));
  143. X}
  144. X
  145. X
  146. X
  147. XStatic Expr *func_strltrim(ex)
  148. XExpr *ex;
  149. X{
  150. X    return makeexpr_assign(makeexpr_hat(ex->args[0], 0),
  151. X                           makeexpr_bicall_1(strltrimname, tp_str255, ex->args[1]));
  152. X}
  153. X
  154. X
  155. X
  156. XStatic Expr *func_strmax(ex)
  157. XExpr *ex;
  158. X{
  159. X    return strmax_func(grabarg(ex, 0));
  160. X}
  161. X
  162. X
  163. X
  164. XStatic Expr *func_strpos(ex)
  165. XExpr *ex;
  166. X{
  167. X    char *cp;
  168. X
  169. X    if (!switch_strpos)
  170. X        swapexprs(ex->args[0], ex->args[1]);
  171. X    cp = strposname;
  172. X    if (!*cp) {
  173. X        note("STRPOS function used [201]");
  174. X        cp = "STRPOS";
  175. X    } 
  176. X    return makeexpr_bicall_3(cp, tp_int,
  177. X                             ex->args[0], 
  178. X                             ex->args[1],
  179. X                             makeexpr_long(1));
  180. X}
  181. X
  182. X
  183. X
  184. XStatic Expr *func_strrpt(ex)
  185. XExpr *ex;
  186. X{
  187. X    if (ex->args[1]->kind == EK_CONST &&
  188. X        ex->args[1]->val.i == 1 && ex->args[1]->val.s[0] == ' ') {
  189. X        return makeexpr_bicall_4("sprintf", tp_strptr, ex->args[0],
  190. X                                 makeexpr_string("%*s"),
  191. X                                 makeexpr_longcast(ex->args[2], 0),
  192. X                                 makeexpr_string(""));
  193. X    } else
  194. X        return makeexpr_bicall_3(strrptname, tp_strptr, ex->args[0], ex->args[1],
  195. X                                 makeexpr_arglong(ex->args[2], 0));
  196. X}
  197. X
  198. X
  199. X
  200. XStatic Expr *func_strrtrim(ex)
  201. XExpr *ex;
  202. X{
  203. X    return makeexpr_bicall_1(strrtrimname, tp_strptr,
  204. X                             makeexpr_assign(makeexpr_hat(ex->args[0], 0),
  205. X                                             ex->args[1]));
  206. X}
  207. X
  208. X
  209. X
  210. XStatic Expr *func_succ()
  211. X{
  212. X    Expr *ex;
  213. X
  214. X    if (wneedtok(TOK_LPAR)) {
  215. X    ex = p_ord_expr();
  216. X    skipcloseparen();
  217. X    } else
  218. X    ex = p_ord_expr();
  219. X#if 1
  220. X    ex = makeexpr_inc(ex, makeexpr_long(1));
  221. X#else
  222. X    ex = makeexpr_cast(makeexpr_plus(ex, makeexpr_long(1)), ex->val.type);
  223. X#endif
  224. X    return ex;
  225. X}
  226. X
  227. X
  228. X
  229. XStatic Expr *func_sqr()
  230. X{
  231. X    return makeexpr_sqr(p_parexpr(tp_integer), 0);
  232. X}
  233. X
  234. X
  235. X
  236. XStatic Expr *func_sqrt(ex)
  237. XExpr *ex;
  238. X{
  239. X    return makeexpr_bicall_1("sqrt", tp_longreal, grabarg(ex, 0));
  240. X}
  241. X
  242. X
  243. X
  244. XStatic Expr *func_swap(ex)
  245. XExpr *ex;
  246. X{
  247. X    char *cp;
  248. X
  249. X    ex = grabarg(ex, 0);
  250. X    cp = swapname;
  251. X    if (!*cp) {
  252. X        note("SWAP function was used [202]");
  253. X        cp = "SWAP";
  254. X    }
  255. X    return makeexpr_bicall_1(swapname, tp_int, ex);
  256. X}
  257. X
  258. X
  259. X
  260. XStatic Expr *func_tan(ex)
  261. XExpr *ex;
  262. X{
  263. X    return makeexpr_bicall_1("tan", tp_longreal, grabarg(ex, 0));
  264. X}
  265. X
  266. X
  267. XStatic Expr *func_tanh(ex)
  268. XExpr *ex;
  269. X{
  270. X    return makeexpr_bicall_1("tanh", tp_longreal, grabarg(ex, 0));
  271. X}
  272. X
  273. X
  274. X
  275. XStatic Expr *func_trunc(ex)
  276. XExpr *ex;
  277. X{
  278. X    return makeexpr_actcast(grabarg(ex, 0), tp_integer);
  279. X}
  280. X
  281. X
  282. X
  283. XStatic Expr *func_utrunc(ex)
  284. XExpr *ex;
  285. X{
  286. X    return makeexpr_actcast(grabarg(ex, 0), tp_unsigned);
  287. X}
  288. X
  289. X
  290. X
  291. XStatic Expr *func_uand()
  292. X{
  293. X    Expr *ex;
  294. X
  295. X    if (!skipopenparen())
  296. X    return NULL;
  297. X    ex = p_expr(tp_unsigned);
  298. X    if (skipcomma()) {
  299. X    ex = makeexpr_bin(EK_BAND, ex->val.type, ex, p_expr(tp_unsigned));
  300. X    skipcloseparen();
  301. X    }
  302. X    return ex;
  303. X}
  304. X
  305. X
  306. X
  307. XStatic Expr *func_udec()
  308. X{
  309. X    return handle_vax_hex(NULL, "u", 0);
  310. X}
  311. X
  312. X
  313. X
  314. XStatic Expr *func_unot()
  315. X{
  316. X    Expr *ex;
  317. X
  318. X    if (!skipopenparen())
  319. X    return NULL;
  320. X    ex = p_expr(tp_unsigned);
  321. X    ex = makeexpr_un(EK_BNOT, ex->val.type, ex);
  322. X    skipcloseparen();
  323. X    return ex;
  324. X}
  325. X
  326. X
  327. X
  328. XStatic Expr *func_uor()
  329. X{
  330. X    Expr *ex;
  331. X
  332. X    if (!skipopenparen())
  333. X    return NULL;
  334. X    ex = p_expr(tp_unsigned);
  335. X    if (skipcomma()) {
  336. X    ex = makeexpr_bin(EK_BOR, ex->val.type, ex, p_expr(tp_unsigned));
  337. X    skipcloseparen();
  338. X    }
  339. X    return ex;
  340. X}
  341. X
  342. X
  343. X
  344. XStatic Expr *func_upcase(ex)
  345. XExpr *ex;
  346. X{
  347. X    return makeexpr_bicall_1("toupper", tp_char, grabarg(ex, 0));
  348. X}
  349. X
  350. X
  351. X
  352. XStatic Expr *func_upper()
  353. X{
  354. X    Expr *ex;
  355. X    Value val;
  356. X
  357. X    if (!skipopenparen())
  358. X    return NULL;
  359. X    ex = p_expr(tp_integer);
  360. X    if (curtok == TOK_COMMA) {
  361. X    gettok();
  362. X    val = p_constant(tp_integer);
  363. X    if (!val.type || val.i != 1)
  364. X        note("UPPER(v,n) not supported for n>1 [190]");
  365. X    }
  366. X    skipcloseparen();
  367. X    return copyexpr(ex->val.type->indextype->smax);
  368. X}
  369. X
  370. X
  371. X
  372. XStatic Expr *func_uxor()
  373. X{
  374. X    Expr *ex;
  375. X
  376. X    if (!skipopenparen())
  377. X    return NULL;
  378. X    ex = p_expr(tp_unsigned);
  379. X    if (skipcomma()) {
  380. X    ex = makeexpr_bin(EK_BXOR, ex->val.type, ex, p_expr(tp_unsigned));
  381. X    skipcloseparen();
  382. X    }
  383. X    return ex;
  384. X}
  385. X
  386. X
  387. X
  388. XStatic Expr *func_val_modula()
  389. X{
  390. X    Expr *ex;
  391. X    Type *tp;
  392. X
  393. X    if (!skipopenparen())
  394. X    return NULL;
  395. X    tp = p_type(NULL);
  396. X    if (!skipcomma())
  397. X    return NULL;
  398. X    ex = p_expr(tp);
  399. X    skipcloseparen();
  400. X    return pascaltypecast(tp, ex);
  401. X}
  402. X
  403. X
  404. X
  405. XStatic Stmt *proc_val_turbo()
  406. X{
  407. X    Expr *ex, *vex, *code, *fmt;
  408. X
  409. X    if (!skipopenparen())
  410. X    return NULL;
  411. X    ex = gentle_cast(p_expr(tp_str255), tp_str255);
  412. X    if (!skipcomma())
  413. X    return NULL;
  414. X    vex = p_expr(NULL);
  415. X    if (curtok == TOK_COMMA) {
  416. X    gettok();
  417. X    code = gentle_cast(p_expr(tp_integer), tp_integer);
  418. X    } else
  419. X    code = NULL;
  420. X    skipcloseparen();
  421. X    if (vex->val.type->kind == TK_REAL)
  422. X        fmt = makeexpr_string("%lg");
  423. X    else if (exprlongness(vex) > 0)
  424. X        fmt = makeexpr_string("%ld");
  425. X    else
  426. X        fmt = makeexpr_string("%d");
  427. X    ex = makeexpr_bicall_3("sscanf", tp_int,
  428. X                           ex, fmt, makeexpr_addr(vex));
  429. X    if (code) {
  430. X    ex = makeexpr_rel(EK_EQ, ex, makeexpr_long(0));
  431. X    return makestmt_assign(code, makeexpr_ord(ex));
  432. X    } else
  433. X    return makestmt_call(ex);
  434. X}
  435. X
  436. X
  437. X
  438. X
  439. X
  440. X
  441. X
  442. XStatic Expr *writestrelement(ex, wid, vex, code, needboth)
  443. XExpr *ex, *wid, *vex;
  444. Xint code, needboth;
  445. X{
  446. X    if (formatstrings && needboth) {
  447. X        return makeexpr_bicall_5("sprintf", tp_str255, vex,
  448. X                                 makeexpr_string(format_d("%%*.*%c", code)),
  449. X                                 copyexpr(wid),
  450. X                                 wid,
  451. X                                 ex);
  452. X    } else {
  453. X        return makeexpr_bicall_4("sprintf", tp_str255, vex,
  454. X                                 makeexpr_string(format_d("%%*%c", code)),
  455. X                                 wid,
  456. X                                 ex);
  457. X    }
  458. X}
  459. X
  460. X
  461. X
  462. XStatic char *makeenumnames(tp)
  463. XType *tp;
  464. X{
  465. X    Strlist *sp;
  466. X    char *name;
  467. X    Meaning *mp;
  468. X    int saveindent;
  469. X
  470. X    for (sp = enumnames; sp && sp->value != (long)tp; sp = sp->next) ;
  471. X    if (!sp) {
  472. X        if (tp->meaning)
  473. X            name = format_s(name_ENUM, tp->meaning->name);
  474. X        else
  475. X            name = format_s(name_ENUM, format_d("_%d", ++enumnamecount));
  476. X        sp = strlist_insert(&enumnames, name);
  477. X        sp->value = (long)tp;
  478. X        outsection(2);
  479. X        output(format_s("Static %s *", charname));
  480. X        output(sp->s);
  481. X        output("[] = {\n");
  482. X    saveindent = outindent;
  483. X    moreindent(tabsize);
  484. X    moreindent(structinitindent);
  485. X        for (mp = tp->fbase; mp; mp = mp->xnext) {
  486. X            output(makeCstring(mp->sym->name, strlen(mp->sym->name)));
  487. X            if (mp->xnext)
  488. X                output(",\002 ");
  489. X        }
  490. X        outindent = saveindent;
  491. X        output("\n} ;\n");
  492. X        outsection(2);
  493. X    }
  494. X    return sp->s;
  495. X}
  496. X
  497. X
  498. X
  499. X
  500. X
  501. X/* This function must return a "tempsprintf" */
  502. X
  503. XExpr *writeelement(ex, wid, prec, base)
  504. XExpr *ex, *wid, *prec;
  505. Xint base;
  506. X{
  507. X    Expr *vex, *ex1, *ex2;
  508. X    Meaning *tvar;
  509. X    char *fmtcode;
  510. X    Type *type;
  511. X
  512. X    ex = makeexpr_charcast(ex);
  513. X    if (ex->val.type->kind == TK_POINTER) {
  514. X        ex = makeexpr_hat(ex, 0);   /* convert char *'s to strings */
  515. X        intwarning("writeelement", "got a char * instead of a string [214]");
  516. X    }
  517. X    if ((ex->val.type->kind == TK_STRING && !wid) ||
  518. X        (ord_type(ex->val.type)->kind == TK_CHAR && (!wid || checkconst(wid, 1)))) {
  519. X        return makeexpr_sprintfify(ex);
  520. X    }
  521. X    tvar = makestmttempvar(tp_str255, name_STRING);
  522. X    vex = makeexpr_var(tvar);
  523. X    if (wid)
  524. X        wid = makeexpr_longcast(wid, 0);
  525. X    if (prec)
  526. X        prec = makeexpr_longcast(prec, 0);
  527. X#if 0
  528. X    if (wid && (wid->kind == EK_CONST && wid->val.i < 0 ||
  529. X                checkconst(wid, -1))) {
  530. X        freeexpr(wid);     /* P-system uses write(x:-1) to mean write(x) */
  531. X        wid = NULL;
  532. X    }
  533. X    if (prec && (prec->kind == EK_CONST && prec->val.i < 0 ||
  534. X                 checkconst(prec, -1))) {
  535. X        freeexpr(prec);
  536. X        prec = NULL;
  537. X    }
  538. X#endif
  539. X    switch (ord_type(ex->val.type)->kind) {
  540. X
  541. X        case TK_INTEGER:
  542. X            if (!wid) {
  543. X        if (integerwidth < 0)
  544. X            integerwidth = (which_lang == LANG_TURBO) ? 1 : 12;
  545. X        wid = makeexpr_long(integerwidth);
  546. X        }
  547. X        type = findbasetype(ex->val.type, 0);
  548. X        if (base == 16)
  549. X        fmtcode = "x";
  550. X        else if (base == 8)
  551. X        fmtcode = "o";
  552. X        else if ((possiblesigns(wid) & (1|4)) == 1) {
  553. X        wid = makeexpr_neg(wid);
  554. X        fmtcode = "x";
  555. X        } else if (type == tp_unsigned ||
  556. X               type == tp_uint ||
  557. X               (type == tp_ushort && sizeof_int < 32))
  558. X        fmtcode = "u";
  559. X        else
  560. X        fmtcode = "d";
  561. X            ex = makeexpr_forcelongness(ex);
  562. X            if (checkconst(wid, 0) || checkconst(wid, 1)) {
  563. X                ex = makeexpr_bicall_3("sprintf", tp_str255, vex,
  564. X                                       makeexpr_string(format_ss("%%%s%s",
  565. X                                 (exprlongness(ex) > 0) ? "l" : "",
  566. X                                 fmtcode)),
  567. X                                       ex);
  568. X            } else {
  569. X                ex = makeexpr_bicall_4("sprintf", tp_str255, vex,
  570. X                                       makeexpr_string(format_ss("%%*%s%s",
  571. X                                 (exprlongness(ex) > 0) ? "l" : "",
  572. X                                 fmtcode)),
  573. X                                       wid,
  574. X                                       ex);
  575. X            }
  576. X            break;
  577. X
  578. X        case TK_CHAR:
  579. X            ex = writestrelement(ex, wid, vex, 'c',
  580. X                                     (wid->kind != EK_CONST || wid->val.i < 1));
  581. X            break;
  582. X
  583. X        case TK_BOOLEAN:
  584. X            if (!wid) {
  585. X                ex = makeexpr_bicall_3("sprintf", tp_str255, vex,
  586. X                                       makeexpr_string("%s"),
  587. X                                       makeexpr_cond(ex,
  588. X                                                     makeexpr_string(" TRUE"),
  589. X                                                     makeexpr_string("FALSE")));
  590. X            } else if (checkconst(wid, 1)) {
  591. X                ex = makeexpr_bicall_3("sprintf", tp_str255, vex,
  592. X                                       makeexpr_string("%c"),
  593. X                                       makeexpr_cond(ex,
  594. X                                                     makeexpr_char('T'),
  595. X                                                     makeexpr_char('F')));
  596. X            } else {
  597. X                ex = writestrelement(makeexpr_cond(ex,
  598. X                                                   makeexpr_string("TRUE"),
  599. X                                                   makeexpr_string("FALSE")),
  600. X                                     wid, vex, 's',
  601. X                                     (wid->kind != EK_CONST || wid->val.i < 5));
  602. X            }
  603. X            break;
  604. X
  605. X        case TK_ENUM:
  606. X            ex = makeexpr_bicall_3("sprintf", tp_str255, vex,
  607. X                                   makeexpr_string("%s"),
  608. X                                   makeexpr_index(makeexpr_name(makeenumnames(ex->val.type),
  609. X                                                                tp_strptr),
  610. X                                                  ex, NULL));
  611. X            break;
  612. X
  613. X        case TK_REAL:
  614. X            if (!wid)
  615. X                wid = makeexpr_long(realwidth);
  616. X            if (prec && (possiblesigns(prec) & (1|4)) != 1) {
  617. X                ex = makeexpr_bicall_5("sprintf", tp_str255, vex,
  618. X                                       makeexpr_string("%*.*f"),
  619. X                                       wid,
  620. X                                       prec,
  621. X                                       ex);
  622. X            } else {
  623. X        if (prec)
  624. X            prec = makeexpr_neg(prec);
  625. X        else
  626. X            prec = makeexpr_minus(copyexpr(wid),
  627. X                      makeexpr_long(7));
  628. X        if (prec->kind == EK_CONST) {
  629. X            if (prec->val.i <= 0)
  630. X            prec = makeexpr_long(1);
  631. X        } else {
  632. X            prec = makeexpr_bicall_2("P_max", tp_integer, prec,
  633. X                         makeexpr_long(1));
  634. X        }
  635. X                if (wid->kind == EK_CONST && wid->val.i > 21) {
  636. X                    ex = makeexpr_bicall_5("sprintf", tp_str255, vex,
  637. X                                           makeexpr_string("%*.*E"),
  638. X                                           wid,
  639. X                       prec,
  640. X                                           ex);
  641. X#if 0
  642. X                } else if (checkconst(wid, 7)) {
  643. X                    ex = makeexpr_bicall_3("sprintf", tp_str255, vex,
  644. X                                           makeexpr_string("%E"),
  645. X                                           ex);
  646. X#endif
  647. X                } else {
  648. X                    ex = makeexpr_bicall_4("sprintf", tp_str255, vex,
  649. X                                           makeexpr_string("% .*E"),
  650. X                       prec,
  651. X                                           ex);
  652. X                }
  653. X            }
  654. X            break;
  655. X
  656. X        case TK_STRING:
  657. X            ex = writestrelement(ex, wid, vex, 's', 1);
  658. X            break;
  659. X
  660. X        case TK_ARRAY:     /* assume packed array of char */
  661. X        ord_range_expr(ex->val.type->indextype, &ex1, &ex2);
  662. X        ex1 = makeexpr_plus(makeexpr_minus(copyexpr(ex2),
  663. X                           copyexpr(ex1)),
  664. X                makeexpr_long(1));
  665. X        ex1 = makeexpr_longcast(ex1, 0);
  666. X        fmtcode = "%.*s";
  667. X            if (!wid) {
  668. X        wid = ex1;
  669. X            } else {
  670. X        if (isliteralconst(wid, NULL) == 2 &&
  671. X            isliteralconst(ex1, NULL) == 2) {
  672. X            if (wid->val.i > ex1->val.i) {
  673. X            fmtcode = format_ds("%*s%%.*s",
  674. X                        wid->val.i - ex1->val.i, "");
  675. X            wid = ex1;
  676. X            }
  677. X        } else
  678. X            note("Format for packed-array-of-char will work only if width < length [321]");
  679. X        }
  680. X            ex = makeexpr_bicall_4("sprintf", tp_str255, vex,
  681. X                                   makeexpr_string(fmtcode),
  682. X                                   wid,
  683. X                                   makeexpr_addr(ex));
  684. X            break;
  685. X
  686. X        default:
  687. X            note("Element has wrong type for WRITE statement [196]");
  688. X            ex = makeexpr_bicall_2("sprintf", tp_str255, vex, makeexpr_string("<meef>"));
  689. X            break;
  690. X
  691. X    }
  692. X    return ex;
  693. X}
  694. X
  695. X
  696. X
  697. XStatic Stmt *handlewrite_text(fex, ex, iswriteln)
  698. XExpr *fex, *ex;
  699. Xint iswriteln;
  700. X{
  701. X    Expr *print, *wid, *prec;
  702. X    unsigned char *ucp;
  703. X    int i, done, base;
  704. X
  705. X    print = NULL;
  706. X    for (;;) {
  707. X        wid = NULL;
  708. X        prec = NULL;
  709. X    base = 10;
  710. X    if (curtok == TOK_COLON && iswriteln >= 0) {
  711. X        gettok();
  712. X        wid = p_expr(tp_integer);
  713. X        if (curtok == TOK_COLON) {
  714. X        gettok();
  715. X        prec = p_expr(tp_integer);
  716. X        }
  717. X    }
  718. X    if (curtok == TOK_IDENT &&
  719. X        !strcicmp(curtokbuf, "OCT")) {
  720. X        base = 8;
  721. X        gettok();
  722. X    } else if (curtok == TOK_IDENT &&
  723. X           !strcicmp(curtokbuf, "HEX")) {
  724. X        base = 16;
  725. X        gettok();
  726. X    }
  727. X        ex = writeelement(ex, wid, prec, base);
  728. X        print = makeexpr_concat(print, cleansprintf(ex), 1);
  729. X        if (curtok == TOK_COMMA && iswriteln >= 0) {
  730. X            gettok();
  731. X            ex = p_expr(NULL);
  732. X        } else
  733. X            break;
  734. X    }
  735. X    if (fex->val.type->kind != TK_STRING) {      /* not strwrite */
  736. X        switch (iswriteln) {
  737. X            case 1:
  738. X            case -1:
  739. X                print = makeexpr_concat(print, makeexpr_string("\n"), 1);
  740. X                break;
  741. X            case 2:
  742. X            case -2:
  743. X                print = makeexpr_concat(print, makeexpr_string("\r"), 1);
  744. X                break;
  745. X        }
  746. X        if (isvar(fex, mp_output)) {
  747. X            ucp = (unsigned char *)print->args[1]->val.s;
  748. X            for (i = 0; i < print->args[1]->val.i; i++) {
  749. X                if (ucp[i] >= 128 && ucp[i] < 144) {
  750. X                    note("WRITE statement contains color/attribute characters [203]");
  751. X            break;
  752. X        }
  753. X            }
  754. X        }
  755. X        if ((i = sprintflength(print, 0)) > 0 && print->nargs == 2 && printfonly != 1) {
  756. X            print = makeexpr_unsprintfify(print);
  757. X            done = 1;
  758. X            if (isvar(fex, mp_output)) {
  759. X                if (i == 1) {
  760. X                    print = makeexpr_bicall_1("putchar", tp_int,
  761. X                                              makeexpr_charcast(print));
  762. X                } else {
  763. X                    if (printfonly == 0) {
  764. X                        if (print->val.s[print->val.i-1] == '\n') {
  765. X                print->val.s[--(print->val.i)] = 0;
  766. X                            print = makeexpr_bicall_1("puts", tp_int, print);
  767. X                        } else {
  768. X                            print = makeexpr_bicall_2("fputs", tp_int,
  769. X                                                      print,
  770. X                                                      copyexpr(fex));
  771. X                        }
  772. X                    } else {
  773. X                        print = makeexpr_sprintfify(print);
  774. X                        done = 0;
  775. X                    }
  776. X                }
  777. X            } else {
  778. X                if (i == 1) {
  779. X                    print = makeexpr_bicall_2("putc", tp_int,
  780. X                                              makeexpr_charcast(print),
  781. X                                              copyexpr(fex));
  782. X                } else if (printfonly == 0) {
  783. X                    print = makeexpr_bicall_2("fputs", tp_int,
  784. X                                              print,
  785. X                                              copyexpr(fex));
  786. X                } else {
  787. X                    print = makeexpr_sprintfify(print);
  788. X                    done = 0;
  789. X                }
  790. X            }
  791. X        } else
  792. X            done = 0;
  793. X        if (!done) {
  794. X            canceltempvar(istempvar(print->args[0]));
  795. X            if (checkstring(print->args[1], "%s") && printfonly != 1) {
  796. X                print = makeexpr_bicall_2("fputs", tp_int,
  797. X                                          grabarg(print, 2),
  798. X                                          copyexpr(fex));
  799. X            } else if (checkstring(print->args[1], "%c") && printfonly != 1 &&
  800. X                       !nosideeffects(print->args[2], 0)) {
  801. X                print = makeexpr_bicall_2("fputc", tp_int,
  802. X                                          grabarg(print, 2),
  803. X                                          copyexpr(fex));
  804. X            } else if (isvar(fex, mp_output)) {
  805. X                if (checkstring(print->args[1], "%s\n") && printfonly != 1) {
  806. X                    print = makeexpr_bicall_1("puts", tp_int, grabarg(print, 2));
  807. X                } else if (checkstring(print->args[1], "%c") && printfonly != 1) {
  808. X                    print = makeexpr_bicall_1("putchar", tp_int, grabarg(print, 2));
  809. X                } else {
  810. X                    strchange(&print->val.s, "printf");
  811. X                    delfreearg(&print, 0);
  812. X                    print->val.type = tp_int;
  813. X                }
  814. X            } else {
  815. X                if (checkstring(print->args[1], "%c") && printfonly != 1) {
  816. X                    print = makeexpr_bicall_2("putc", tp_int,
  817. X                                              grabarg(print, 2),
  818. X                                              copyexpr(fex));
  819. X                } else {
  820. X                    strchange(&print->val.s, "fprintf");
  821. X                    freeexpr(print->args[0]);
  822. X                    print->args[0] = copyexpr(fex);
  823. X                    print->val.type = tp_int;
  824. X                }
  825. X            }
  826. X        }
  827. X        if (FCheck(checkfilewrite)) {
  828. X            print = makeexpr_bicall_2("~SETIO", tp_void,
  829. X                                      makeexpr_rel(EK_GE, print, makeexpr_long(0)),
  830. X                      makeexpr_name(filewriteerrorname, tp_int));
  831. X        }
  832. X    }
  833. X    return makestmt_call(print);
  834. X}
  835. X
  836. X
  837. X
  838. XStatic Stmt *handlewrite_bin(fex, ex)
  839. XExpr *fex, *ex;
  840. X{
  841. X    Type *basetype;
  842. X    Stmt *sp;
  843. X    Expr *tvardef = NULL;
  844. X    Meaning *tvar = NULL;
  845. X
  846. X    sp = NULL;
  847. X    basetype = fex->val.type->basetype->basetype;
  848. X    for (;;) {
  849. X        if (!expr_has_address(ex) || ex->val.type != basetype) {
  850. X            if (!tvar)
  851. X                tvar = makestmttempvar(basetype, name_TEMP);
  852. X            if (!tvardef || !exprsame(tvardef, ex, 1)) {
  853. X                freeexpr(tvardef);
  854. X                tvardef = copyexpr(ex);
  855. X                sp = makestmt_seq(sp, makestmt_assign(makeexpr_var(tvar),
  856. X                                                      ex));
  857. X            } else
  858. X                freeexpr(ex);
  859. X            ex = makeexpr_var(tvar);
  860. X        }
  861. X        ex = makeexpr_bicall_4("fwrite", tp_integer, makeexpr_addr(ex),
  862. X                                                     makeexpr_sizeof(makeexpr_type(basetype), 0),
  863. X                                                     makeexpr_long(1),
  864. X                                                     copyexpr(fex));
  865. X        if (FCheck(checkfilewrite)) {
  866. X            ex = makeexpr_bicall_2("~SETIO", tp_void,
  867. X                                   makeexpr_rel(EK_EQ, ex, makeexpr_long(1)),
  868. X                   makeexpr_name(filewriteerrorname, tp_int));
  869. X        }
  870. X        sp = makestmt_seq(sp, makestmt_call(ex));
  871. X        if (curtok == TOK_COMMA) {
  872. X            gettok();
  873. X            ex = p_expr(NULL);
  874. X        } else
  875. X            break;
  876. X    }
  877. X    freeexpr(tvardef);
  878. X    return sp;
  879. X}
  880. X
  881. X
  882. X
  883. XStatic Stmt *proc_write()
  884. X{
  885. X    Expr *fex, *ex;
  886. X    Stmt *sp;
  887. X
  888. X    if (!skipopenparen())
  889. X    return NULL;
  890. X    ex = p_expr(NULL);
  891. X    if (isfiletype(ex->val.type) && wneedtok(TOK_COMMA)) {
  892. X        fex = ex;
  893. X        ex = p_expr(NULL);
  894. X    } else {
  895. X        fex = makeexpr_var(mp_output);
  896. X    }
  897. X    if (fex->val.type == tp_text)
  898. X        sp = handlewrite_text(fex, ex, 0);
  899. X    else
  900. X        sp = handlewrite_bin(fex, ex);
  901. X    skipcloseparen();
  902. X    return wrapopencheck(sp, fex);
  903. X}
  904. X
  905. X
  906. X
  907. XStatic Stmt *handle_modula_write(fmt)
  908. Xchar *fmt;
  909. X{
  910. X    Expr *ex, *wid;
  911. X
  912. X    if (!skipopenparen())
  913. X    return NULL;
  914. X    ex = makeexpr_forcelongness(p_expr(NULL));
  915. X    if (skipcomma())
  916. X    wid = p_expr(tp_integer);
  917. X    else
  918. X    wid = makeexpr_long(1);
  919. X    if (checkconst(wid, 0) || checkconst(wid, 1))
  920. X    ex = makeexpr_bicall_2("printf", tp_str255,
  921. X                   makeexpr_string(format_ss("%%%s%s",
  922. X                             (exprlongness(ex) > 0) ? "l" : "",
  923. X                             fmt)),
  924. X                   ex);
  925. X    else
  926. X    ex = makeexpr_bicall_3("printf", tp_str255,
  927. X                   makeexpr_string(format_ss("%%*%s%s",
  928. X                             (exprlongness(ex) > 0) ? "l" : "",
  929. X                             fmt)),
  930. X                   makeexpr_arglong(wid, 0),
  931. X                   ex);
  932. X    skipcloseparen();
  933. X    return makestmt_call(ex);
  934. X}
  935. X
  936. X
  937. XStatic Stmt *proc_writecard()
  938. X{
  939. X    return handle_modula_write("u");
  940. X}
  941. X
  942. X
  943. XStatic Stmt *proc_writeint()
  944. X{
  945. X    return handle_modula_write("d");
  946. X}
  947. X
  948. X
  949. XStatic Stmt *proc_writehex()
  950. X{
  951. X    return handle_modula_write("x");
  952. X}
  953. X
  954. X
  955. XStatic Stmt *proc_writeoct()
  956. X{
  957. X    return handle_modula_write("o");
  958. X}
  959. X
  960. X
  961. XStatic Stmt *proc_writereal()
  962. X{
  963. X    return handle_modula_write("f");
  964. X}
  965. X
  966. X
  967. X
  968. XStatic Stmt *proc_writedir()
  969. X{
  970. X    Expr *fex, *ex;
  971. X    Stmt *sp;
  972. X
  973. X    if (!skipopenparen())
  974. X    return NULL;
  975. X    fex = p_expr(tp_text);
  976. X    if (!skipcomma())
  977. X    return NULL;
  978. X    ex = p_expr(tp_integer);
  979. X    sp = doseek(fex, ex);
  980. X    if (!skipcomma())
  981. X    return sp;
  982. X    sp = makestmt_seq(sp, handlewrite_bin(fex, p_expr(NULL)));
  983. X    skipcloseparen();
  984. X    return wrapopencheck(sp, fex);
  985. X}
  986. X
  987. X
  988. X
  989. XStatic Stmt *handlewriteln(iswriteln)
  990. Xint iswriteln;
  991. X{
  992. X    Expr *fex, *ex;
  993. X    Stmt *sp;
  994. X    Meaning *deffile = mp_output;
  995. X
  996. X    sp = NULL;
  997. X    if (iswriteln == 3) {
  998. X    iswriteln = 1;
  999. X    if (messagestderr)
  1000. X        deffile = mp_stderr;
  1001. X    }
  1002. X    if (curtok != TOK_LPAR) {
  1003. X        fex = makeexpr_var(deffile);
  1004. X        if (iswriteln)
  1005. X            sp = handlewrite_text(fex, makeexpr_string(""), -iswriteln);
  1006. X    } else {
  1007. X        gettok();
  1008. X        ex = p_expr(NULL);
  1009. X        if (isfiletype(ex->val.type)) {
  1010. X            fex = ex;
  1011. X            if (curtok == TOK_RPAR || !wneedtok(TOK_COMMA)) {
  1012. X                if (iswriteln)
  1013. X                    ex = makeexpr_string("");
  1014. X                else
  1015. X                    ex = NULL;
  1016. X            } else {
  1017. X                ex = p_expr(NULL);
  1018. X            }
  1019. X        } else {
  1020. X            fex = makeexpr_var(deffile);
  1021. X        }
  1022. X        if (ex)
  1023. X            sp = handlewrite_text(fex, ex, iswriteln);
  1024. X        skipcloseparen();
  1025. X    }
  1026. X    if (iswriteln == 0) {
  1027. X        sp = makestmt_seq(sp, makestmt_call(makeexpr_bicall_1("fflush", tp_void,
  1028. X                                                              copyexpr(fex))));
  1029. X    }
  1030. X    return wrapopencheck(sp, fex);
  1031. X}
  1032. X
  1033. X
  1034. X
  1035. XStatic Stmt *proc_overprint()
  1036. X{
  1037. X    return handlewriteln(2);
  1038. X}
  1039. X
  1040. X
  1041. X
  1042. XStatic Stmt *proc_prompt()
  1043. X{
  1044. X    return handlewriteln(0);
  1045. X}
  1046. X
  1047. X
  1048. X
  1049. XStatic Stmt *proc_writeln()
  1050. X{
  1051. X    return handlewriteln(1);
  1052. X}
  1053. X
  1054. X
  1055. XStatic Stmt *proc_message()
  1056. X{
  1057. X    return handlewriteln(3);
  1058. X}
  1059. X
  1060. X
  1061. X
  1062. XStatic Stmt *proc_writev()
  1063. X{
  1064. X    Expr *vex, *ex;
  1065. X    Stmt *sp;
  1066. X    Meaning *mp;
  1067. X
  1068. X    if (!skipopenparen())
  1069. X    return NULL;
  1070. X    vex = p_expr(tp_str255);
  1071. X    if (curtok == TOK_RPAR) {
  1072. X    gettok();
  1073. X    return makestmt_assign(vex, makeexpr_string(""));
  1074. X    }
  1075. X    if (!skipcomma())
  1076. X    return NULL;
  1077. X    sp = handlewrite_text(vex, p_expr(NULL), 0);
  1078. X    skipcloseparen();
  1079. X    ex = sp->exp1;
  1080. X    if (ex->kind == EK_BICALL && !strcmp(ex->val.s, "sprintf") &&
  1081. X        (mp = istempvar(ex->args[0])) != NULL) {
  1082. X        canceltempvar(mp);
  1083. X        ex->args[0] = vex;
  1084. X    } else
  1085. X        sp->exp1 = makeexpr_assign(vex, ex);
  1086. X    return sp;
  1087. X}
  1088. X
  1089. X
  1090. XStatic Stmt *proc_strwrite(mp_x, spbase)
  1091. XMeaning *mp_x;
  1092. XStmt *spbase;
  1093. X{
  1094. X    Expr *vex, *exi, *exj, *ex;
  1095. X    Stmt *sp;
  1096. X    Meaning *mp;
  1097. X
  1098. X    if (!skipopenparen())
  1099. X    return NULL;
  1100. X    vex = p_expr(tp_str255);
  1101. X    if (!skipcomma())
  1102. X    return NULL;
  1103. X    exi = p_expr(tp_integer);
  1104. X    if (!skipcomma())
  1105. X    return NULL;
  1106. X    exj = p_expr(tp_integer);
  1107. X    if (!skipcomma())
  1108. X    return NULL;
  1109. X    sp = handlewrite_text(vex, p_expr(NULL), 0);
  1110. X    skipcloseparen();
  1111. X    ex = sp->exp1;
  1112. X    FREE(sp);
  1113. X    if (checkconst(exi, 1)) {
  1114. X        sp = spbase;
  1115. X        while (sp && sp->next)
  1116. X            sp = sp->next;
  1117. X        if (sp && sp->kind == SK_ASSIGN && sp->exp1->kind == EK_ASSIGN &&
  1118. X             (sp->exp1->args[0]->kind == EK_HAT ||
  1119. X              sp->exp1->args[0]->kind == EK_INDEX) &&
  1120. X             exprsame(sp->exp1->args[0]->args[0], vex, 1) &&
  1121. X             checkconst(sp->exp1->args[1], 0)) {
  1122. X            nukestmt(sp);     /* remove preceding bogus setstrlen */
  1123. X        }
  1124. X    }
  1125. X    if (ex->kind == EK_BICALL && !strcmp(ex->val.s, "sprintf") &&
  1126. X        (mp = istempvar(ex->args[0])) != NULL) {
  1127. X        canceltempvar(mp);
  1128. X        ex->args[0] = bumpstring(copyexpr(vex), exi, 1);
  1129. X        sp = makestmt_call(ex);
  1130. X    } else
  1131. X        sp = makestmt_assign(bumpstring(copyexpr(vex), exi, 1), ex);
  1132. X    if (fullstrwrite != 0) {
  1133. X        sp = makestmt_seq(sp, makestmt_assign(exj,
  1134. X                                              makeexpr_plus(makeexpr_bicall_1("strlen", tp_int, vex),
  1135. X                                                            makeexpr_long(1))));
  1136. X        if (fullstrwrite == 1)
  1137. X            note("FullStrWrite=1 not yet supported [204]");
  1138. X        if (fullstrwrite == 2)
  1139. X            note("STRWRITE was used [205]");
  1140. X    } else {
  1141. X        freeexpr(vex);
  1142. X    }
  1143. X    return mixassignments(sp, NULL);
  1144. X}
  1145. X
  1146. X
  1147. X
  1148. XStatic Stmt *proc_str_turbo()
  1149. X{
  1150. X    Expr *ex, *wid, *prec;
  1151. X
  1152. X    if (!skipopenparen())
  1153. X    return NULL;
  1154. X    ex = p_expr(NULL);
  1155. X    wid = NULL;
  1156. X    prec = NULL;
  1157. X    if (curtok == TOK_COLON) {
  1158. X        gettok();
  1159. X        wid = p_expr(tp_integer);
  1160. X        if (curtok == TOK_COLON) {
  1161. X            gettok();
  1162. X            prec = p_expr(tp_integer);
  1163. X        }
  1164. X    }
  1165. X    ex = writeelement(ex, wid, prec, 10);
  1166. X    if (!skipcomma())
  1167. X    return NULL;
  1168. X    wid = p_expr(tp_str255);
  1169. X    skipcloseparen();
  1170. X    return makestmt_assign(wid, ex);
  1171. X}
  1172. X
  1173. X
  1174. X
  1175. XStatic Expr *func_xor()
  1176. X{
  1177. X    Expr *ex, *ex2;
  1178. X    Type *type;
  1179. X    Meaning *tvar;
  1180. X
  1181. X    if (!skipopenparen())
  1182. X    return NULL;
  1183. X    ex = p_expr(NULL);
  1184. X    if (!skipcomma())
  1185. X    return ex;
  1186. X    ex2 = p_expr(ex->val.type);
  1187. X    skipcloseparen();
  1188. X    if (ex->val.type->kind != TK_SET &&
  1189. X    ex->val.type->kind != TK_SMALLSET) {
  1190. X    ex = makeexpr_bin(EK_BXOR, ex->val.type, ex, ex2);
  1191. X    } else {
  1192. X    type = mixsets(&ex, &ex2);
  1193. X    tvar = makestmttempvar(type, name_SET);
  1194. X    ex = makeexpr_bicall_3(setxorname, type,
  1195. X                   makeexpr_var(tvar),
  1196. X                   ex, ex2);
  1197. X    }
  1198. X    return ex;
  1199. X}
  1200. X
  1201. X
  1202. X
  1203. X
  1204. X
  1205. X
  1206. X
  1207. Xvoid decl_builtins()
  1208. X{
  1209. X    makespecialfunc( "ABS",           func_abs);
  1210. X    makespecialfunc( "ADDR",          func_addr);
  1211. X    if (!modula2)
  1212. X    makespecialfunc( "ADDRESS",   func_addr);
  1213. X    makespecialfunc( "ADDTOPOINTER",  func_addtopointer);
  1214. X    makespecialfunc( "ADR",           func_addr);
  1215. X    makespecialfunc( "ASL",          func_lsl);
  1216. X    makespecialfunc( "ASR",          func_asr);
  1217. X    makespecialfunc( "BADDRESS",      func_iaddress);
  1218. X    makespecialfunc( "BAND",          func_uand);
  1219. X    makespecialfunc( "BIN",           func_bin);
  1220. X    makespecialfunc( "BITNEXT",          func_bitnext);
  1221. X    makespecialfunc( "BITSIZE",          func_bitsize);
  1222. X    makespecialfunc( "BITSIZEOF",     func_bitsize);
  1223. Xmp_blockread_ucsd =
  1224. X    makespecialfunc( "BLOCKREAD",     func_blockread);
  1225. Xmp_blockwrite_ucsd =
  1226. X    makespecialfunc( "BLOCKWRITE",    func_blockwrite);
  1227. X    makespecialfunc( "BNOT",          func_unot);
  1228. X    makespecialfunc( "BOR",          func_uor);
  1229. X    makespecialfunc( "BSL",          func_bsl);
  1230. X    makespecialfunc( "BSR",          func_bsr);
  1231. X    makespecialfunc( "BTST",          func_btst);
  1232. X    makespecialfunc( "BXOR",          func_uxor);
  1233. X    makespecialfunc( "BYTEREAD",      func_byteread);
  1234. X    makespecialfunc( "BYTEWRITE",     func_bytewrite);
  1235. X    makespecialfunc( "BYTE_OFFSET",   func_byte_offset);
  1236. X    makespecialfunc( "CHR",           func_chr);         
  1237. X    makespecialfunc( "CONCAT",        func_concat);
  1238. X    makespecialfunc( "DBLE",          func_float);
  1239. Xmp_dec_dec =
  1240. X    makespecialfunc( "DEC",           func_dec);
  1241. X    makespecialfunc( "EOF",           func_eof);
  1242. X    makespecialfunc( "EOLN",          func_eoln);
  1243. X    makespecialfunc( "FCALL",         func_fcall);
  1244. X    makespecialfunc( "FILEPOS",       func_filepos);
  1245. X    makespecialfunc( "FILESIZE",      func_filesize);
  1246. X    makespecialfunc( "FLOAT",          func_float);
  1247. X    makespecialfunc( "HEX",           func_hex);         
  1248. X    makespecialfunc( "HI",            func_hi);
  1249. X    makespecialfunc( "HIWORD",        func_hiword);
  1250. X    makespecialfunc( "HIWRD",         func_hiword);
  1251. X    makespecialfunc( "HIGH",          func_high);
  1252. X    makespecialfunc( "IADDRESS",      func_iaddress);
  1253. X    makespecialfunc( "INT",           func_int);         
  1254. X    makespecialfunc( "LAND",          func_uand);
  1255. X    makespecialfunc( "LNOT",          func_unot);
  1256. X    makespecialfunc( "LO",            func_lo);
  1257. X    makespecialfunc( "LOOPHOLE",      func_loophole);
  1258. X    makespecialfunc( "LOR",          func_uor);
  1259. X    makespecialfunc( "LOWER",          func_lower);
  1260. X    makespecialfunc( "LOWORD",        func_loword);
  1261. X    makespecialfunc( "LOWRD",         func_loword);
  1262. X    makespecialfunc( "LSL",          func_lsl);
  1263. X    makespecialfunc( "LSR",          func_lsr);
  1264. X    makespecialfunc( "MAX",          func_max);
  1265. X    makespecialfunc( "MAXPOS",        func_maxpos);
  1266. X    makespecialfunc( "MIN",          func_min);
  1267. X    makespecialfunc( "NEXT",          func_sizeof);
  1268. X    makespecialfunc( "OCT",           func_oct);
  1269. X    makespecialfunc( "ORD",           func_ord);
  1270. X    makespecialfunc( "ORD4",          func_ord4);
  1271. X    makespecialfunc( "PI",          func_pi);
  1272. X    makespecialfunc( "POSITION",      func_position);
  1273. X    makespecialfunc( "PRED",          func_pred);
  1274. X    makespecialfunc( "QUAD",          func_float);
  1275. X    makespecialfunc( "RANDOM",        func_random);
  1276. X    makespecialfunc( "REF",          func_addr);
  1277. X    makespecialfunc( "SCAN",          func_scan);
  1278. X    makespecialfunc( "SEEKEOF",       func_seekeof);
  1279. X    makespecialfunc( "SEEKEOLN",      func_seekeoln);
  1280. X    makespecialfunc( "SIZE",          func_sizeof);
  1281. X    makespecialfunc( "SIZEOF",        func_sizeof);
  1282. X    makespecialfunc( "SNGL",          func_sngl);
  1283. X    makespecialfunc( "SQR",           func_sqr);
  1284. X    makespecialfunc( "STATUSV",          func_statusv);
  1285. X    makespecialfunc( "SUCC",          func_succ);
  1286. X    makespecialfunc( "TSIZE",         func_sizeof);
  1287. X    makespecialfunc( "UAND",          func_uand);
  1288. X    makespecialfunc( "UDEC",          func_udec);
  1289. X    makespecialfunc( "UINT",          func_uint);         
  1290. X    makespecialfunc( "UNOT",          func_unot);
  1291. X    makespecialfunc( "UOR",          func_uor);
  1292. X    makespecialfunc( "UPPER",          func_upper);
  1293. X    makespecialfunc( "UXOR",          func_uxor);
  1294. Xmp_val_modula =
  1295. X    makespecialfunc( "VAL",          func_val_modula);
  1296. X    makespecialfunc( "WADDRESS",      func_iaddress);
  1297. X    makespecialfunc( "XOR",          func_xor);
  1298. X
  1299. X    makestandardfunc("ARCTAN",        func_arctan);
  1300. X    makestandardfunc("ARCTANH",       func_arctanh);
  1301. X    makestandardfunc("BINARY",        func_binary);      
  1302. X    makestandardfunc("CAP",           func_upcase);
  1303. X    makestandardfunc("COPY",          func_copy);        
  1304. X    makestandardfunc("COS",           func_cos);         
  1305. X    makestandardfunc("COSH",          func_cosh);         
  1306. X    makestandardfunc("EXP",           func_exp);         
  1307. X    makestandardfunc("EXP10",         func_pwroften);
  1308. X    makestandardfunc("EXPO",          func_expo);         
  1309. X    makestandardfunc("FRAC",          func_frac);        
  1310. X    makestandardfunc("INDEX",         func_strpos);      
  1311. X    makestandardfunc("LASTPOS",       NULL);             
  1312. X    makestandardfunc("LINEPOS",       NULL);             
  1313. X    makestandardfunc("LENGTH",        func_strlen);      
  1314. X    makestandardfunc("LN",            func_ln);          
  1315. X    makestandardfunc("LOG",           func_log);
  1316. X    makestandardfunc("LOG10",         func_log);
  1317. X    makestandardfunc("MAXAVAIL",      func_maxavail);
  1318. X    makestandardfunc("MEMAVAIL",      func_memavail);
  1319. X    makestandardfunc("OCTAL",         func_octal);       
  1320. X    makestandardfunc("ODD",           func_odd);         
  1321. X    makestandardfunc("PAD",           func_pad);
  1322. X    makestandardfunc("PARAMCOUNT",    func_paramcount);
  1323. X    makestandardfunc("PARAMSTR",      func_paramstr);    
  1324. X    makestandardfunc("POS",           func_pos);         
  1325. X    makestandardfunc("PTR",           func_ptr);
  1326. X    makestandardfunc("PWROFTEN",      func_pwroften);
  1327. X    makestandardfunc("ROUND",         func_round);       
  1328. X    makestandardfunc("SCANEQ",        func_scaneq);
  1329. X    makestandardfunc("SCANNE",        func_scanne);
  1330. X    makestandardfunc("SIN",           func_sin);         
  1331. X    makestandardfunc("SINH",          func_sinh);         
  1332. X    makestandardfunc("SQRT",          func_sqrt);        
  1333. Xmp_str_hp =
  1334. X    makestandardfunc("STR",           func_str_hp);
  1335. X    makestandardfunc("STRLEN",        func_strlen);      
  1336. X    makestandardfunc("STRLTRIM",      func_strltrim);    
  1337. X    makestandardfunc("STRMAX",        func_strmax);      
  1338. X    makestandardfunc("STRPOS",        func_strpos);      
  1339. X    makestandardfunc("STRRPT",        func_strrpt);      
  1340. X    makestandardfunc("STRRTRIM",      func_strrtrim);    
  1341. X    makestandardfunc("SUBSTR",        func_str_hp);
  1342. X    makestandardfunc("SWAP",          func_swap);        
  1343. X    makestandardfunc("TAN",           func_tan);       
  1344. X    makestandardfunc("TANH",          func_tanh);       
  1345. X    makestandardfunc("TRUNC",         func_trunc);       
  1346. X    makestandardfunc("UPCASE",        func_upcase);      
  1347. X    makestandardfunc("UROUND",        func_uround);
  1348. X    makestandardfunc("UTRUNC",        func_utrunc);
  1349. X
  1350. X    makespecialproc( "APPEND",        proc_append);
  1351. X    makespecialproc( "ARGV",          proc_argv);
  1352. X    makespecialproc( "ASSERT",        proc_assert);
  1353. X    makespecialproc( "ASSIGN",        proc_assign);
  1354. X    makespecialproc( "BCLR",          proc_bclr);
  1355. Xmp_blockread_turbo =
  1356. X    makespecialproc( "BLOCKREAD_TURBO", proc_blockread);
  1357. Xmp_blockwrite_turbo =
  1358. X    makespecialproc( "BLOCKWRITE_TURBO", proc_blockwrite);
  1359. X    makespecialproc( "BREAK",         proc_flush);
  1360. X    makespecialproc( "BSET",          proc_bset);
  1361. X    makespecialproc( "CALL",          proc_call);
  1362. X    makespecialproc( "CLOSE",         proc_close);
  1363. X    makespecialproc( "CONNECT",       proc_assign);
  1364. X    makespecialproc( "CYCLE",          proc_cycle);
  1365. Xmp_dec_turbo =
  1366. X    makespecialproc( "DEC_TURBO",     proc_dec);
  1367. X    makespecialproc( "DISPOSE",       proc_dispose);
  1368. X    makespecialproc( "ESCAPE",        proc_escape);
  1369. X    makespecialproc( "EXCL",          proc_excl);
  1370. X    makespecialproc( "EXIT",          proc_exit);
  1371. X    makespecialproc( "FILLCHAR",      proc_fillchar);
  1372. X    makespecialproc( "FLUSH",         proc_flush);
  1373. X    makespecialproc( "GET",           proc_get);
  1374. X    makespecialproc( "HALT",          proc_escape);
  1375. X    makespecialproc( "INC",           proc_inc);
  1376. X    makespecialproc( "INCL",          proc_incl);
  1377. X    makespecialproc( "LEAVE",          proc_leave);
  1378. X    makespecialproc( "LOCATE",        proc_seek);
  1379. X    makespecialproc( "MESSAGE",       proc_message);
  1380. X    makespecialproc( "MOVE_FAST",     proc_move_fast);        
  1381. X    makespecialproc( "MOVE_L_TO_R",   proc_move_fast);        
  1382. X    makespecialproc( "MOVE_R_TO_L",   proc_move_fast);        
  1383. X    makespecialproc( "NEW",           proc_new);
  1384. X    if (which_lang != LANG_VAX)
  1385. X    makespecialproc( "OPEN",      proc_open);
  1386. X    makespecialproc( "OVERPRINT",     proc_overprint);
  1387. X    makespecialproc( "PACK",          NULL);
  1388. X    makespecialproc( "PAGE",          proc_page);
  1389. X    makespecialproc( "PUT",           proc_put);
  1390. X    makespecialproc( "PROMPT",        proc_prompt);
  1391. X    makespecialproc( "RANDOMIZE",     proc_randomize);
  1392. X    makespecialproc( "READ",          proc_read);
  1393. X    makespecialproc( "READDIR",       proc_readdir);
  1394. X    makespecialproc( "READLN",        proc_readln);
  1395. X    makespecialproc( "READV",         proc_readv);
  1396. X    makespecialproc( "RESET",         proc_reset);
  1397. X    makespecialproc( "REWRITE",       proc_rewrite);
  1398. X    makespecialproc( "SEEK",          proc_seek);
  1399. X    makespecialproc( "SETSTRLEN",     proc_setstrlen);
  1400. X    makespecialproc( "SETTEXTBUF",    proc_settextbuf);
  1401. Xmp_str_turbo =
  1402. X    makespecialproc( "STR_TURBO",     proc_str_turbo);
  1403. X    makespecialproc( "STRAPPEND",     proc_strappend);
  1404. X    makespecialproc( "STRDELETE",     proc_strdelete);
  1405. X    makespecialproc( "STRINSERT",     proc_strinsert);
  1406. X    makespecialproc( "STRMOVE",       proc_strmove);
  1407. X    makespecialproc( "STRREAD",       proc_strread);
  1408. X    makespecialproc( "STRWRITE",      proc_strwrite);
  1409. X    makespecialproc( "UNPACK",        NULL);
  1410. X    makespecialproc( "WRITE",         proc_write);
  1411. X    makespecialproc( "WRITEDIR",      proc_writedir);
  1412. X    makespecialproc( "WRITELN",       proc_writeln);
  1413. X    makespecialproc( "WRITEV",        proc_writev);
  1414. Xmp_val_turbo =
  1415. X    makespecialproc( "VAL_TURBO",     proc_val_turbo);
  1416. X
  1417. X    makestandardproc("DELETE",        proc_delete);      
  1418. X    makestandardproc("FREEMEM",       proc_freemem);     
  1419. X    makestandardproc("GETMEM",        proc_getmem);
  1420. X    makestandardproc("GOTOXY",        proc_gotoxy);      
  1421. X    makestandardproc("INSERT",        proc_insert);      
  1422. X    makestandardproc("MARK",          NULL);             
  1423. X    makestandardproc("MOVE",          proc_move);        
  1424. X    makestandardproc("MOVELEFT",      proc_move);        
  1425. X    makestandardproc("MOVERIGHT",     proc_move);        
  1426. X    makestandardproc("RELEASE",       NULL);             
  1427. X
  1428. X    makespecialvar(  "MEM",           var_mem);
  1429. X    makespecialvar(  "MEMW",          var_memw);
  1430. X    makespecialvar(  "MEML",          var_meml);
  1431. X    makespecialvar(  "PORT",          var_port);
  1432. X    makespecialvar(  "PORTW",         var_portw);
  1433. X
  1434. X    /* Modula-2 standard I/O procedures (case-sensitive!) */
  1435. X    makespecialproc( "Read",          proc_read);
  1436. X    makespecialproc( "ReadCard",      proc_read);
  1437. X    makespecialproc( "ReadInt",       proc_read);
  1438. X    makespecialproc( "ReadReal",      proc_read);
  1439. X    makespecialproc( "ReadString",    proc_read);
  1440. X    makespecialproc( "Write",         proc_write);
  1441. X    makespecialproc( "WriteCard",     proc_writecard);
  1442. X    makespecialproc( "WriteHex",      proc_writehex);
  1443. X    makespecialproc( "WriteInt",      proc_writeint);
  1444. X    makespecialproc( "WriteOct",      proc_writeoct);
  1445. X    makespecialproc( "WriteLn",       proc_writeln);
  1446. X    makespecialproc( "WriteReal",     proc_writereal);
  1447. X    makespecialproc( "WriteString",   proc_write);
  1448. X}
  1449. X
  1450. X
  1451. X
  1452. X
  1453. X/* End. */
  1454. X
  1455. X
  1456. X
  1457. END_OF_FILE
  1458. if test 42271 -ne `wc -c <'src/funcs.c.3'`; then
  1459.     echo shar: \"'src/funcs.c.3'\" unpacked with wrong size!
  1460. fi
  1461. # end of 'src/funcs.c.3'
  1462. fi
  1463. echo shar: End of archive 17 \(of 32\).
  1464. cp /dev/null ark17isdone
  1465. MISSING=""
  1466. 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
  1467.     if test ! -f ark${I}isdone ; then
  1468.     MISSING="${MISSING} ${I}"
  1469.     fi
  1470. done
  1471. if test "${MISSING}" = "" ; then
  1472.     echo You have unpacked all 32 archives.
  1473.     echo "Now see PACKNOTES and the README"
  1474.     rm -f ark[1-9]isdone ark[1-9][0-9]isdone
  1475. else
  1476.     echo You still need to unpack the following archives:
  1477.     echo "        " ${MISSING}
  1478. fi
  1479. ##  End of shell archive.
  1480. exit 0
  1481.