home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume20 / fpc / part03 < prev    next >
Text File  |  1989-10-23  |  52KB  |  1,470 lines
  1. Subject:  v20i052:  Portable compiler of the FP language, Part03/06
  2. Newsgroups: comp.sources.unix
  3. Sender: sources
  4. Approved: rsalz@uunet.UU.NET
  5.  
  6. Submitted-by: Edoardo Biagioni <biagioni@cs.unc.edu>
  7. Posting-number: Volume 20, Issue 52
  8. Archive-name: fpc/part03
  9.  
  10. #    This is a shell archive.
  11. #    Remove everything above and including the cut line.
  12. #    Then run the rest of the file through sh.
  13. -----cut here-----cut here-----cut here-----cut here-----
  14. #!/bin/sh
  15. # shar:    Shell Archiver
  16. #    Run the following text with /bin/sh to create:
  17. #    code.c
  18. #    code.h
  19. #    expr.c
  20. echo shar: extracting code.c '(20383 characters)'
  21. sed 's/^XX//' << \SHAR_EOF > code.c
  22. XX/* code.c: produce code for the function encoded by the parse tree. */
  23. XX
  24. XX#include <stdio.h>
  25. XX#include <strings.h>
  26. XX#include "fpc.h"
  27. XX#include "parse.h"
  28. XX#include "code.h"
  29. XX#include "fp.h"
  30. XX
  31. XXstatic fpexpr preoptimize ();
  32. XXstatic void putheader ();
  33. XXstatic void putfinish ();
  34. XX
  35. XXextern void codeexpr ();
  36. XXextern char * sprintf ();
  37. XX
  38. XXstatic int varsneeded;
  39. XXstatic int selneeded;
  40. XX
  41. XX/* assumes that oldname ends in .fp. Returns "" if for some reason
  42. XX   the file should not be opened. */
  43. XXvoid newfname (oldname, newname)
  44. XXchar * oldname, * newname;
  45. XX{
  46. XX  int len;
  47. XX
  48. XX  len = strlen (oldname);
  49. XX  if ((oldname [len - 3] != '.') ||
  50. XX      (oldname [len - 2] != 'f') ||
  51. XX      (oldname [len - 1] != 'p'))
  52. XX  {
  53. XX    *newname = '\0';
  54. XX    return;
  55. XX  }
  56. XX  (void) strcpy (newname, oldname);
  57. XX  newname [len - 2] = 'c';    /* change .fp to .c */
  58. XX  newname [len - 1] = '\0';
  59. XX}
  60. XX
  61. XXvoid code (fun, tree)
  62. XXchar * fun;
  63. XXfpexpr tree;
  64. XX{
  65. XX  tree = preoptimize (tree);
  66. XX  countvars (tree);
  67. XX  putheader (fun, varsneeded, selneeded, tree);
  68. XX  codeexpr (tree, "data", "res");
  69. XX  putfinish (fun);
  70. XX}
  71. XX
  72. XXstatic void putdefine (name, val)
  73. XXchar * name, *val;
  74. XX{
  75. XX  (void) fprintf (outf, "#define %s\t%s\n", name, val);
  76. XX}
  77. XX
  78. XXstatic void putdefnum (name, val)
  79. XXchar * name;
  80. XXint val;
  81. XX{
  82. XX  (void) fprintf (outf, "#define %s\t%d\n", name, val);
  83. XX}
  84. XX
  85. XXstatic void putmain ()
  86. XX{
  87. XX  char inproc [MAXIDLEN], outproc [MAXIDLEN];
  88. XX
  89. XX/* implementation should be refined, for now we don't do -c */
  90. XX  if (check || (makeast && rstring) || traceptr)
  91. XX    (void) fprintf (outf, "#include <stdio.h>\n");
  92. XX  if (makemain && makeast && rstring)
  93. XX    (void) fprintf (outf, "#include <sgtty.h>\n\n");
  94. XX  else
  95. XX    (void) fprintf (outf, "\n");
  96. XX  if (makemain)
  97. XX  {
  98. XX    (void) strcpy (inproc, (rstring ? "getfpstring" : "getfpdata"));
  99. XX    (void) strcpy (outproc, (wstring ? "putfpstrings" : "putfpdata"));
  100. XX    if (makeast)
  101. XX      (void) strcpy (inproc, (rstring ? "getfpchar" : "getfpdata"));
  102. XX    if (redirout)
  103. XX      (void) strcpy (outproc, "putcommands");
  104. XX    (void) fprintf (outf, "main (argc, argv)\nint argc;\nchar * argv [];\n{\n");
  105. XX    (void) fprintf (outf, "  extern fp_data %s (), %s ();\n", inproc, mainfn);
  106. XX    (void) fprintf (outf, "  extern int fpargc;\n  extern char ** fpargv;\n");
  107. XX    if (check)
  108. XX      if (printspace)
  109. XX        (void) fprintf (outf, "  extern void printstorage ();\n");
  110. XX      else
  111. XX        (void) fprintf (outf, "  extern void checkstorage ();\n");
  112. XX    if (makeast)
  113. XX    {
  114. XX      (void) fprintf (outf, "  extern struct fp_object nilobj;\n");
  115. XX      (void) fprintf (outf, "  fp_data state;\n");
  116. XX      (void) fprintf (outf, "  static struct fp_constant initstate = ");
  117. XX      (void) fprintf (outf, "{(short) NILOBJ, (short) 2};\n");
  118. XX      if (rstring)
  119. XX      {
  120. XX        (void) fprintf (outf, "  struct sgttyb newtty, oldtty;\n");
  121. XX        (void) fprintf (outf, "  struct sgttyb * savetty;\n");
  122. XX      }
  123. XX    }
  124. XX    (void) fprintf (outf, "  extern void %s ();\n  fp_data input, result;\n\n",
  125. XX                outproc);
  126. XX    if (makeee || makedeb)
  127. XX      (void) fprintf (outf,
  128. XX              "  (void) fprintf (stderr, \"entering main\\n\");\n");
  129. XX    (void) fprintf (outf, "  fpargc = argc;\n  fpargv = argv;\n");
  130. XX    if (makeast)    /* produce an applicative state transition system */
  131. XX    {
  132. XX      if (rstring)
  133. XX      {
  134. XX        (void) fprintf (outf, "  savetty = &oldtty;\n");
  135. XX        (void) fprintf (outf, "  ioctl (0, TIOCGETP, &oldtty);\n");
  136. XX        (void) fprintf (outf, "  ioctl (0, TIOCGETP, &newtty);\n");
  137. XX        (void) fprintf (outf, "  newtty.sg_flags |= CBREAK;\n");
  138. XX        (void) fprintf (outf, "  ioctl (0, TIOCSETP, &newtty);\n");
  139. XX      }
  140. XX      (void) fprintf (outf, "  state = (fp_data) & initstate;\n");
  141. XX      (void) fprintf (outf, "  input = newpair ();\n");
  142. XX      (void) fprintf (outf, "  input->fp_header.fp_next->fp_entry =");
  143. XX      (void) fprintf (outf, " (fp_data) & nilobj;\n");
  144. XX      (void) fprintf (outf, "  input->fp_entry = & nilobj;\n");
  145. XX      (void) fprintf (outf, "  while (1)\n  {\n");
  146. XX      (void) fprintf (outf, "    result = %s (input);\n", mainfn);
  147. XX      if (check)
  148. XX      {
  149. XX    (void) fprintf (outf, "    if ((result->fp_type != VECTOR) ||\n");
  150. XX    (void) fprintf (outf, "        (result->fp_header.fp_next == 0) ||\n");
  151. XX    (void) fprintf (outf, "        (result->%s != 0))\n",
  152. XX         "fp_header.fp_next->fp_header.fp_next");
  153. XX    (void) fprintf (outf,
  154. XX         "      genbottom (\"non-pair returned in AST\", result);\n");
  155. XX      }
  156. XX      (void) fprintf (outf,
  157. XX              "    state = result->fp_header.fp_next->fp_entry;\n");
  158. XX      (void) fprintf (outf, "    %s (result->fp_entry);\n", outproc);
  159. XX      (void) fprintf (outf, "    if (state->fp_type == NILOBJ)\n");
  160. XX      (void) fprintf (outf, "      break;\n");
  161. XX      (void) fprintf (outf, "    inc_ref (state);\n");
  162. XX      (void) fprintf (outf, "    dec_ref (result);\n");
  163. XX      (void) fprintf (outf, "    input = newpair ();\n");
  164. XX      (void) fprintf (outf,
  165. XX              "    input->fp_header.fp_next->fp_entry = state;\n");
  166. XX      (void) fprintf (outf, "    input->fp_entry = %s ();\n", inproc);
  167. XX      (void) fprintf (outf, "  }\n  dec_ref (result);\n");
  168. XX      if (rstring)
  169. XX        (void) fprintf (outf, "  ioctl (0, TIOCSETP, &oldtty);\n");
  170. XX    }
  171. XX    else    /* normal, non-ast system */
  172. XX    {
  173. XX      if (useparms)
  174. XX      {
  175. XX    (void) fprintf (outf, "  if (fpargc != 1)\n");
  176. XX    (void) fprintf (outf, "    input = & nilobj;\n");
  177. XX    (void) fprintf (outf, "  else\n  ");
  178. XX      }
  179. XX      (void) fprintf (outf, "  input = %s ();\n", inproc);
  180. XX      (void) fprintf (outf, "  result = %s (input);\n", mainfn);
  181. XX      (void) fprintf (outf, "  %s (result);\n", outproc);
  182. XX      (void) fprintf (outf, "  dec_ref (result);\n");
  183. XX    }
  184. XX    if (makeee || makedeb)
  185. XX      (void) fprintf (outf,
  186. XX              "  (void) fprintf (stderr, \"exiting main\\n\");\n");
  187. XX    if (check)
  188. XX      if (printspace)
  189. XX        (void) fprintf (outf, "  printstorage ();\n");
  190. XX      else
  191. XX        (void) fprintf (outf, "  checkstorage ();\n");
  192. XX    (void) fprintf (outf, "  return (0);\n}\n\n");
  193. XX  }
  194. XX}
  195. XX
  196. XXvoid putfileheader (in, out)
  197. XXchar * in;
  198. XXchar * out;
  199. XX{
  200. XX  (void) fprintf (outf, "/* %s: target file generated by fpc from source %s */\n\n",
  201. XX       out, in);
  202. XX  putdefnum ("FALSEOBJ  ", FALSEOBJ);
  203. XX  putdefnum ("TRUEOBJ   ", TRUEOBJ);
  204. XX  putdefnum ("INTCONST  ", INTCONST);
  205. XX  putdefnum ("FLOATCONST", FLOATCONST);
  206. XX  putdefnum ("ATOMCONST ", ATOMCONST);
  207. XX  putdefnum ("CHARCONST ", CHARCONST);
  208. XX  putdefnum ("NILOBJ    ", NILOBJ);
  209. XX  putdefnum ("VECTOR    ", VECTOR);
  210. XX  (void) fprintf (outf, "\ntypedef struct fp_object * fp_data;\n\n");
  211. XX  (void) fprintf (outf,
  212. XX          "struct fp_object\n{\n  short fp_type;\n  short fp_ref;\n");
  213. XX  (void) fprintf (outf, "  union\n  {\n    long fp_int;\n    int fp_char;\n");
  214. XX  (void) fprintf (outf, "    char * fp_atom;\n    float fp_float;\n");
  215. XX  (void) fprintf (outf, "    fp_data fp_next;\n  } fp_header;\n");
  216. XX  (void) fprintf (outf, "  fp_data fp_entry;\n};\n\n");
  217. XX  (void) fprintf (outf, "struct fp_constant\n{\n  short fp_type;\n");
  218. XX  (void) fprintf (outf, "  short fp_ref;\n  %s fp_value;\n", HEADERTYPE);
  219. XX  (void) fprintf (outf, "  fp_data fp_entry;\n};\n\n");
  220. XX  (void) fprintf (outf, "struct fp_floatc\n{\n  short fp_type;\n");
  221. XX  (void) fprintf (outf, "  short fp_ref;\n  %s fp_value;\n};\n\n", HEADERFLOAT);
  222. XX  (void) fprintf (outf, "struct fp_charc\n{\n  short fp_type;\n");
  223. XX  (void) fprintf (outf, "  short fp_ref;\n  %s fp_value;\n};\n\n", HEADERCHAR);
  224. XX  if (check)
  225. XX  {
  226. XX    (void) fprintf (outf, "struct stackframe\n{\n  char * st_name;\n");
  227. XX    (void) fprintf (outf, "  fp_data st_data;\n");
  228. XX    (void) fprintf (outf, "  struct stackframe * st_prev;\n};\n");
  229. XX    (void) fprintf (outf, "extern struct stackframe * stack;\n\n");
  230. XX  }
  231. XX  (void) fprintf (outf, "extern fp_data newvect ();\n");
  232. XX  (void) fprintf (outf, "extern fp_data newpair ();\n");
  233. XX  (void) fprintf (outf, "extern fp_data newcell ();\n");
  234. XX  (void) fprintf (outf, "extern fp_data newconst ();\n");
  235. XX  (void) fprintf (outf, "extern void returnvect ();\n");
  236. XX  (void) fprintf (outf, "extern struct fp_object nilobj;\n");
  237. XX  (void) fprintf (outf, "extern struct fp_object tobj;\n");
  238. XX  (void) fprintf (outf, "extern struct fp_object fobj;\n\n");
  239. XX  if (makedeb || makeee || traceptr)
  240. XX    (void) fprintf (outf, "extern int depthcount;\nextern int indent ();\n\n");
  241. XX  if (makedeb || traceptr)
  242. XX    (void) fprintf (outf, "extern void printfpdata ();\n\n");
  243. XX  if (check)
  244. XX    (void) fprintf (outf, "extern void genbottom ();\n\n");
  245. XX  putdefine ("inc_ref(d)", "((d)->fp_ref++)");
  246. XX  putdefine ("dec_ref(d)",
  247. XX"if (((d)->fp_type == VECTOR) && \\\n\t\t\t\t(--((d)->fp_ref) <= 0)) returnvect (d)");
  248. XX  putdefine ("abs(n)", "((n) < 0 ? - (n) : (n))");
  249. XX  (void) fprintf (outf, "\n");
  250. XX  putmain ();
  251. XX}
  252. XX
  253. XXvoid putfiletail ()
  254. XX{
  255. XX  (void) fprintf (outf, "\n");
  256. XX}
  257. XX
  258. XXstatic void traverse (tree, fn, pre)
  259. XX/* traverses the tree, calling fn on each and every node */
  260. XXfpexpr tree;
  261. XXvoid ((* fn) ());
  262. XXint pre;
  263. XX{
  264. XX  fpexpr save = tree;
  265. XX
  266. XX  if (pre)
  267. XX    (* fn) (tree);
  268. XX  switch (tree->exprtype)
  269. XX  {
  270. XX    case COND:
  271. XX      traverse (tree->fpexprv.conditional [0], (* fn), pre);
  272. XX      traverse (tree->fpexprv.conditional [1], (* fn), pre);
  273. XX      traverse (tree->fpexprv.conditional [2], (* fn), pre);
  274. XX      break;
  275. XX    case BU:
  276. XX    case BUR:
  277. XX      traverse (tree->fpexprv.bulr.bufun, (* fn), pre);
  278. XX      traverse (tree->fpexprv.bulr.buobj, (* fn), pre);
  279. XX      break;
  280. XX    case WHILE:
  281. XX      traverse (tree->fpexprv.whilestat [0], (* fn), pre);
  282. XX      traverse (tree->fpexprv.whilestat [1], (* fn), pre);
  283. XX      break;
  284. XX    case COMP:
  285. XX    case CONSTR:
  286. XX      while (tree != 0)
  287. XX      {
  288. XX        traverse (tree->fpexprv.compconstr.compexpr, (* fn), pre);
  289. XX    tree = tree->fpexprv.compconstr.compnext;
  290. XX      }
  291. XX      break;
  292. XX    case AA:
  293. XX    case INSERT:
  294. XX    case RINSERT:
  295. XX    case TREE:
  296. XX    case MULTI:
  297. XX      traverse (tree->fpexprv.aains, (* fn), pre);
  298. XX      break;
  299. XX    case LIST:
  300. XX      while (tree != 0)
  301. XX      {
  302. XX        traverse (tree->fpexprv.listobj.listel, (* fn), pre);
  303. XX    tree = tree->fpexprv.listobj.listnext;
  304. XX      }
  305. XX      break;
  306. XX    case SEL:
  307. XX    case RSEL:
  308. XX    case FNCALL:
  309. XX    case NIL:
  310. XX    case TRUE:
  311. XX    case FALSE:
  312. XX    case INT:
  313. XX    case FLOAT:
  314. XX    case SYM:
  315. XX    case CHAR:
  316. XX      break;
  317. XX    default:
  318. XX      yyerror ("compiler error 11");
  319. XX  }
  320. XX  if (! pre)
  321. XX   (* fn) (save);
  322. XX}
  323. XX
  324. XXstatic void opt (tree)
  325. XXfpexpr tree;
  326. XX{
  327. XX  if (((tree->exprtype == INSERT) ||
  328. XX       (tree->exprtype == RINSERT) ||
  329. XX       (tree->exprtype == TREE)) &&
  330. XX      (tree->fpexprv.aains->exprtype == FNCALL) &&
  331. XX      ((strcmp (tree->fpexprv.aains->fpexprv.funcall, "plus") == 0) ||
  332. XX       (strcmp (tree->fpexprv.aains->fpexprv.funcall, "times") == 0) ||
  333. XX       (strcmp (tree->fpexprv.aains->fpexprv.funcall, "and") == 0) ||
  334. XX       (strcmp (tree->fpexprv.aains->fpexprv.funcall, "or") == 0)))
  335. XX/* means we can replace the call to insert by a call to MULTI */
  336. XX    tree->exprtype = MULTI;
  337. XX/* wasn't that easy, now? */
  338. XX}
  339. XX
  340. XXstatic fpexpr preoptimize (tree)
  341. XXfpexpr tree;
  342. XX{    /* as long as it doesn't change the meaning of the program,
  343. XX     * everything is fair game here */
  344. XX/* the only optimization we do here is change (insert <f>), where <f>
  345. XX * is one of {plus, times, and, or} to (multi <f>)
  346. XX */
  347. XX  traverse (tree, opt, 0);
  348. XX  return (tree);
  349. XX}
  350. XX
  351. XXstatic int nodevars (tree)
  352. XXfpexpr tree;
  353. XX{
  354. XX  char errbuf [256];
  355. XX
  356. XX  switch (tree->exprtype)
  357. XX  {
  358. XX    case COND:
  359. XX/* a -> b ; c : res := a; if (res) then res := b; else res := c; end */
  360. XX    case FNCALL:
  361. XX/* f: res := f (arg); */
  362. XX    case SEL:
  363. XX/* n: i1 := n; res := arg; while (--i1 > 0) res := cdr (res);
  364. XX      res := car (res); */
  365. XX    case RSEL:
  366. XX/* n: i1 := 0; res := arg; while (res != 0) res := cdr (res); i1++;
  367. XX      i1 := i1 - n; res := arg; while (--i1 != 0) res := cdr (res);
  368. XX      res := car (res); */
  369. XX    case NIL:
  370. XX    case TRUE:
  371. XX    case FALSE:
  372. XX    case INT:
  373. XX    case FLOAT:
  374. XX    case SYM:
  375. XX    case CHAR:
  376. XX    case LIST:    /* called for each list element */
  377. XX      return (0);
  378. XX
  379. XX    case COMP:
  380. XX/* a o b o c o d : r1 := d (arg); r2 := c (r1); r1 := b (r2); res := a (r1); */
  381. XX      if ((tree->fpexprv.compconstr.compnext != 0) &&  /* should never happen */
  382. XX(tree->fpexprv.compconstr.compnext->fpexprv.compconstr.compnext != 0))
  383. XX        return (2);
  384. XX    case CONSTR:
  385. XX/* [a, b] : res := new (2); chase := res; chase->car := b (arg);
  386. XX            chase = cdr (chase); chase->car := a (arg); */
  387. XX    case BU:
  388. XX/* bu  op v : res := v; r1 := newvect (res, arg); res := op (r1); */
  389. XX    case BUR:
  390. XX/* bur op v : res := v; r1 := newvect (arg, res); res := op (r1); */
  391. XX    case MULTI:
  392. XX/* \/f: r1 := arg; res := car (r1);
  393. XX    while (r1 != 0) res := op (res, car (r1)); r1 := cdr (r1); */
  394. XX      return (1);
  395. XX
  396. XX    case RINSERT:
  397. XX/* \a : res := car (arg); r1 := cdr (arg);
  398. XX        while (r1 != 0) r2 := cons (res, cons (car (r1), nil));
  399. XX      res := a (r2); r1 := cdr (r1); */
  400. XX    case AA:
  401. XX/* aa e : if (arg == <>) then res := arg;
  402. XX   else r1 := arg; res := newvect (1); r2 := res;
  403. XX     while (r1 != 0) r2->el := e (car r1); r1 := cdr (r1);
  404. XX       if (r1 != 0) r2->next = newvect (1); r2 = cdr (r2); */
  405. XX    case WHILE:
  406. XX/* while pred f : res := arg;
  407. XX   while (1)
  408. XX      r1 := pred (res); if (! r1) then break; arg := f (res); res := arg; */
  409. XX      return (2);
  410. XX
  411. XX    case INSERT:
  412. XX/* /a : r1 := 0; r2 := arg;
  413. XX    while (r2 != 0) r3 := cons (car (r2), r1); r1 := r3; r2 := cdr (r2);
  414. XX        res := car (r1); r1 := cdr (r1);
  415. XX        while (r1 != 0) r2 := cons (car (r1), cons (res, nil)); res := a (r2);
  416. XX      r1 := cdr (r1); */
  417. XX      return (3);
  418. XX
  419. XX    case TREE:
  420. XX/* \/a: r1 := arg;
  421. XX    while (cdr (r1) != 0)
  422. XX      r2 := r1; r1 := newcell (); r3 := r1;
  423. XX      while (r2 != 0)
  424. XX        if (cdr (r2) == 0) rplaca (r3, car (r2)); r2 := 0;
  425. XX        else
  426. XX          r4 := cons (car (r2), cons (cadr (r2), nil)); r2 := cddr (r2);
  427. XX          rplaca (r3, a(r4));
  428. XX          if (r2 != 0) rplacd (r3, newcell ()); r3 := cdr (r3);
  429. XX    res := car (r1); */
  430. XX      return (5);    /* one more needed for storage management */
  431. XX
  432. XX    default:
  433. XX      (void) sprintf (errbuf, "compiler error 12, type is %d", tree->exprtype);
  434. XX      yyerror (errbuf);
  435. XX      return (-1);
  436. XX  }
  437. XX}
  438. XX
  439. XXstatic void countvar (tree)
  440. XXfpexpr tree;
  441. XX{
  442. XX  varsneeded += nodevars (tree);
  443. XX  selneeded = selneeded ||
  444. XX          (((tree->exprtype == SEL) || (tree->exprtype == RSEL)) &&
  445. XX           (tree->fpexprv.lrsel > 1));
  446. XX}
  447. XX
  448. XXstatic countvars (tree)
  449. XXfpexpr tree;
  450. XX{
  451. XX  varsneeded = 0;
  452. XX  selneeded = 0;
  453. XX  traverse (tree, countvar, 1);
  454. XX}
  455. XX
  456. XXstatic int constcount;
  457. XX
  458. XXstatic void declconst (tree)
  459. XXfpexpr tree;
  460. XX/* traverse procedure called in post-order traversal. It generates a
  461. XX * new "constant variable" for the constant and stores it in the tree.
  462. XX * It also generates a declaration for the constant itself, using
  463. XX * the "constant variables" of the elements in case of lists.
  464. XX * A constant declaration is of the form.
  465. XX * static fp_data cnn = {type, 1, val, entry}
  466. XX */
  467. XX{
  468. XX  static char def1 [] = "  static struct fp_constant ";
  469. XX  static char def2 [] = " =\n                {(short) ";
  470. XX  static char def3 [] = ", (short) 1";
  471. XX  fpexpr next;
  472. XX
  473. XX  if (tree->exprtype >= NIL)
  474. XX  {
  475. XX    (void) sprintf (tree->constvar, "c%d", constcount++);
  476. XX/* we always use a new constant "variable" for a new constant
  477. XX * encountered. That may be updated later to allow sharing of
  478. XX * equal constants, as in equal nil/true/false and (less often)
  479. XX * numbers, strings or lists. Not a high priority item, on V.M.
  480. XX * systems */
  481. XX    switch (tree->exprtype)
  482. XX    {
  483. XX      case FALSE:
  484. XX    (void) fprintf (outf, "%s%s%s%s%s};\n", def1, tree->constvar,
  485. XX             def2, "FALSEOBJ", def3);
  486. XX    break;
  487. XX      case TRUE:
  488. XX    (void) fprintf (outf, "%s%s%s%s%s};\n", def1, tree->constvar,
  489. XX             def2, "TRUEOBJ", def3);
  490. XX    break;
  491. XX      case NIL:
  492. XX    (void) fprintf (outf, "%s%s%s%s%s};\n", def1, tree->constvar,
  493. XX             def2, "NILOBJ", def3);
  494. XX    break;
  495. XX      case INT:
  496. XX    (void) fprintf (outf, "%s%s%s%s%s, (%s) %d};\n", def1, tree->constvar,
  497. XX             def2, "INTCONST", def3, HEADERTYPE,
  498. XX            tree->fpexprv.intobj);
  499. XX    break;
  500. XX      case FLOAT:
  501. XX    (void) fprintf (outf, "%s%s%s%s%s, %lf};\n",
  502. XX            "  static struct fp_floatc ", tree->constvar,
  503. XX             def2, "FLOATCONST", def3, tree->fpexprv.floatobj);
  504. XX    break;
  505. XX      case SYM:
  506. XX    (void) fprintf (outf, "%s%s%s%s%s, (%s) \"%s\"};\n", def1,
  507. XX            tree->constvar, def2, "ATOMCONST", def3,
  508. XX            HEADERTYPE, tree->fpexprv.symbol);
  509. XX    break;
  510. XX      case CHAR:
  511. XX    (void) fprintf (outf, "%s%s%s%s%s, '\\%o'};\n",
  512. XX            "  static struct fp_charc ", tree->constvar,
  513. XX            def2, "CHARCONST", def3, tree->fpexprv.character);
  514. XX    break;
  515. XX      case LIST:
  516. XX    next = tree->fpexprv.listobj.listnext;
  517. XX    if (next != 0)
  518. XX      declconst (next);
  519. XX    (void) fprintf (outf, "%s%s%s%s%s, (%s) %c%s, (fp_data) &%s};\n", def1,
  520. XX             tree->constvar, def2, "VECTOR", def3, HEADERTYPE,
  521. XX             ((next == 0) ? '0' : '&'),
  522. XX             ((next == 0) ? "" : next->constvar),
  523. XX             tree->fpexprv.listobj.listel->constvar);
  524. XX    break;
  525. XX      default:    /* error */
  526. XX        yyerror ("compiler error 13");
  527. XX    }
  528. XX  }    /* else it is not a constant, ignore it */
  529. XX}
  530. XX
  531. XXstatic char externs [MAXIDS] [MAXIDLEN];
  532. XXstatic int extptr;
  533. XX
  534. XXstatic void putoneextern (tree)
  535. XXfpexpr tree;
  536. XX{
  537. XX  int search = 0;
  538. XX  char buf [MAXIDLEN];
  539. XX
  540. XX  if (tree->exprtype == FNCALL)
  541. XX  {
  542. XX    if (strcmp (tree->fpexprv.funcall, "times") == 0)
  543. XX      (void) strcpy (buf, "fptimes");
  544. XX    else
  545. XX      (void) strcpy (buf, tree->fpexprv.funcall);
  546. XX    while ((search < extptr) &&
  547. XX       (strcmp (buf, externs [search]) != 0))
  548. XX      search++;
  549. XX    if (search == extptr)    /* must insert new name */
  550. XX      (void) strcpy (externs [extptr++], buf);
  551. XX  }
  552. XX}
  553. XX
  554. XXstatic void putexterns (tree, fun)
  555. XXfpexpr tree;
  556. XXchar * fun;
  557. XX{
  558. XX  (void) strcpy (externs [0], fun);
  559. XX  extptr = 1;
  560. XX  traverse (tree, putoneextern, 1);
  561. XX  if (extptr > 1)
  562. XX  {
  563. XX    (void) fprintf (outf, "  extern fp_data");
  564. XX    while (--extptr > 0)
  565. XX    {
  566. XX      (void) fprintf (outf, " %s ()%s", externs [extptr],
  567. XX           (extptr == 1) ? ";\n" : ",");
  568. XX      if (((extptr - 1) & DCLEMASK) == DCLEMASK)
  569. XX        (void) fprintf (outf, "\n\t\t");
  570. XX    }
  571. XX  }
  572. XX}
  573. XX
  574. XXstatic int freevar;
  575. XX
  576. XXstatic void declvars (vars, hassel)
  577. XXint vars, hassel;
  578. XX{
  579. XX  freevar = 0;
  580. XX  if (hassel)
  581. XX    (void) fprintf (outf, "  register int sel;\n");
  582. XX  (void) fprintf (outf, "  fp_data");
  583. XX  while (vars-- > 0)
  584. XX  {
  585. XX    (void) fprintf (outf, " d%d,", vars);
  586. XX    if ((vars & DCLMASK) == DCLMASK)
  587. XX      (void) fprintf (outf, "\n\t ");
  588. XX  }
  589. XX  (void) fprintf (outf, " res;\n");
  590. XX  if (check)
  591. XX    (void) fprintf (outf, "  struct stackframe stackentry;\n");
  592. XX  (void) fprintf (outf, "\n");
  593. XX}
  594. XX
  595. XXvoid newvar (buf)
  596. XXchar * buf;
  597. XX{
  598. XX  (void) sprintf (buf, "d%d", freevar++);
  599. XX}
  600. XX
  601. XXstatic int tracingfn;
  602. XX
  603. XXstatic void entertrace (fname)
  604. XXchar * fname;
  605. XX{
  606. XX  if (makeee || makedeb || tracingfn)
  607. XX  {
  608. XX    (void) fprintf (outf,
  609. XX            "  depthcount += 2;\n  indent (depthcount, stderr);\n");
  610. XX    if (makedeb || tracingfn)
  611. XX    {
  612. XX      (void) fprintf (outf, "  (void) fprintf (stderr, \"entering %s, data is\\n\");\n",
  613. XX           fname);
  614. XX      (void) fprintf (outf, "  printfpdata (stderr, data, depthcount);\n");
  615. XX      (void) fprintf (outf, "  (void) fprintf (stderr, \"\\n\");\n");
  616. XX    }
  617. XX    else
  618. XX      (void) fprintf (outf, "  (void) fprintf (stderr, \"entering %s\\n\");\n", fname);
  619. XX  }
  620. XX  if (check)        /* keep the stack */
  621. XX  {
  622. XX    (void) fprintf (outf, "  stackentry.st_prev = stack;\n");
  623. XX    (void) fprintf (outf, "  stackentry.st_data = data;\n  inc_ref (data);\n");
  624. XX    (void) fprintf (outf, "  stackentry.st_name = \"%s\";\n", fname);
  625. XX    (void) fprintf (outf, "  stack = & stackentry;\n", fname);
  626. XX  }
  627. XX}
  628. XX
  629. XXstatic void putheader (fname, vars, hassel, tree)
  630. XXchar * fname;
  631. XXint vars, hassel;
  632. XXfpexpr tree;
  633. XX{
  634. XX  int trace;
  635. XX
  636. XX  for (trace = 0;
  637. XX       (trace < traceptr) && (strcmp (tracefns [trace], fname) != 0);
  638. XX       trace++)
  639. XX    ;
  640. XX  tracingfn = (trace < traceptr);    /* are we tracing this function? */
  641. XX  (void) fprintf (outf, "fp_data %s (data)\nfp_data data;\n{\n", fname);
  642. XX  putexterns (tree, fname);
  643. XX  constcount = 0;
  644. XX  traverse (tree, declconst, 0);    /* declare the static constants */
  645. XX  declvars (vars, hassel);
  646. XX  entertrace (fname);
  647. XX}
  648. XX
  649. XXstatic void putfinish (fname)
  650. XXchar * fname;
  651. XX{
  652. XX  if (makeee || makedeb || tracingfn)
  653. XX  {
  654. XX    (void) fprintf (outf,
  655. XX            "  indent (depthcount, stderr);\n  depthcount -= 2;\n");
  656. XX    if (makedeb || tracingfn)
  657. XX    {
  658. XX      (void) fprintf (outf, "  (void) fprintf (stderr, \"exiting %s, result is\\n\");\n",
  659. XX           fname);
  660. XX      (void) fprintf (outf, "  printfpdata (stderr, res, depthcount);\n");
  661. XX      (void) fprintf (outf, "  (void) fprintf (stderr, \"\\n\");\n");
  662. XX    }
  663. XX    else
  664. XX      (void) fprintf (outf, "  (void) fprintf (stderr, \"exiting %s\\n\");\n", fname);
  665. XX  }
  666. XX  if (check)        /* restore the stack */
  667. XX  {
  668. XX    (void) fprintf (outf, "  dec_ref (data);\n");
  669. XX    (void) fprintf (outf, "  stack = stackentry.st_prev;\n");
  670. XX  }
  671. XX  (void) fprintf (outf, "  return (res);\n}\n\n");
  672. XX  tracingfn = 0;
  673. XX}
  674. SHAR_EOF
  675. if test 20383 -ne "`wc -c code.c`"
  676. then
  677. echo shar: error transmitting code.c '(should have been 20383 characters)'
  678. fi
  679. echo shar: extracting code.h '(843 characters)'
  680. sed 's/^XX//' << \SHAR_EOF > code.h
  681. XX/* code.h: defines the constants used by code.c not declared in parse.h */
  682. XX
  683. XX#define DCLMASK    0x7    /* There will be at most DCLMASK+1 declarations */
  684. XX            /* on a single line. This value only affects */
  685. XX            /* pretty-printing and should be 2^x-1 for some x */
  686. XX
  687. XX#define DCLEMASK 0x3    /* Like DCLMASK, but for externs, which are longer */
  688. XX
  689. XX#define HEADERTYPE "long"
  690. XX            /* this must be a type of the same size as the */
  691. XX            /* largest element of the union {...} fp_header */
  692. XX            /* in the declaration of fp_object. Otherwise, */
  693. XX            /* the declaration of constants will be incorrect */
  694. XX
  695. XX#define HEADERFLOAT "float"    /* this is the type of fp_float */
  696. XX
  697. XX#define HEADERCHAR "int"    /* this is the type of fp_char */
  698. XX
  699. XX#define BRACE (void) fprintf (outf, "%s{\n", indentstr ()); indent (1)
  700. XX
  701. XX#define UNBRACE (void) indent (0); fprintf (outf, "%s}\n", indentstr ())
  702. SHAR_EOF
  703. if test 843 -ne "`wc -c code.h`"
  704. then
  705. echo shar: error transmitting code.h '(should have been 843 characters)'
  706. fi
  707. echo shar: extracting expr.c '(26310 characters)'
  708. sed 's/^XX//' << \SHAR_EOF > expr.c
  709. XX/* expr.c: produce code for the expression encoded by the parse tree. */
  710. XX
  711. XX#include <stdio.h>
  712. XX#include <strings.h>
  713. XX#include "fpc.h"
  714. XX#include "parse.h"
  715. XX#include "code.h"
  716. XX#include "fp.h"
  717. XX
  718. XXextern void newvar ();
  719. XXextern char * sprintf ();
  720. XX
  721. XXstatic void codecond ();
  722. XXstatic void codebu ();
  723. XXstatic void codewhile ();
  724. XXstatic void codecomp ();
  725. XXstatic void codeaa ();
  726. XXstatic void codeconstr ();
  727. XXstatic void codeinsert ();
  728. XXstatic void codesel ();
  729. XXstatic void codefncall ();
  730. XXstatic void codeconst ();
  731. XXstatic void codemulti ();
  732. XX
  733. XXvoid codeexpr (tree, invar, outvar)
  734. XXfpexpr tree;
  735. XXchar * invar, * outvar;
  736. XX{
  737. XX  int type = 0;
  738. XX/* used to distinguish between slightly different functional forms that
  739. XX * use the same procedure to generate code.
  740. XX */
  741. XX
  742. XX  switch (tree->exprtype)
  743. XX  {
  744. XX    case COND:
  745. XX      codecond (tree, invar, outvar);
  746. XX      break;
  747. XX    case BUR:
  748. XX      type++;
  749. XX    case BU:
  750. XX      codebu (tree, type, invar, outvar);
  751. XX      break;
  752. XX    case WHILE:
  753. XX      codewhile (tree, invar, outvar);
  754. XX      break;
  755. XX    case COMP:
  756. XX      codecomp (tree, invar, outvar);
  757. XX      break;
  758. XX    case AA:
  759. XX      codeaa (tree, invar, outvar);
  760. XX      break;
  761. XX    case CONSTR:
  762. XX      codeconstr (tree, invar, outvar);
  763. XX      break;
  764. XX    case TREE:
  765. XX      type++;
  766. XX    case RINSERT:
  767. XX      type++;
  768. XX    case INSERT:
  769. XX      codeinsert (tree, type, invar, outvar);
  770. XX      break;
  771. XX    case MULTI:
  772. XX      codemulti (tree, invar, outvar);
  773. XX      break;
  774. XX    case RSEL:
  775. XX      type++;
  776. XX    case SEL:
  777. XX      codesel (tree, type, invar, outvar);
  778. XX      break;
  779. XX    case FNCALL:
  780. XX      codefncall (tree, invar, outvar);
  781. XX      break;
  782. XX    default:
  783. XX      if ((tree->exprtype >= NIL) && (tree->exprtype <= CHAR))
  784. XX        codeconst (tree, invar, outvar);
  785. XX      else
  786. XX        yyerror ("compiler error 10");
  787. XX  }
  788. XX}
  789. XX
  790. XXstatic int indlev = 1;
  791. XX
  792. XXstatic void indent (plus)
  793. XXint plus;
  794. XX{
  795. XX  if (plus > 0)
  796. XX    indlev++;
  797. XX  else
  798. XX    indlev--;
  799. XX}
  800. XX
  801. XXstatic char * indentstr ()
  802. XX/* returns a reference to a string with 2*indlev blanks. Notice that
  803. XX * successive calls will refer to the same string.... 'nuff said. */
  804. XX{
  805. XX  register char * str;
  806. XX  register int count;
  807. XX  static char blanks [1024] = "";
  808. XX
  809. XX  if (indlev > 511)
  810. XX    yyerror ("error: expression nesting too great");
  811. XX  count = indlev;
  812. XX  for (str = blanks; count > 3; *(str++) = '\t')
  813. XX    count -= 4;
  814. XX  count *= 2;
  815. XX  for ( ; count > 0; *(str++) = ' ')
  816. XX    count -= 1;
  817. XX  *str = '\0';
  818. XX  return (blanks);
  819. XX}
  820. XX
  821. XXstatic void codecond (tree, invar, outvar)
  822. XXfpexpr tree;
  823. XXchar * invar, * outvar;
  824. XX/* a -> b ; c : res := a; if (res) then res := b; else res := c; end */
  825. XX{
  826. XX  (void) fprintf (outf, "%sinc_ref (%s);\n", indentstr (), invar);
  827. XX  codeexpr (tree->fpexprv.conditional [0], invar, outvar);   /* r := a (d); */
  828. XX  (void) fprintf (outf, "%sif (%s->fp_type%s)\n",    /* if (r) */
  829. XX       indentstr (), outvar, (check)? " == TRUEOBJ" : "");
  830. XX  BRACE;
  831. XX  codeexpr (tree->fpexprv.conditional [1], invar, outvar);   /* r := b (d); */
  832. XX  UNBRACE;
  833. XX  (void) fprintf (outf, "%selse", indentstr ()); /* else */
  834. XX  if (check)
  835. XX    (void) fprintf (outf, " if (%s->fp_type == FALSEOBJ)", outvar);
  836. XX  (void) fprintf (outf, "\n");
  837. XX  BRACE;
  838. XX  codeexpr (tree->fpexprv.conditional [2], invar, outvar);   /* r := c (d); */
  839. XX  UNBRACE;
  840. XX  if (check)
  841. XX    (void) fprintf (outf,
  842. XX         "%selse\n%s  genbottom (\"%s\", %s);\n",
  843. XX             indentstr (), indentstr (), "in conditional: non-boolean pred",
  844. XX         outvar);
  845. XX}
  846. XX
  847. XXstatic void codebu (tree, right, invar, outvar)
  848. XXfpexpr tree;
  849. XXint right;
  850. XXchar * invar, * outvar;
  851. XX/* bu  op v : res := v; r1 := newvect (res, arg); res := op (r1);
  852. XX   bur op v : res := v; r1 := newvect (arg, res); res := op (r1); */
  853. XX{
  854. XX  char pair [MAXIDLEN];
  855. XX/* later on should optimize bu/r op x for op in {=, !=, +, -, *, div, mod}
  856. XX * and for x an atomic type */
  857. XX
  858. XX  codeconst (tree->fpexprv.bulr.buobj, "", outvar);
  859. XX  newvar (pair);
  860. XX  (void) fprintf (outf, "%s%s = newpair ();\n", indentstr (), pair);
  861. XX  (void) fprintf (outf, "%s%s->fp_header.fp_next->fp_entry = %s;\n",
  862. XX       indentstr (), pair, (right) ? outvar : invar);
  863. XX  (void) fprintf (outf, "%s%s->fp_entry = %s;\n",
  864. XX       indentstr (), pair, (right) ? invar : outvar);
  865. XX  codeexpr (tree->fpexprv.bulr.bufun, pair, outvar);
  866. XX}
  867. XX
  868. XXstatic void codewhile (tree, invar, outvar)
  869. XXfpexpr tree;
  870. XXchar * invar, * outvar;
  871. XX/* while pred f : res := arg;
  872. XX   while (1)
  873. XX      r1 := pred (res); if (! r1) then break; arg := f (res); res := arg; */
  874. XX{
  875. XX  char predicate [MAXIDLEN];
  876. XX  char result [MAXIDLEN];
  877. XX
  878. XX  newvar (predicate);
  879. XX  newvar (result);
  880. XX  (void) fprintf (outf, "%s%s = %s;\n%swhile (1)\n",
  881. XX              indentstr (), outvar, invar, indentstr ());
  882. XX  BRACE;
  883. XX  (void) fprintf (outf, "%sinc_ref (%s);\n", indentstr (), outvar);
  884. XX  codeexpr (tree->fpexprv.whilestat [0], outvar, predicate);
  885. XX/* notice: need not dec_ref (predicate) since the result is
  886. XX   ALWAYS a boolean, so dec_ref'ing it would make no difference */
  887. XX  (void) fprintf (outf, "%sif (%s %s->fp_type)\n%s  break;\n",
  888. XX       indentstr (), ((check) ? "FALSEOBJ ==" : "!"),
  889. XX       predicate, indentstr ());
  890. XX  if (check)
  891. XX    (void) fprintf (outf, "%selse if (%s->fp_type != TRUEOBJ)\n%s  %s%s);\n",
  892. XX         indentstr (), predicate, indentstr (),
  893. XX         "genbottom (\"predicate for while is not boolean\", ", predicate);
  894. XX  codeexpr (tree->fpexprv.whilestat [1], outvar, result);
  895. XX  (void) fprintf (outf, "%s%s = %s;\n", indentstr (), outvar, result);
  896. XX  UNBRACE;
  897. XX}
  898. XX
  899. XXstatic void codecomp (tree, invar, outvar)
  900. XXfpexpr tree;
  901. XXchar * invar, * outvar;
  902. XX/* a o b o c o d : r1 := d (arg); r2 := c (r1); r1 := b (r2); res := a (r1); */
  903. XX/* we need to alternate use of r1 and r2 since some of the functional forms
  904. XX   will generate wierd code if given the same input and output variable */
  905. XX{
  906. XX  char pass [2] [MAXIDLEN];
  907. XX  char count = 0;
  908. XX
  909. XX  newvar (pass [0]);
  910. XX  if ((tree->fpexprv.compconstr.compnext != 0) &&  /* should never happen */
  911. XX      (tree->fpexprv.compconstr.compnext->fpexprv.compconstr.compnext != 0))
  912. XX/* the second expression will return false if we have (a o b) */
  913. XX    newvar (pass [1]);
  914. XX  while (tree != 0)
  915. XX  {
  916. XX    if (tree->fpexprv.compconstr.compnext != 0)
  917. XX      codeexpr (tree->fpexprv.compconstr.compexpr, invar, pass [count]);
  918. XX    else
  919. XX      codeexpr (tree->fpexprv.compconstr.compexpr, invar, outvar);
  920. XX    invar = pass [count];
  921. XX    count = (count + 1) % 2;
  922. XX    tree = tree->fpexprv.compconstr.compnext;
  923. XX  }
  924. XX}
  925. XX
  926. XXstatic void codeaa (tree, invar, outvar)
  927. XXfpexpr tree;
  928. XXchar * invar, * outvar;
  929. XX/* aa e : if (arg == <>) then res := arg;
  930. XX   else r1 := arg; res := newcell (); r2 := res;
  931. XX     while (r1 != 0) r2->el := e (car r1); r1 := cdr (r1);
  932. XX       if (r1 != 0) r2->next = newcell (); r2 = cdr (r2); */
  933. XX{
  934. XX  char chasearg [MAXIDLEN], chaseres [MAXIDLEN], tempres [MAXIDLEN],
  935. XX       tempval [MAXIDLEN];
  936. XX
  937. XX  (void) fprintf (outf, "%sif (%s->fp_type == NILOBJ)\n%s  %s = %s;\n%selse",
  938. XX       indentstr (), invar, indentstr (), outvar, invar, indentstr ());
  939. XX  if (check)
  940. XX    (void) fprintf (outf, " if (%s->fp_type == VECTOR)", invar);
  941. XX  newvar (chasearg);
  942. XX  newvar (chaseres);
  943. XX  (void) fprintf (outf, "\n");
  944. XX  BRACE;
  945. XX  (void) fprintf (outf, "%s%s = %s;\n%s%s = %s = newcell ();\n",
  946. XX              indentstr (), chasearg, invar,
  947. XX              indentstr (), chaseres, outvar);
  948. XX  (void) fprintf (outf, "%swhile (1)\n", indentstr ());
  949. XX  BRACE;
  950. XX  (void) sprintf (tempres, "%s->fp_entry", chaseres);
  951. XX  (void) sprintf (tempval, "%s->fp_entry", chasearg);
  952. XX  (void) fprintf (outf, "%sinc_ref (%s);\n", indentstr (), tempval);
  953. XX  codeexpr (tree->fpexprv.aains, tempval, tempres);
  954. XX  (void) fprintf (outf, "%sif (%s = %s->fp_header.fp_next)\n",
  955. XX       indentstr (), chasearg, chasearg, indentstr ());
  956. XX  (void) fprintf (outf, "%s  %s = %s->fp_header.fp_next = newcell ();\n",
  957. XX       indentstr (), chaseres, chaseres);
  958. XX  (void) fprintf (outf, "%selse\n%s  break;\n", indentstr (), indentstr ());
  959. XX  UNBRACE;
  960. XX  UNBRACE;
  961. XX  if (check)
  962. XX    (void) fprintf (outf,
  963. XX         "%selse\n%s  genbottom (\"%s\", %s);\n",
  964. XX         indentstr (), indentstr (),
  965. XX         "apply-to-all called with atomic argument", invar);
  966. XX  (void) fprintf (outf, "%sdec_ref (%s);\n", indentstr (), invar);
  967. XX}
  968. XX
  969. XXstatic void codeconstr (tree, invar, outvar)
  970. XXfpexpr tree;
  971. XXchar * invar, * outvar;
  972. XX/* [a, b] : res := new (2); chase := res; chase->car := b (arg);
  973. XX            chase = cdr (chase); chase->car := a (arg); */
  974. XX{
  975. XX  int length;
  976. XX  fpexpr subtree = tree;
  977. XX  char chase [MAXIDLEN];
  978. XX  char tempres [MAXIDLEN];
  979. XX
  980. XX  for (length = 0; subtree != 0; length++)
  981. XX    subtree = subtree->fpexprv.compconstr.compnext;
  982. XX  newvar (chase);
  983. XX  (void) sprintf (tempres, "%s->fp_entry", chase);
  984. XX  if (length > 2)
  985. XX    (void) fprintf (outf, "%s%s = %s = newvect (%d);\n", indentstr (),
  986. XX            outvar, chase, length);
  987. XX  else if (length == 2)
  988. XX    (void) fprintf (outf, "%s%s = %s = newpair ();\n", indentstr (),
  989. XX            outvar, chase);
  990. XX  else
  991. XX    (void) fprintf (outf, "%s%s = %s = newcell ();\n", indentstr (),
  992. XX            outvar, chase);
  993. XX  if (length > 1)
  994. XX    (void) fprintf (outf, "%s%s->fp_ref += %d;\n", indentstr (), invar,
  995. XX            length - 1);
  996. XX  while (tree != 0)
  997. XX  {
  998. XX    codeexpr (tree->fpexprv.compconstr.compexpr, invar, tempres);
  999. XX    tree = tree->fpexprv.compconstr.compnext;
  1000. XX    if (tree != 0)
  1001. XX      (void) fprintf (outf, "%s%s = %s->fp_header.fp_next;\n",
  1002. XX           indentstr (), chase, chase);
  1003. XX  }
  1004. XX}
  1005. XX
  1006. XXstatic void codemulti (tree, invar, outvar)
  1007. XXfpexpr tree;
  1008. XXchar * invar, * outvar;
  1009. XX{
  1010. XX/* multi f: r1 := arg; res := newconst (); res->val := initval;
  1011. XX        while (r1 != 0) res := op (res, car (r1)); r1 := cdr (r1); */
  1012. XX  char var1 [MAXIDLEN];
  1013. XX  int optype;    /* 0 for +, 1 for *, 2 for and, 3 for or */
  1014. XX  int isand;
  1015. XX  int isplus;
  1016. XX  char opchar;    /* + for +, * for * */
  1017. XX
  1018. XX  newvar (var1);
  1019. XX  if (strcmp (tree->fpexprv.aains->fpexprv.funcall, "plus") == 0)
  1020. XX    optype = 0;
  1021. XX  else if (strcmp (tree->fpexprv.aains->fpexprv.funcall, "times") == 0)
  1022. XX    optype = 1;
  1023. XX  else if (strcmp (tree->fpexprv.aains->fpexprv.funcall, "and") == 0)
  1024. XX    optype = 2;
  1025. XX  else if (strcmp (tree->fpexprv.aains->fpexprv.funcall, "or") == 0)
  1026. XX    optype = 3;
  1027. XX  else
  1028. XX    yyerror ("compiler error 20");
  1029. XX  if (check)
  1030. XX  {
  1031. XX    (void) fprintf (outf, "%sif (%s->fp_type != VECTOR)\n",
  1032. XX            indentstr (), invar);
  1033. XX    indent (1);
  1034. XX    (void) fprintf (outf,
  1035. XX"%sgenbottom (\"error in insert: argument not a vector\", %s);\n",
  1036. XX            indentstr (), invar);
  1037. XX    indent (0);
  1038. XX  }
  1039. XX/* multi f: r1 := arg; */
  1040. XX  (void) fprintf (outf, "%s%s = %s;\n", indentstr (), var1, invar);
  1041. XX  if (optype > 1)
  1042. XX  {
  1043. XX    isand = (optype == 2);
  1044. XX/* while ((r1 != 0) && (car (r1) != true[false])) r1 := cdr (r1); */
  1045. XX    (void) fprintf (outf, "%swhile (%s && ", indentstr (), var1);
  1046. XX    if (isand)
  1047. XX      if (check)
  1048. XX        (void) fprintf (outf, "(%s->fp_entry->fp_type == TRUEOBJ))\n", var1);
  1049. XX      else
  1050. XX        (void) fprintf (outf, "%s->fp_entry->fp_type)\n", var1);
  1051. XX    else
  1052. XX      (void) fprintf (outf, "(%s->fp_entry->fp_type == FALSEOBJ))\n", var1);
  1053. XX    indent (1);
  1054. XX    (void) fprintf (outf, "%s%s = %s->fp_header.fp_next;\n", indentstr (),
  1055. XX            var1, var1);
  1056. XX    indent (0);
  1057. XX/* if (r1 == 0) res := default else res := other */
  1058. XX    (void) fprintf (outf, "%sif (%s)\n", indentstr (), var1);
  1059. XX    indent (1);
  1060. XX    if (check)
  1061. XX    {
  1062. XX      (void) fprintf (outf, "%sif (%s->fp_entry->fp_type != %sOBJ)\n",
  1063. XX              indentstr (), var1, (isand ? "FALSE" : "TRUE"));
  1064. XX      indent (1);
  1065. XX      (void) fprintf (outf,
  1066. XX"%sgenbottom (\"error in insert %s: argument not a boolean vector\", %s);\n",
  1067. XX              indentstr (), (isand ? "and" : "or"), invar);
  1068. XX      indent (0);
  1069. XX      (void) fprintf (outf, "%selse\n", indentstr ());
  1070. XX      indent (1);
  1071. XX    }
  1072. XX    (void) fprintf (outf, "%s%s = & %cobj;\n", indentstr (), outvar,
  1073. XX                  (isand ? 'f' : 't'));
  1074. XX    if (check)
  1075. XX      indent (0);
  1076. XX    indent (0);
  1077. XX    (void) fprintf (outf, "%selse\n", indentstr ());
  1078. XX    indent (1);
  1079. XX    (void) fprintf (outf, "%s%s = & %cobj;\n", indentstr (), outvar,
  1080. XX                  (isand ? 't' : 'f'));
  1081. XX    indent (0);
  1082. XX  }
  1083. XX  else        /* numeric */
  1084. XX  {
  1085. XX    isplus = (optype == 0);
  1086. XX    opchar = isplus ? '+' : '*';
  1087. XX/* multi f: r1 := arg; res := newconst (INT); res->val := 0|1; */
  1088. XX    (void) fprintf (outf, "%s%s = newconst (INTCONST);\n", indentstr (),
  1089. XX            outvar);
  1090. XX    (void) fprintf (outf, "%sif (%s->fp_entry->fp_type == INTCONST)\n",
  1091. XX            indentstr (), var1);
  1092. XX    BRACE;
  1093. XX    (void) fprintf (outf, "%s%s->fp_header.fp_int = ", indentstr (), outvar);
  1094. XX    (void) fprintf (outf, "%s->fp_entry->fp_header.fp_int;\n", var1);
  1095. XX/* while (d0 && (d0->car->type == int)) res += d0->car->val; d0 = cdr (d0); */
  1096. XX    (void) fprintf (outf, "%swhile ((%s = %s->fp_header.fp_next) && ",
  1097. XX            indentstr (), var1, var1);
  1098. XX    (void) fprintf (outf, "(%s->fp_entry->fp_type == INTCONST))\n", var1);
  1099. XX    if (check)    /* need to check for arithmetic overflow */
  1100. XX    {
  1101. XX      BRACE;
  1102. XX      if (isplus)
  1103. XX      {
  1104. XX        (void) fprintf (outf, "%sif (((%s->fp_header.fp_int < 0) == ",
  1105. XX                indentstr (), outvar);
  1106. XX        (void) fprintf (outf, "(%s->fp_entry->fp_header.fp_int < 0)) &&\n",
  1107. XX                var1);
  1108. XX      }
  1109. XX      else
  1110. XX        (void) fprintf (outf, "%sif ((%s->fp_header.fp_int != 0) &&\n",
  1111. XX                indentstr (), outvar);
  1112. XX      indent (1);
  1113. XX      indent (1);
  1114. XX      (void) fprintf (outf, "%s((%d %c abs (%s->fp_header.fp_int))",
  1115. XX              indentstr (), MAXINT, (isplus ? '-' : '/'), outvar);
  1116. XX      (void) fprintf (outf, " < abs (%s->fp_entry->fp_header.fp_int)))\n",
  1117. XX              var1);
  1118. XX
  1119. XX      indent (0);
  1120. XX      (void) fprintf (outf, "%sgenbottom (\"overflow in insert %c\", %s);\n",
  1121. XX              indentstr (), opchar, invar);
  1122. XX      indent (0);
  1123. XX    }
  1124. XX    else
  1125. XX      indent (1);
  1126. XX    (void) fprintf (outf, "%s%s->fp_header.fp_int ", indentstr (), outvar);
  1127. XX    (void) fprintf (outf, "%c= %s->fp_entry->fp_header.fp_int;\n",
  1128. XX            opchar, var1);
  1129. XX    if (check)
  1130. XX    {
  1131. XX      UNBRACE;
  1132. XX    }
  1133. XX    else
  1134. XX      indent (0);
  1135. XX    UNBRACE;
  1136. XX    (void) fprintf (outf, "%selse\n", indentstr ());
  1137. XX    indent (1);
  1138. XX    (void) fprintf (outf, "%s%s->fp_header.fp_int = %c;\n", indentstr (),
  1139. XX            outvar, (isplus ? '0' : '1'));
  1140. XX    indent (0);
  1141. XX    (void) fprintf (outf, "%sif (%s)\n", indentstr (), var1);
  1142. XX    BRACE;
  1143. XX    (void) fprintf (outf, "%s%s->fp_header.fp_float =", indentstr (), outvar);
  1144. XX    (void) fprintf (outf, " %s->fp_header.fp_int;\n", outvar);
  1145. XX    (void) fprintf (outf, "%s%s->fp_type = FLOATCONST;\n", indentstr (),
  1146. XX            outvar);
  1147. XX    (void) fprintf (outf, "%swhile (%s)\n", indentstr (), var1);
  1148. XX    BRACE;
  1149. XX    (void) fprintf (outf, "%sif (%s->fp_entry->fp_type == FLOATCONST)\n",
  1150. XX            indentstr (), var1);
  1151. XX    indent (1);
  1152. XX    (void) fprintf (outf, "%s%s->fp_header.fp_float ", indentstr (), outvar);
  1153. XX    (void) fprintf (outf, "%c= %s->fp_entry->fp_header.fp_float;\n",
  1154. XX            opchar, var1);
  1155. XX    indent (0);
  1156. XX    if (check)
  1157. XX    {
  1158. XX      (void) fprintf (outf, "%selse if (%s->fp_entry->fp_type != INTCONST)\n",
  1159. XX              indentstr (), var1);
  1160. XX      indent (1);
  1161. XX      (void) fprintf (outf,
  1162. XX"%sgenbottom (\"error in insert %c: argument not a numeric vector\", %s);\n",
  1163. XX              indentstr (), opchar, invar);
  1164. XX      indent (0);
  1165. XX    }
  1166. XX    (void) fprintf (outf, "%selse\n", indentstr ());
  1167. XX    indent (1);
  1168. XX    (void) fprintf (outf, "%s%s->fp_header.fp_float ", indentstr (), outvar);
  1169. XX    (void) fprintf (outf, "%c= %s->fp_entry->fp_header.fp_int;\n",
  1170. XX            opchar, var1);
  1171. XX    indent (0);
  1172. XX    (void) fprintf (outf, "%s%s = %s->fp_header.fp_next;\n", indentstr (),
  1173. XX            var1, var1);
  1174. XX    UNBRACE;
  1175. XX    UNBRACE;
  1176. XX  }
  1177. XX  (void) fprintf (outf, "%sdec_ref (%s);\n", indentstr (), invar);
  1178. XX}
  1179. XX
  1180. XXstatic void codeinsert (tree, type, invar, outvar)
  1181. XXfpexpr tree;
  1182. XXint type;    /* 0 for left, 1 for right, 2 for tree */
  1183. XXchar * invar, * outvar;
  1184. XX/* /a : r3 := 0; r2 := arg;
  1185. XX    while (r2 != 0) r1 := cons (car (r2), r3); r3 := r1; r2 := cdr (r2);
  1186. XX        res := car (r3); r1 := cdr (r3);
  1187. XX        while (r1 != 0) r2 := cons (car (r1), cons (res, nil));
  1188. XX      res := a (r2); r1 := cdr (r1);
  1189. XX   \a : res := car (arg); r1 := cdr (arg);
  1190. XX        while (r1 != 0) r2 := cons (res, cons (car (r1), nil));
  1191. XX      res := a (r2); r1 := cdr (r1);
  1192. XX   \/a: r1 = arg;
  1193. XX        while (r1->cdr != 0)
  1194. XX          r2 := r1; r1 := newcell (); r3 := r1;
  1195. XX          while (r2 != 0)
  1196. XX            if (r2->cdr == 0) r3->car = r2->car; r2 = 0;
  1197. XX            else
  1198. XX              r4 = newpair (); r4->car = r2->car; r2 = r2->cdr;
  1199. XX              r4->cdr->car = r2->car; r2 = r2->cdr; r3->car = a (r4);
  1200. XX          if (r2 != 0) r3->cdr = newcell (); r3 = r3->cdr;
  1201. XX        res = r1->car; */
  1202. XX{
  1203. XX  char insertname [13];
  1204. XX  char var1 [MAXIDLEN],
  1205. XX       var2 [MAXIDLEN],
  1206. XX       var3 [MAXIDLEN],
  1207. XX       var4 [MAXIDLEN],
  1208. XX       var5 [MAXIDLEN],        /* used for ref count in tree insert */
  1209. XX       argvar [MAXIDLEN],    /* this is the argument to the fn in rins */
  1210. XX       varcar [MAXIDLEN];
  1211. XX
  1212. XX  newvar (var1);
  1213. XX  newvar (var2);
  1214. XX  switch (type)
  1215. XX  {
  1216. XX    case 0:    /* normal insert */
  1217. XX      (void) strcpy (insertname, "left insert");
  1218. XX      newvar (var3);
  1219. XX      (void) strcpy (argvar, var3);
  1220. XX      break;
  1221. XX    case 1:    /* right insert */
  1222. XX      (void) strcpy (insertname, "right insert");
  1223. XX      (void) strcpy (argvar, invar);
  1224. XX      break;
  1225. XX    default:    /* tree insert */
  1226. XX      (void) strcpy (insertname, "tree insert");
  1227. XX      newvar (var3);
  1228. XX      newvar (var4);
  1229. XX      newvar (var5);
  1230. XX      (void) sprintf (varcar, "%s->fp_entry", var3);
  1231. XX      break;
  1232. XX  }
  1233. XX  if (check)
  1234. XX  {
  1235. XX    (void) fprintf (outf, "%sif (%s->fp_type != VECTOR)\n",
  1236. XX                 indentstr (), invar);
  1237. XX    (void) fprintf (outf, "%s  genbottom (\"%s%s\", %s);\n", indentstr (),
  1238. XX            "non-vector passed to ", insertname, invar);
  1239. XX  }
  1240. XX  switch (type)
  1241. XX  {
  1242. XX    case 0:    /* normal insert */
  1243. XX/* r3 := 0; r2 := arg; */
  1244. XX      (void) fprintf (outf, "%s%s = 0;\n%s%s = %s;\n", indentstr (),
  1245. XX                  var3, indentstr (), var2, invar);
  1246. XX/* while (r2 != 0) r1 := cons (car (r2), r3); r3 := r1; r2 := cdr (r2); */
  1247. XX/* i.e., reverse+copy arg into ra. Increment the refs of each element
  1248. XX   of arg, afterwards return arg, and the elements will stay. */
  1249. XX      (void) fprintf (outf, "%swhile (%s)\n", indentstr (), var2);
  1250. XX      BRACE;
  1251. XX      (void) fprintf (outf, "%s%s = newcell ();\n", indentstr (), var1);
  1252. XX      (void) fprintf (outf, "%s%s->fp_header.fp_next = %s;\n",
  1253. XX                     indentstr (), var1, var3);
  1254. XX      (void) fprintf (outf, "%s%s->fp_entry = %s->fp_entry;\n%s%s = %s;\n",
  1255. XX                     indentstr (), var1, var2, indentstr (), var3, var1);
  1256. XX      (void) fprintf (outf, "%sinc_ref (%s->fp_entry);\n", indentstr (), var3);
  1257. XX      (void) fprintf (outf, "%s%s = %s->fp_header.fp_next;\n",
  1258. XX                     indentstr (), var2, var2);
  1259. XX      UNBRACE;
  1260. XX      (void) fprintf (outf, "%sdec_ref (%s);\n", indentstr (), invar);
  1261. XX    case 1:    /* right insert */
  1262. XX/* res := car (arg/r3); r1 := cdr (arg/r3); */
  1263. XX      (void) fprintf (outf, "%s%s = %s->fp_entry;\n", indentstr (),
  1264. XX              outvar, argvar);
  1265. XX      (void) fprintf (outf, "%s%s = %s->fp_header.fp_next;\n", indentstr (),
  1266. XX              var1, argvar);
  1267. XX      (void) fprintf (outf, "%sinc_ref (%s);\n", indentstr (), outvar);
  1268. XX/* while (r1 != 0) r2 := cons (res, cons (car (r1), nil));
  1269. XX           r2 := cons (car (r1), cons (res, nil));
  1270. XX   res := a (r2); r1 := cdr (r1); */
  1271. XX      (void) fprintf (outf, "%swhile (%s)\n",
  1272. XX                  indentstr (), var1);
  1273. XX      BRACE;
  1274. XX      (void) fprintf (outf, "%s%s = newpair ();\n", indentstr (), var2);
  1275. XX      if (type == 0)
  1276. XX      {
  1277. XX    (void) fprintf (outf, "%s%s->fp_header.fp_next->fp_entry = %s;\n",
  1278. XX                indentstr (), var2, outvar);
  1279. XX    (void) fprintf (outf, "%s%s->fp_entry = %s->fp_entry;\n",
  1280. XX                indentstr (), var2, var1);
  1281. XX      }
  1282. XX      else
  1283. XX      {
  1284. XX    (void) fprintf (outf, "%s%s->fp_entry = %s;\n",
  1285. XX                indentstr (), var2, outvar);
  1286. XX    (void) fprintf (outf,
  1287. XX            "%s%s->fp_header.fp_next->fp_entry = %s->fp_entry;\n",
  1288. XX                indentstr (), var2, var1);
  1289. XX      }
  1290. XX      (void) fprintf (outf, "%sinc_ref (%s->fp_entry);\n", indentstr (), var1);
  1291. XX      codeexpr (tree->fpexprv.aains, var2, outvar);
  1292. XX      (void) fprintf (outf, "%s%s = %s->fp_header.fp_next;\n",
  1293. XX                  indentstr (), var1, var1);
  1294. XX      UNBRACE;
  1295. XX      (void) fprintf (outf, "%sdec_ref (%s);\n", indentstr (), argvar);
  1296. XX      break;
  1297. XX    default:    /* tree insert */
  1298. XX/*   \/a: r1 = arg;                            */
  1299. XX      (void) fprintf (outf, "%s%s = %s;\n", indentstr (), var1, invar);
  1300. XX/*        while (r1->cdr != 0)                        */
  1301. XX      (void) fprintf (outf, "%swhile (%s->fp_header.fp_next%s)\n",
  1302. XX              indentstr (), var1, (check ? " != 0" : ""));
  1303. XX      BRACE;
  1304. XX/*          r2 = r1; r1 := r3 := newcell ();                */
  1305. XX      (void) fprintf (outf, "%s%s = %s = %s;\n", indentstr (), var2,
  1306. XX              var5, var1);
  1307. XX      (void) fprintf (outf, "%s%s = %s = newcell ();\n", indentstr (),
  1308. XX              var1, var3);
  1309. XX/*          while (r2 != 0)                        */
  1310. XX      (void) fprintf (outf, "%swhile (%s%s)\n", indentstr (), var2,
  1311. XX              (check ? " != 0" : ""));
  1312. XX      indent (1);
  1313. XX/*            if (r2->cdr == 0) r3->car := r2->car; r2 := 0;        */
  1314. XX/*            else                            */
  1315. XX      (void) fprintf (outf, "%sif (%s->fp_header.fp_next == 0)\n",
  1316. XX              indentstr (), var2);
  1317. XX      BRACE;
  1318. XX      (void) fprintf (outf, "%s%s->fp_entry = %s->fp_entry;\n",
  1319. XX              indentstr (), var3, var2);
  1320. XX      (void) fprintf (outf, "%sinc_ref (%s->fp_entry);\n", indentstr (), var2);
  1321. XX      (void) fprintf (outf, "%s%s = 0;\n", indentstr (), var2);
  1322. XX      UNBRACE;
  1323. XX      (void) fprintf (outf, "%selse\n", indentstr ());
  1324. XX      BRACE;
  1325. XX/*              r4 := newpair (); r4->car := r2->car; r2 := r2->cdr;    */
  1326. XX      (void) fprintf (outf, "%s%s = newpair ();\n", indentstr (), var4);
  1327. XX      (void) fprintf (outf, "%s%s->fp_entry = %s->fp_entry;\n",
  1328. XX              indentstr (), var4, var2);
  1329. XX      (void) fprintf (outf, "%sinc_ref (%s->fp_entry);\n", indentstr (), var2);
  1330. XX      (void) fprintf (outf, "%s%s = %s->fp_header.fp_next;\n",
  1331. XX              indentstr (), var2, var2);
  1332. XX/*              r4->cdr->car := r2->car; r2 := r2->cdr; r3->car := a (r4); */
  1333. XX      (void) fprintf (outf,
  1334. XX              "%s%s->fp_header.fp_next->fp_entry = %s->fp_entry;\n",
  1335. XX              indentstr (), var4, var2);
  1336. XX      (void) fprintf (outf, "%sinc_ref (%s->fp_entry);\n", indentstr (), var2);
  1337. XX      (void) fprintf (outf, "%s%s = %s->fp_header.fp_next;\n",
  1338. XX              indentstr (), var2, var2);
  1339. XX      codeexpr (tree->fpexprv.aains, var4, varcar);
  1340. XX/*          if (r2 != 0) r3->cdr := newcell (); r3 := r3->cdr;    */
  1341. XX      (void) fprintf (outf, "%sif (%s%s)\n", indentstr (), var2,
  1342. XX              (check ? " != 0" : ""));
  1343. XX      (void) fprintf (outf,
  1344. XX              "%s  %s = %s->fp_header.fp_next = newcell ();\n",
  1345. XX              indentstr (), var3, var3);
  1346. XX/*        res := r1->car;                        */
  1347. XX      UNBRACE;
  1348. XX      indent (0);
  1349. XX      (void) fprintf (outf, "%sdec_ref (%s);\n", indentstr (), var5);
  1350. XX      UNBRACE;
  1351. XX      (void) fprintf (outf, "%s%s = %s->fp_entry;\n",
  1352. XX              indentstr (), outvar, var1);
  1353. XX      (void) fprintf (outf, "%sinc_ref (%s);\n", indentstr (), outvar);
  1354. XX      (void) fprintf (outf, "%sdec_ref (%s);\n", indentstr (), var1);
  1355. XX      break;
  1356. XX  }
  1357. XX}
  1358. XX
  1359. XXstatic void codesel (tree, right, invar, outvar)
  1360. XXfpexpr tree;
  1361. XXint right;
  1362. XXchar * invar, * outvar;
  1363. XX/* n: i1 := n; r := d; while (--i1 != 0) r := cdr (r);
  1364. XX      r := car (r);
  1365. XX  nr: i1 := 0; r := d; while (r != 0) r := cdr (r); i1++;
  1366. XX      i1 := i1 - (n - 1); r := d; while (--i1 != 0) r := cdr (r);
  1367. XX      r := car (r); */
  1368. XX/* notice that selectors of 1 are special cases, since they occurr
  1369. XX * very frequently and can be optimized a bit */
  1370. XX{
  1371. XX  char * ind;
  1372. XX  char * errmess = "argument too short for ";
  1373. XX  char checkstr [256];
  1374. XX  int selector;
  1375. XX
  1376. XX  checkstr [0] = '\0';
  1377. XX  selector = tree->fpexprv.lrsel;
  1378. XX  ind = indentstr ();
  1379. XX  if (check)
  1380. XX  {
  1381. XX    (void) fprintf (outf, "%sif (%s->fp_type != VECTOR)\n", ind, invar);
  1382. XX    (void) fprintf (outf,
  1383. XX         "%s  genbottom (\"selector %d%s applied to nonvector\", %s);\n",
  1384. XX         ind, selector, (right) ? "r" : "", invar);
  1385. XX  }
  1386. XX  if (selector == 1)        /* first or last */
  1387. XX  {
  1388. XX    if (right)            /* last: common special case */
  1389. XX    {
  1390. XX      (void) fprintf (outf, "%s%s = %s;\n", ind, outvar, invar); /* r := d; */
  1391. XX      (void) fprintf (outf,            /* while (cdr (r) != 0) */
  1392. XX                     "%swhile (%s->fp_header.fp_next)\n", ind, outvar);
  1393. XX      (void) fprintf (outf,            /* r = cdr (r); */
  1394. XX                     "%s  %s = %s->fp_header.fp_next;\n", ind,
  1395. XX              outvar, outvar);
  1396. XX      (void) fprintf (outf,            /* r = car (r); */
  1397. XX                     "%s%s = %s->fp_entry;\n", ind, outvar, outvar);
  1398. XX    }
  1399. XX    else            /* first: *very* common special case */
  1400. XX/* r := car (d); */
  1401. XX      (void) fprintf (outf, "%s%s = %s->fp_entry;\n", ind, outvar, invar);
  1402. XX  }
  1403. XX  else        /* selector != 1, general (i.e., non-special) case */
  1404. XX  {
  1405. XX    /* i1 := 1 or i1 := n */
  1406. XX    (void) fprintf (outf, "%ssel = %d;\n", ind, (right) ? 1 : selector);
  1407. XX    if (right)
  1408. XX    {
  1409. XX      (void) fprintf (outf, "%s%s = %s;\n", ind, outvar, invar); /* r := d; */
  1410. XX      (void) fprintf (outf,        /* while ((r = cdr (r)) != 0) i1++; */
  1411. XX                     "%swhile (%s = %s->fp_header.fp_next)\n%s  sel++;\n",
  1412. XX                     ind, outvar, outvar, ind);
  1413. XX      if (check)
  1414. XX        (void) fprintf (outf,
  1415. XX            "%sif (sel < %d)\n%s  genbottom (\"%s%dr\", %s);\n",
  1416. XX                    ind, selector, ind, errmess, selector, invar);
  1417. XX  /* i1 := i1 - (n - 1); */
  1418. XX      (void) fprintf (outf, "%ssel -= %d;\n", ind, selector - 1);
  1419. XX    }
  1420. XX    (void) fprintf (outf, "%s%s = %s;\n", ind, outvar, invar);    /* r := d; */
  1421. XX    if (check && (! right))
  1422. XX      (void) sprintf (checkstr,
  1423. XX"if (%s == 0)\n%s    genbottom (\"%ssel %d\", %s);\n%s  else\n%s    ",
  1424. XX                     outvar, ind, errmess, selector, invar, ind, ind);
  1425. XX      /* while (--i1 != 0) r := cdr (r); */
  1426. XX    (void) fprintf (outf,
  1427. XX                 "%swhile (--sel)\n%s  %s%s = %s->fp_header.fp_next;\n",
  1428. XX                 ind, ind, checkstr, outvar, outvar);
  1429. XX    /*  r := car (r); */
  1430. XX    if (check && (! right))
  1431. XX      (void) fprintf (outf,
  1432. XX              "%sif (%s == 0)\n%s  genbottom (\"%ssel %d\", %s);\n",
  1433. XX                     ind, outvar, ind, errmess, selector, invar);
  1434. XX    (void) fprintf (outf, "%s%s = %s->fp_entry;\n", ind, outvar, outvar);
  1435. XX  }
  1436. XX  (void) fprintf (outf, "%sinc_ref (%s);\n%sdec_ref (%s);\n",
  1437. XX             ind, outvar, ind, invar);
  1438. XX}
  1439. XX
  1440. XXstatic void codefncall (tree, invar, outvar)
  1441. XXfpexpr tree;
  1442. XXchar * invar, * outvar;
  1443. XX/* f: res := f (arg); */
  1444. XX{
  1445. XX  if (strcmp (tree->fpexprv.funcall, "times") == 0)
  1446. XX    (void) fprintf (outf, "%s%s = %s (%s);\n",
  1447. XX            indentstr (), outvar, "fptimes", invar);
  1448. XX  else
  1449. XX    (void) fprintf (outf, "%s%s = %s (%s);\n",
  1450. XX            indentstr (), outvar, tree->fpexprv.funcall, invar);
  1451. XX}
  1452. XX
  1453. XXstatic void codeconst (tree, invar, outvar)
  1454. XXfpexpr tree;
  1455. XXchar * invar, * outvar;
  1456. XX{
  1457. XX  if (*invar != '\0')
  1458. XX    (void) fprintf (outf, "%sdec_ref (%s);\n", indentstr (), invar);
  1459. XX  (void) fprintf (outf, "%s%s = (fp_data) & (%s);\n%sinc_ref (%s);\n",
  1460. XX       indentstr (), outvar, tree->constvar, indentstr (), outvar);
  1461. XX}
  1462. SHAR_EOF
  1463. if test 26310 -ne "`wc -c expr.c`"
  1464. then
  1465. echo shar: error transmitting expr.c '(should have been 26310 characters)'
  1466. fi
  1467. #    End of shell archive
  1468. exit 0
  1469.  
  1470.