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