home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / unix / volume20 / fpc / part04 < prev    next >
Encoding:
Internet Message Format  |  1989-10-23  |  42.8 KB
  1. Subject:  v20i053:  Portable compiler of the FP language, Part04/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 53
  8. Archive-name: fpc/part04
  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. #    fp.c.part2
  18. #    mkffp.c
  19. echo shar: extracting fp.c.part2 '(34144 characters)'
  20. sed 's/^XX//' << \SHAR_EOF > fp.c.part2
  21. XX
  22. XXfp_data apndr (data)
  23. XXfp_data data;
  24. XX{
  25. XX  register fp_data vector, el, res, prev, next;
  26. XX
  27. XX#ifdef DEBUG
  28. XX  (void) fprintf (stderr, "entering apndr, object is ");
  29. XX  printfpdata (stderr, data, 0);
  30. XX  (void) putc ('\n', stderr);
  31. XX#endif
  32. XX#ifndef NOCHECK
  33. XX  if (data->fp_type != VECTOR)
  34. XX    genbottom ("apndr: input is not a vector", data);
  35. XX  if ((data->fp_header.fp_next == 0) ||
  36. XX      (data->fp_header.fp_next->fp_header.fp_next != 0))
  37. XX    genbottom ("apndr: input is not a 2-element vector", data);
  38. XX#endif
  39. XX  vector = data->fp_entry;
  40. XX  el = data->fp_header.fp_next->fp_entry;
  41. XX#ifndef NOCHECK
  42. XX  if (nonvector (vector))
  43. XX    genbottom ("apndr: 1st element is not a vector or nil", data);
  44. XX#endif
  45. XX  if (vector->fp_type != VECTOR)        /* nil? */
  46. XX    vector = 0;
  47. XX  prev = 0;        /* copy the first argument */
  48. XX  while (vector != 0)
  49. XX  {
  50. XX    next = newcell ();
  51. XX    if (vector != data->fp_entry)
  52. XX      prev->fp_header.fp_next = next;
  53. XX    else
  54. XX      res = next;
  55. XX    next->fp_entry = vector->fp_entry;
  56. XX    inc_ref (next->fp_entry);
  57. XX    prev = next;
  58. XX    vector = vector->fp_header.fp_next;
  59. XX  }
  60. XX  next = newcell ();    /* cons the second argument to the right */
  61. XX  next->fp_entry = el;
  62. XX  inc_ref (el);
  63. XX  if (prev == 0)
  64. XX    res = next;
  65. XX  else
  66. XX    prev->fp_header.fp_next = next;
  67. XX  dec_ref (data);
  68. XX#ifdef DEBUG
  69. XX  (void) fprintf (stderr, "exiting apndr, result is ");
  70. XX  printfpdata (stderr, res, 0);
  71. XX  (void) putc ('\n', stderr);
  72. XX#endif
  73. XX  return (res);
  74. XX}
  75. XX
  76. XXvoid parmbot (fname, errdesc, data)
  77. XXchar * fname;
  78. XXchar * errdesc;
  79. XXfp_data data;
  80. XX{
  81. XX  char buffer [100];
  82. XX
  83. XX  (void) strcpy (buffer, fname);
  84. XX  (void) strcat (buffer, ": ");
  85. XX  (void) strcat (buffer, errdesc);
  86. XX  genbottom (buffer, data);
  87. XX}
  88. XX
  89. XXint compare ();
  90. XX
  91. XXint compvectors (v1, v2)
  92. XXfp_data v1, v2;
  93. XX/* like compare, but for v1, v2 assumed vectors or 0 (not checked) */
  94. XX{
  95. XX  register int tempres;
  96. XX
  97. XX  if (v1 == v2)
  98. XX    return (0);
  99. XX  if (v1 == 0)
  100. XX    return (- 1);
  101. XX  if (v2 == 0)
  102. XX    return (1);
  103. XX/* compare the heads */
  104. XX  if ((tempres = compare (v1->fp_entry, v2->fp_entry)) != 0)
  105. XX    return (tempres);
  106. XX/* heads are same, compare tails */
  107. XX  return (compvectors (v1->fp_header.fp_next, v2->fp_header.fp_next));
  108. XX}
  109. XX
  110. XXint compare (op1, op2)
  111. XXfp_data op1, op2;
  112. XX/* compares the two objects (numbers, symbols, nil, true, false, vectors)
  113. XX * in data and returns an int > 0, = 0 or < 0 depending on the first being
  114. XX * greater, equal to or less than the second. Also takes care
  115. XX * of error messages. Returns the input data.
  116. XX * notice: F < T < num < atom < char < nil < vector
  117. XX */
  118. XX{
  119. XX  register int result = 0;
  120. XX  register int type1, type2;
  121. XX  register float num1, num2;
  122. XX  register float eps;
  123. XX#define ONEPLUSEPSILON 1.0001
  124. XX#define ONEMINUSEPSILON (2.0 - ONEPLUSEPSILON)
  125. XX
  126. XX  type1 = op1->fp_type;
  127. XX  type2 = op2->fp_type;
  128. XX  if ((type1 == type2) && (type1 != FLOATCONST))
  129. XX            /* floats are handled in the else if */
  130. XX    switch (type1)
  131. XX    {
  132. XX      case INTCONST:
  133. XX        return (op1->fp_header.fp_int - op2->fp_header.fp_int);
  134. XX      case CHARCONST:
  135. XX    return (op1->fp_header.fp_char - op2->fp_header.fp_char);
  136. XX      case ATOMCONST:
  137. XX    result = strcmp (op1->fp_header.fp_atom, op2->fp_header.fp_atom);
  138. XX    break;
  139. XX      case VECTOR:    /* use an arbitrary ordering! */
  140. XX    result = compvectors (op1, op2);
  141. XX    break;
  142. XX      default:        /* nil, true, false */
  143. XX    /* do nothing, equality of types implies equality of data */
  144. XX    ;
  145. XX    }
  146. XX  else if (((type1 == INTCONST) || (type1 == FLOATCONST)) &&
  147. XX       ((type2 == INTCONST) || (type2 == FLOATCONST)))
  148. XX  {
  149. XX    num1 = ((type1 == INTCONST) ? op1->fp_header.fp_int :
  150. XX                  op1->fp_header.fp_float);
  151. XX    num2 = ((type2 == INTCONST) ? op2->fp_header.fp_int :
  152. XX                  op2->fp_header.fp_float);
  153. XX    eps = (num1 >= 0.0) ? ONEPLUSEPSILON : ONEMINUSEPSILON;
  154. XX    if ((num1 * eps) < num2)
  155. XX      result = -1;
  156. XX    else if ((num1 / eps) > num2)
  157. XX      result = 1;
  158. XX    else
  159. XX      result = 0;
  160. XX  }
  161. XX  else if (type1 < type2)
  162. XX    result = -1;
  163. XX  else if (type1 > type2)
  164. XX    result = 1;
  165. XX  else
  166. XX    result = 0;
  167. XX  return (result);
  168. XX}
  169. XX
  170. XXfp_data eq (data)
  171. XXfp_data data;
  172. XX{
  173. XX  register fp_data res;
  174. XX
  175. XX#ifdef DEBUG
  176. XX  (void) fprintf (stderr, "entering eq, object is ");
  177. XX  printfpdata (stderr, data, 0);
  178. XX  (void) putc ('\n', stderr);
  179. XX#endif
  180. XX  checkpair (data, "eq");
  181. XX  if (compare (data->fp_entry, data->fp_header.fp_next->fp_entry) == 0)
  182. XX    res = fp_true;
  183. XX  else
  184. XX    res = fp_false;
  185. XX  dec_ref (data);
  186. XX#ifdef DEBUG
  187. XX  (void) fprintf (stderr, "exiting eq, result is ");
  188. XX  printfpdata (stderr, res, 0);
  189. XX  (void) putc ('\n', stderr);
  190. XX#endif
  191. XX  return (res);
  192. XX}
  193. XX
  194. XXfp_data notequal (data)
  195. XXfp_data data;
  196. XX{
  197. XX  register fp_data res;
  198. XX
  199. XX#ifdef DEBUG
  200. XX  (void) fprintf (stderr, "entering notequal, object is ");
  201. XX  printfpdata (stderr, data, 0);
  202. XX  (void) putc ('\n', stderr);
  203. XX#endif
  204. XX  checkpair (data, "eq");
  205. XX  if (compare (data->fp_entry, data->fp_header.fp_next->fp_entry) != 0)
  206. XX    res = fp_true;
  207. XX  else
  208. XX    res = fp_false;
  209. XX  dec_ref (data);
  210. XX#ifdef DEBUG
  211. XX  (void) fprintf (stderr, "exiting notequal, result is ");
  212. XX  printfpdata (stderr, res, 0);
  213. XX  (void) putc ('\n', stderr);
  214. XX#endif
  215. XX  return (res);
  216. XX}
  217. XX
  218. XXfp_data lequal (data)
  219. XXfp_data data;
  220. XX{
  221. XX  register fp_data res;
  222. XX
  223. XX#ifdef DEBUG
  224. XX  (void) fprintf (stderr, "entering lequal, object is ");
  225. XX  printfpdata (stderr, data, 0);
  226. XX  (void) putc ('\n', stderr);
  227. XX#endif
  228. XX  checkpair (data, "lequal");
  229. XX  if (compare (data->fp_entry, data->fp_header.fp_next->fp_entry) <= 0)
  230. XX    res = fp_true;
  231. XX  else
  232. XX    res = fp_false;
  233. XX  dec_ref (data);
  234. XX#ifdef DEBUG
  235. XX  (void) fprintf (stderr, "exiting lequal, result is ");
  236. XX  printfpdata (stderr, res, 0);
  237. XX  (void) putc ('\n', stderr);
  238. XX#endif
  239. XX  return (res);
  240. XX}
  241. XX
  242. XXfp_data less (data)
  243. XXfp_data data;
  244. XX{
  245. XX  register fp_data res;
  246. XX
  247. XX#ifdef DEBUG
  248. XX  (void) fprintf (stderr, "entering less, object is ");
  249. XX  printfpdata (stderr, data, 0);
  250. XX  (void) putc ('\n', stderr);
  251. XX#endif
  252. XX  checkpair (data, "less");
  253. XX  if (compare (data->fp_entry, data->fp_header.fp_next->fp_entry) < 0)
  254. XX    res = fp_true;
  255. XX  else
  256. XX    res = fp_false;
  257. XX  dec_ref (data);
  258. XX#ifdef DEBUG
  259. XX  (void) fprintf (stderr, "exiting less, result is ");
  260. XX  printfpdata (stderr, res, 0);
  261. XX  (void) putc ('\n', stderr);
  262. XX#endif
  263. XX  return (res);
  264. XX}
  265. XX
  266. XXfp_data gequal (data)
  267. XXfp_data data;
  268. XX{
  269. XX  register fp_data res;
  270. XX
  271. XX#ifdef DEBUG
  272. XX  (void) fprintf (stderr, "entering gequal, object is ");
  273. XX  printfpdata (stderr, data, 0);
  274. XX  (void) putc ('\n', stderr);
  275. XX#endif
  276. XX  checkpair (data, "gequal");
  277. XX  if (compare (data->fp_entry, data->fp_header.fp_next->fp_entry) >= 0)
  278. XX    res = fp_true;
  279. XX  else
  280. XX    res = fp_false;
  281. XX  dec_ref (data);
  282. XX#ifdef DEBUG
  283. XX  (void) fprintf (stderr, "exiting gequal, result is ");
  284. XX  printfpdata (stderr, res, 0);
  285. XX  (void) putc ('\n', stderr);
  286. XX#endif
  287. XX  return (res);
  288. XX}
  289. XX
  290. XXfp_data greater (data)
  291. XXfp_data data;
  292. XX{
  293. XX  register fp_data res;
  294. XX
  295. XX#ifdef DEBUG
  296. XX  (void) fprintf (stderr, "entering greater, object is ");
  297. XX  printfpdata (stderr, data, 0);
  298. XX  (void) putc ('\n', stderr);
  299. XX#endif
  300. XX  checkpair (data, "greater");
  301. XX  if (compare (data->fp_entry, data->fp_header.fp_next->fp_entry) > 0)
  302. XX    res = fp_true;
  303. XX  else
  304. XX    res = fp_false;
  305. XX  dec_ref (data);
  306. XX#ifdef DEBUG
  307. XX  (void) fprintf (stderr, "exiting greater, result is ");
  308. XX  printfpdata (stderr, res, 0);
  309. XX  (void) putc ('\n', stderr);
  310. XX#endif
  311. XX  return (res);
  312. XX}
  313. XX
  314. XX#ifndef NOCHECK
  315. XXvoid checkarith (data, fname)
  316. XXfp_data data;
  317. XXchar * fname;
  318. XX{
  319. XX#ifdef DEBUG
  320. XX  (void) fprintf (stderr, "entering %s, object is ", fname);
  321. XX  printfpdata (stderr, data, 0);
  322. XX  (void) putc ('\n', stderr);
  323. XX#endif
  324. XX  if (data->fp_type != VECTOR)
  325. XX    parmbot (fname, "input is not a vector", data);
  326. XX  if ((data->fp_header.fp_next == 0) ||
  327. XX      (data->fp_header.fp_next->fp_header.fp_next != 0))
  328. XX    parmbot (fname, "input is not a 2-element vector", data);
  329. XX  if ((data->fp_entry->fp_type != INTCONST) &&
  330. XX      (data->fp_entry->fp_type != FLOATCONST))
  331. XX    parmbot (fname, "1st argument is not a number", data);
  332. XX  if ((data->fp_header.fp_next->fp_entry->fp_type != INTCONST) &&
  333. XX      (data->fp_header.fp_next->fp_entry->fp_type != FLOATCONST))
  334. XX    parmbot (fname, "second argument is not a number", data);
  335. XX}
  336. XX
  337. XX#endif
  338. XX
  339. XXfp_data plus (data)
  340. XXfp_data data;
  341. XX{
  342. XX  register fp_data res;
  343. XX  register float op1, op2;
  344. XX  register int isint = 1;
  345. XX
  346. XX#ifndef NOCHECK
  347. XX  checkarith (data, "plus");
  348. XX#endif
  349. XX  if (data->fp_header.fp_next->fp_entry->fp_type == INTCONST)
  350. XX    op2 = data->fp_header.fp_next->fp_entry->fp_header.fp_int;
  351. XX  else
  352. XX  {
  353. XX    isint = 0;
  354. XX    op2 = data->fp_header.fp_next->fp_entry->fp_header.fp_float;
  355. XX  }
  356. XX  if (data->fp_entry->fp_type == INTCONST)
  357. XX    op1 = data->fp_entry->fp_header.fp_int;
  358. XX  else
  359. XX  {
  360. XX    isint = 0;
  361. XX    op1 = data->fp_entry->fp_header.fp_float;
  362. XX  }
  363. XX#ifndef NOCHECK
  364. XX  if (isint && ((op1 < 0) == (op2 < 0)) &&
  365. XX      ((MAXINT - abs (op1)) < abs (op2)))
  366. XX    genbottom ("plus: overflow or underflow", data);
  367. XX#endif
  368. XX  if (isint)
  369. XX  {
  370. XX    res = newconst (INTCONST);
  371. XX    res->fp_header.fp_int = op1 + op2;
  372. XX  }
  373. XX  else
  374. XX  {
  375. XX    res = newconst (FLOATCONST);
  376. XX    res->fp_header.fp_float = op1 + op2;
  377. XX  }
  378. XX  dec_ref (data);
  379. XX#ifdef DEBUG
  380. XX  (void) fprintf (stderr, "exiting plus, result is ");
  381. XX  printfpdata (stderr, res, 0);
  382. XX  (void) putc ('\n', stderr);
  383. XX#endif
  384. XX  return (res);
  385. XX}
  386. XX
  387. XXfp_data minus (data)
  388. XXfp_data data;
  389. XX{
  390. XX  register fp_data res;
  391. XX  register float op1, op2;
  392. XX  register int isint = 1;
  393. XX
  394. XX#ifndef NOCHECK
  395. XX  checkarith (data, "minus");
  396. XX#endif
  397. XX  if (data->fp_header.fp_next->fp_entry->fp_type == INTCONST)
  398. XX    op2 = data->fp_header.fp_next->fp_entry->fp_header.fp_int;
  399. XX  else
  400. XX  {
  401. XX    isint = 0;
  402. XX    op2 = data->fp_header.fp_next->fp_entry->fp_header.fp_float;
  403. XX  }
  404. XX  if (data->fp_entry->fp_type == INTCONST)
  405. XX    op1 = data->fp_entry->fp_header.fp_int;
  406. XX  else
  407. XX  {
  408. XX    isint = 0;
  409. XX    op1 = data->fp_entry->fp_header.fp_float;
  410. XX  }
  411. XX#ifndef NOCHECK
  412. XX  if (isint && ((op1 < 0) != (op2 < 0)) &&
  413. XX      ((MAXINT - abs (op1)) < abs (op2)))
  414. XX    genbottom ("minus: overflow or underflow", data);
  415. XX#endif
  416. XX  if (isint)
  417. XX  {
  418. XX    res = newconst (INTCONST);
  419. XX    res->fp_header.fp_int = op1 - op2;
  420. XX  }
  421. XX  else
  422. XX  {
  423. XX    res = newconst (FLOATCONST);
  424. XX    res->fp_header.fp_float = op1 - op2;
  425. XX  }
  426. XX  dec_ref (data);
  427. XX#ifdef DEBUG
  428. XX  (void) fprintf (stderr, "exiting minus, result is ");
  429. XX  printfpdata (stderr, res, 0);
  430. XX  (void) putc ('\n', stderr);
  431. XX#endif
  432. XX  return (res);
  433. XX}
  434. XX
  435. XXfp_data fptimes (data)
  436. XXfp_data data;
  437. XX{
  438. XX  register fp_data res;
  439. XX  register float op1, op2;
  440. XX  register int isint = 1;
  441. XX
  442. XX#ifndef NOCHECK
  443. XX  checkarith (data, "times");
  444. XX#endif
  445. XX  if (data->fp_header.fp_next->fp_entry->fp_type == INTCONST)
  446. XX    op2 = data->fp_header.fp_next->fp_entry->fp_header.fp_int;
  447. XX  else
  448. XX  {
  449. XX    isint = 0;
  450. XX    op2 = data->fp_header.fp_next->fp_entry->fp_header.fp_float;
  451. XX  }
  452. XX  if (data->fp_entry->fp_type == INTCONST)
  453. XX    op1 = data->fp_entry->fp_header.fp_int;
  454. XX  else
  455. XX  {
  456. XX    isint = 0;
  457. XX    op1 = data->fp_entry->fp_header.fp_float;
  458. XX  }
  459. XX#ifndef NOCHECK
  460. XX  if (isint && (op1 != 0) && ((MAXINT / abs (op1)) < abs (op2)))
  461. XX/* the second condition is to insure that the test does not overflow */
  462. XX    genbottom ("times: arithmetic overflow", data);
  463. XX#endif
  464. XX  if (isint)
  465. XX  {
  466. XX    res = newconst (INTCONST);
  467. XX    res->fp_header.fp_int = op1 * op2;
  468. XX  }
  469. XX  else
  470. XX  {
  471. XX    res = newconst (FLOATCONST);
  472. XX    res->fp_header.fp_float = op1 * op2;
  473. XX  }
  474. XX  dec_ref (data);
  475. XX#ifdef DEBUG
  476. XX  (void) fprintf (stderr, "exiting times, result is ");
  477. XX  printfpdata (stderr, res, 0);
  478. XX  (void) putc ('\n', stderr);
  479. XX#endif
  480. XX  return (res);
  481. XX}
  482. XX
  483. XXfp_data div (data)
  484. XXfp_data data;
  485. XX{
  486. XX  register fp_data res;
  487. XX  register float op1, op2, intermediate;
  488. XX  register int isint = 1;
  489. XX
  490. XX#ifndef NOCHECK
  491. XX  checkarith (data, "div");
  492. XX#endif
  493. XX  if (data->fp_header.fp_next->fp_entry->fp_type == INTCONST)
  494. XX    op2 = data->fp_header.fp_next->fp_entry->fp_header.fp_int;
  495. XX  else
  496. XX  {
  497. XX    isint = 0;
  498. XX    op2 = data->fp_header.fp_next->fp_entry->fp_header.fp_float;
  499. XX  }
  500. XX  if (data->fp_entry->fp_type == INTCONST)
  501. XX    op1 = data->fp_entry->fp_header.fp_int;
  502. XX  else
  503. XX  {
  504. XX    isint = 0;
  505. XX    op1 = data->fp_entry->fp_header.fp_float;
  506. XX  }
  507. XX#ifndef NOCHECK
  508. XX  if (op2 == 0.0)
  509. XX    genbottom ("div: division by 0", data);
  510. XX#endif
  511. XX  if (isint)
  512. XX  {
  513. XX    res = newconst (INTCONST);
  514. XX    intermediate = op1 / op2;
  515. XX    res->fp_header.fp_int = intermediate;
  516. XX    if ((res->fp_header.fp_int < 0) &&
  517. XX    (res->fp_header.fp_int != intermediate))
  518. XX      res->fp_header.fp_int--;
  519. XX  }
  520. XX  else
  521. XX  {
  522. XX    res = newconst (FLOATCONST);
  523. XX    res->fp_header.fp_float = op1 / op2;
  524. XX  }
  525. XX  dec_ref (data);
  526. XX#ifdef DEBUG
  527. XX  (void) fprintf (stderr, "exiting div, result is ");
  528. XX  printfpdata (stderr, res, 0);
  529. XX  (void) putc ('\n', stderr);
  530. XX#endif
  531. XX  return (res);
  532. XX}
  533. XX
  534. XXfp_data mod (data)
  535. XXfp_data data;
  536. XX{
  537. XX  register fp_data res;
  538. XX  register long op1, op2;
  539. XX
  540. XX#ifndef NOCHECK
  541. XX  checkarith (data, "mod");
  542. XX#endif
  543. XX  if (data->fp_header.fp_next->fp_entry->fp_type == INTCONST)
  544. XX    op2 = data->fp_header.fp_next->fp_entry->fp_header.fp_int;
  545. XX  else
  546. XX    op2 = data->fp_header.fp_next->fp_entry->fp_header.fp_float;
  547. XX  if (data->fp_entry->fp_type == INTCONST)
  548. XX    op1 = data->fp_entry->fp_header.fp_int;
  549. XX  else
  550. XX    op1 = data->fp_entry->fp_header.fp_float;
  551. XX#ifndef NOCHECK
  552. XX  if (op2 == 0.0)
  553. XX    genbottom ("mod: division by 0", data);
  554. XX#endif
  555. XX  res = newconst (INTCONST);
  556. XX  res->fp_header.fp_int = op1 % op2;
  557. XX  if (res->fp_header.fp_int < 0)
  558. XX    res->fp_header.fp_int += abs (op2);
  559. XX  if ((op2 < 0) && (res->fp_header.fp_int != 0))
  560. XX    res->fp_header.fp_int = (- op2) - res->fp_header.fp_int;
  561. XX  dec_ref (data);
  562. XX#ifdef DEBUG
  563. XX  (void) fprintf (stderr, "exiting mod, result is ");
  564. XX  printfpdata (stderr, res, 0);
  565. XX  (void) putc ('\n', stderr);
  566. XX#endif
  567. XX  return (res);
  568. XX}
  569. XX
  570. XXfp_data neg (data)
  571. XXfp_data data;
  572. XX{
  573. XX  register fp_data res;
  574. XX
  575. XX#ifdef DEBUG
  576. XX  (void) fprintf (stderr, "entering neg, object is ");
  577. XX  printfpdata (stderr, data, 0);
  578. XX  (void) putc ('\n', stderr);
  579. XX#endif
  580. XX#ifndef NOCHECK
  581. XX  if ((data->fp_type != INTCONST) && (data->fp_type != FLOATCONST))
  582. XX    genbottom ("neg: input is not a number", data);
  583. XX#endif
  584. XX  res = newconst (data->fp_type);
  585. XX  if (data->fp_type == INTCONST)
  586. XX    res->fp_header.fp_int = - data->fp_header.fp_int;
  587. XX  else
  588. XX    res->fp_header.fp_float = - data->fp_header.fp_float;
  589. XX  dec_ref (data);
  590. XX#ifdef DEBUG
  591. XX  (void) fprintf (stderr, "exiting neg, result is ");
  592. XX  printfpdata (stderr, res, 0);
  593. XX  (void) putc ('\n', stderr);
  594. XX#endif
  595. XX  return (res);
  596. XX}
  597. XX
  598. XXfp_data null (data)
  599. XXfp_data data;
  600. XX{
  601. XX  register fp_data res;
  602. XX
  603. XX#ifdef DEBUG
  604. XX  (void) fprintf (stderr, "entering null, argument is ");
  605. XX  printfpdata (stderr, data, 0);
  606. XX  (void) putc ('\n', stderr);
  607. XX#endif
  608. XX  if (data->fp_type == NILOBJ)
  609. XX    res = (fp_true);
  610. XX  else
  611. XX    res = (fp_false);
  612. XX  dec_ref (data);
  613. XX#ifdef DEBUG
  614. XX  (void) fprintf (stderr, "exiting null, result is ");
  615. XX  printfpdata (stderr, res, 0);
  616. XX  (void) putc ('\n', stderr);
  617. XX#endif
  618. XX  return (res);
  619. XX}
  620. XX
  621. XXfp_data length (data)
  622. XXfp_data data;
  623. XX{
  624. XX  register fp_data res, vector;
  625. XX  register long size;
  626. XX
  627. XX#ifdef DEBUG
  628. XX  (void) fprintf (stderr, "entering length, object is ");
  629. XX  printfpdata (stderr, data, 0);
  630. XX  (void) putc ('\n', stderr);
  631. XX#endif
  632. XX#ifndef NOCHECK
  633. XX  if (nonvector (data))
  634. XX    genbottom ("length: input is not a vector or nil", data);
  635. XX#endif
  636. XX  size = 0;
  637. XX  if (data->fp_type == NILOBJ)
  638. XX    vector = 0;
  639. XX  else
  640. XX    vector = data;
  641. XX  while (vector != 0)
  642. XX  {
  643. XX    size++;
  644. XX    vector = vector->fp_header.fp_next;
  645. XX  }
  646. XX  res = newconst (INTCONST);
  647. XX  res->fp_header.fp_int = size;
  648. XX  dec_ref (data);
  649. XX#ifdef DEBUG
  650. XX  (void) fprintf (stderr, "exiting length, result is ");
  651. XX  printfpdata (stderr, res, 0);
  652. XX  (void) putc ('\n', stderr);
  653. XX#endif
  654. XX  return (res);
  655. XX}
  656. XX
  657. XXfp_data trans (data)
  658. XXfp_data data;
  659. XX{
  660. XX/* implementation: a matrix backbone is the set of storage cells that
  661. XX   point to rows of the matrix. What we do is we copy the argument's
  662. XX   backbone, then use it to step through all elements of the first
  663. XX   column while updating the backbone to point to the second column
  664. XX   and building a result row, and repeat. */
  665. XX  register fp_data fromptr,    /* holds the "from" part when pointer chasing */
  666. XX           toptr,    /* holds the "to" part when pointer chasing */
  667. XX           resptr,    /* holds a copy of the result backbone */
  668. XX           bbcopy,    /* holds a copy of the matrix backbone */
  669. XX             res;        /* holds the final result */
  670. XX  register long rows = 1, cols = 1;
  671. XX
  672. XX#ifdef DEBUG
  673. XX  (void) fprintf (stderr, "entering trans, object is ");
  674. XX  printfpdata (stderr, data, 0);
  675. XX  (void) putc ('\n', stderr);
  676. XX#endif
  677. XX#ifndef NOCHECK
  678. XX  if (data->fp_type != VECTOR)
  679. XX    genbottom ("trans: input is not a vector", data);
  680. XX#endif
  681. XX  if (data->fp_entry->fp_type != VECTOR)
  682. XX  {    /* The loop is for legality check only. */
  683. XX    /* it is legal to tranpose a vector of nils into nil. */
  684. XX    /* the converse (nil to a vector of nils) is not legal. */
  685. XX    /* that is the only case in which trans o trans != id. */
  686. XX#ifndef NOCHECK
  687. XX    for (fromptr = data; fromptr != 0; fromptr = fromptr->fp_header.fp_next)
  688. XX      if (fromptr->fp_entry->fp_type != NILOBJ)
  689. XX    genbottom ("trans: input is not a matrix", data);
  690. XX#endif
  691. XX    res = fp_nil;
  692. XX  }
  693. XX  else
  694. XX  {        /* find out number of source cols = dest rows */
  695. XX    fromptr = data->fp_entry;
  696. XX    while ((fromptr = fromptr->fp_header.fp_next) != 0)
  697. XX      cols++;
  698. XX            /* now find out number of source rows = dest cols */
  699. XX    fromptr = data;
  700. XX    while ((fromptr = fromptr->fp_header.fp_next) != 0)
  701. XX      rows++;
  702. XX    bbcopy = newvect (rows);    /* copy the old backbone to bbcopy */
  703. XX    fromptr = data;
  704. XX    toptr = bbcopy;
  705. XX    while (fromptr != 0)
  706. XX    {
  707. XX      toptr->fp_entry = fromptr->fp_entry;
  708. XX/* no need to inc_ref since we will reset the backbone to be
  709. XX   all NILs before returning it. */
  710. XX      toptr = toptr->fp_header.fp_next;
  711. XX      fromptr = fromptr->fp_header.fp_next;
  712. XX    }        /* backbone copied, now start building output rows */
  713. XX    res = newvect (cols);        /* the result has "cols" rows */
  714. XX    resptr = res;
  715. XX    while (resptr != 0) /* build one row at a time, and assign it to */
  716. XX    { /* resptr->fp_entry, so we are done when resptr is 0 */
  717. XX/* loop invariant: every time we enter the loop, we are (inductively)
  718. XX   building the transpose of bbcopy into resptr. When we finish
  719. XX   each loop, we will have removed the first column of bbcopy and built
  720. XX   the top row of resptr, and changed bbcopy to remove its first column. */
  721. XX      resptr->fp_entry = toptr = newvect (rows);
  722. XX      fromptr = bbcopy;
  723. XX/* resptr is the backbone of res. fromptr runs along bbcopy
  724. XX   and updates it to point to the next element of each row. toptr
  725. XX   runs along the current result row to initialize it. */
  726. XX      while (toptr != 0)    /* here we build one row of res */
  727. XX      {
  728. XX#ifndef NOCHECK
  729. XX    if (fromptr->fp_entry == 0)
  730. XX      genbottom ("trans: rows are not all equally long", data);
  731. XX#endif
  732. XX    toptr->fp_entry = fromptr->fp_entry->fp_entry;
  733. XX    inc_ref (toptr->fp_entry);
  734. XX    fromptr->fp_entry = fromptr->fp_entry->fp_header.fp_next;
  735. XX/* make the backbone so it points to the next element of the row,
  736. XX   in effect deleting this element of the first column from bbcopy. */
  737. XX    fromptr = fromptr->fp_header.fp_next;
  738. XX    toptr = toptr->fp_header.fp_next;
  739. XX      }        /* the row of result is built, go on to the next. */
  740. XX      resptr = resptr->fp_header.fp_next;
  741. XX    }
  742. XX    for (fromptr = bbcopy; fromptr != 0; fromptr = fromptr->fp_header.fp_next)
  743. XX#ifndef NOCHECK
  744. XX      if (fromptr->fp_entry != 0)
  745. XX    genbottom ("trans: rows are not all equally long", data);
  746. XX      else
  747. XX#endif
  748. XX    fromptr->fp_entry = fp_nil;
  749. XX    dec_ref (bbcopy);
  750. XX  }
  751. XX  dec_ref (data);
  752. XX#ifdef DEBUG
  753. XX  (void) fprintf (stderr, "exiting trans, result is ");
  754. XX  printfpdata (stderr, res, 0);
  755. XX  (void) putc ('\n', stderr);
  756. XX#endif
  757. XX  return (res);
  758. XX}
  759. XX
  760. XX#ifndef NOCHECK
  761. XXvoid checklog (data, fname)
  762. XXfp_data data;
  763. XXchar * fname;
  764. XX{
  765. XX#ifdef DEBUG
  766. XX  (void) fprintf (stderr, "entering %s, object is ", fname);
  767. XX  printfpdata (stderr, data, 0);
  768. XX  (void) putc ('\n', stderr);
  769. XX#endif
  770. XX  if (data->fp_type != VECTOR)
  771. XX    parmbot (fname, "input is not a vector", data);
  772. XX  if ((data->fp_header.fp_next == 0) ||
  773. XX      (data->fp_header.fp_next->fp_header.fp_next != 0))
  774. XX    parmbot (fname, "input is not a 2-element vector", data);
  775. XX  if (nonboolean (data->fp_entry))
  776. XX    parmbot (fname, "1st argument is not a boolean", data);
  777. XX  if (nonboolean (data->fp_header.fp_next->fp_entry))
  778. XX    parmbot (fname, "second argument is not a boolean", data);
  779. XX}
  780. XX#endif
  781. XX
  782. XXfp_data and (data)
  783. XXfp_data data;
  784. XX{
  785. XX  register fp_data res;
  786. XX  register fp_data op1, op2;
  787. XX
  788. XX#ifndef NOCHECK
  789. XX  checklog (data, "and");
  790. XX#endif
  791. XX  op1 = data->fp_entry;
  792. XX  op2 = data->fp_header.fp_next->fp_entry;
  793. XX  if ((op1->fp_type == TRUEOBJ) &&
  794. XX      (op2->fp_type == TRUEOBJ))
  795. XX    res = (fp_true);
  796. XX  else
  797. XX    res = (fp_false);
  798. XX  dec_ref (data);
  799. XX#ifdef DEBUG
  800. XX  (void) fprintf (stderr, "exiting and, result is ");
  801. XX  printfpdata (stderr, res, 0);
  802. XX  (void) putc ('\n', stderr);
  803. XX#endif
  804. XX  return (res);
  805. XX}
  806. XX
  807. XXfp_data or (data)
  808. XXfp_data data;
  809. XX{
  810. XX  register fp_data res, op1, op2;
  811. XX
  812. XX#ifndef NOCHECK
  813. XX  checklog (data, "or");
  814. XX#endif
  815. XX  op1 = data->fp_entry;
  816. XX  op2 = data->fp_header.fp_next->fp_entry;
  817. XX  if ((op1->fp_type == TRUEOBJ) ||
  818. XX      (op2->fp_type == TRUEOBJ))
  819. XX    res = (fp_true);
  820. XX  else
  821. XX    res = (fp_false);
  822. XX  dec_ref (data);
  823. XX#ifdef DEBUG
  824. XX  (void) fprintf (stderr, "exiting or, result is ");
  825. XX  printfpdata (stderr, res, 0);
  826. XX  (void) putc ('\n', stderr);
  827. XX#endif
  828. XX  return (res);
  829. XX}
  830. XX
  831. XXfp_data not (data)
  832. XXfp_data data;
  833. XX{
  834. XX  register fp_data res;
  835. XX
  836. XX#ifdef DEBUG
  837. XX  (void) fprintf (stderr, "entering not, object is ");
  838. XX  printfpdata (stderr, data, 0);
  839. XX  (void) putc ('\n', stderr);
  840. XX#endif
  841. XX#ifndef NOCHECK
  842. XX  if (nonboolean (data))
  843. XX    genbottom ("not: argument is not a boolean", data);
  844. XX#endif
  845. XX  if (data->fp_type == TRUEOBJ)
  846. XX    res = (fp_false);
  847. XX  else
  848. XX    res = (fp_true);
  849. XX  dec_ref (data);
  850. XX#ifdef DEBUG
  851. XX  (void) fprintf (stderr, "exiting not, result is ");
  852. XX  printfpdata (stderr, res, 0);
  853. XX  (void) putc ('\n', stderr);
  854. XX#endif
  855. XX  return (res);
  856. XX}
  857. XX
  858. XXfp_data iota (data)
  859. XXfp_data data;
  860. XX{
  861. XX  register fp_data res, num, vect;
  862. XX  register long pos, size;
  863. XX
  864. XX#ifdef DEBUG
  865. XX  (void) fprintf (stderr, "entering iota, object is ");
  866. XX  printfpdata (stderr, data, 0);
  867. XX  (void) putc ('\n', stderr);
  868. XX#endif
  869. XX#ifndef NOCHECK
  870. XX  if ((data->fp_type != INTCONST) && (data->fp_type != FLOATCONST))
  871. XX    genbottom ("iota: input is not a number", data);
  872. XX#endif
  873. XX  if (data->fp_type == INTCONST)
  874. XX    size = data->fp_header.fp_int;
  875. XX  else
  876. XX    size = data->fp_header.fp_float;
  877. XX#ifndef NOCHECK
  878. XX  if (size < 0)
  879. XX    genbottom ("iota: input is negative", data);
  880. XX#endif
  881. XX  if (size == 0)
  882. XX    return (fp_nil);
  883. XX  res = newvect (size);
  884. XX  vect = res;
  885. XX  pos = 0;
  886. XX  while (size > pos++)
  887. XX  {
  888. XX    num = newconst (INTCONST);
  889. XX    num->fp_header.fp_int = pos;
  890. XX    vect->fp_entry = num;
  891. XX    vect = vect->fp_header.fp_next;
  892. XX  }
  893. XX#ifdef DEBUG
  894. XX  (void) fprintf (stderr, "exiting iota, result is ");
  895. XX  printfpdata (stderr, res, 0);
  896. XX  (void) putc ('\n', stderr);
  897. XX#endif
  898. XX  return (res);
  899. XX}
  900. XX
  901. XX/* the following function is used very often, so it is included
  902. XX * here for speed, though it could be defined as \/(/apndl o apndr).
  903. XX * It is not mentioned in the Backus Turing award lecture. */
  904. XXfp_data append (data)
  905. XXfp_data data;
  906. XX{
  907. XX  register fp_data entry;    /* holds the vector being copied */
  908. XX  register fp_data new;        /* holds the next cell filled in for new */
  909. XX  register fp_data res;        /* holds final result, but tested often */
  910. XX  register fp_data old;        /* chases 'data' */
  911. XX
  912. XX#ifdef DEBUG
  913. XX  (void) fprintf (stderr, "entering append, argument is ");
  914. XX  printfpdata (stderr, data, 0);
  915. XX  (void) putc ('\n', stderr);
  916. XX#endif
  917. XX#ifndef NOCHECK    /* arg must be a vector of vectors or nils */
  918. XX  if (data->fp_type != VECTOR)
  919. XX    genbottom ("append: input is not a vector", data);
  920. XX#endif
  921. XX  res = 0;
  922. XX  for (entry = data->fp_entry, old = data->fp_header.fp_next;
  923. XX    old != 0;
  924. XX    entry = old->fp_entry, old = old->fp_header.fp_next)
  925. XX  {
  926. XX    if (entry->fp_type == VECTOR)
  927. XX    {    /* partial loop unrolling to avoid testing for res == 0 in the
  928. XX       inner (for) loop: */
  929. XX      if (res == 0)
  930. XX    new = res = newcell ();
  931. XX      else
  932. XX    new = new->fp_header.fp_next = newcell ();
  933. XX      new->fp_entry = entry->fp_entry;
  934. XX      inc_ref (new->fp_entry);
  935. XX      for (entry = entry->fp_header.fp_next;
  936. XX       entry != 0;        /* this condition tested at start! */
  937. XX       entry = entry->fp_header.fp_next)
  938. XX      {
  939. XX    new = new->fp_header.fp_next = newcell ();
  940. XX    new->fp_entry = entry->fp_entry;
  941. XX    inc_ref (new->fp_entry);
  942. XX      }
  943. XX    }
  944. XX#ifndef NOCHECK
  945. XX    else if (entry->fp_type != NILOBJ)
  946. XX      genbottom ("append: input is not a vector of nils or vectors", data);
  947. XX#endif
  948. XX  }
  949. XX  if (res == 0)
  950. XX#ifndef NOCHECK
  951. XX    if ((entry->fp_type != NILOBJ) && (entry->fp_type != VECTOR))
  952. XX      genbottom ("append: input is not a vector of nils or vectors", data);
  953. XX    else
  954. XX#endif
  955. XX    res = entry;
  956. XX  else
  957. XX    if (entry->fp_type == VECTOR)
  958. XX      new->fp_header.fp_next = entry;
  959. XX#ifndef NOCHECK
  960. XX    else if (entry->fp_type != NILOBJ)
  961. XX      genbottom ("append: input is not a vector of nils or vectors", data);
  962. XX#endif
  963. XX  inc_ref (entry);    /* doesn't hurt, even if entry is nil */
  964. XX  dec_ref (data);
  965. XX#ifdef DEBUG
  966. XX  (void) fprintf (stderr, "exiting append, result is ");
  967. XX  printfpdata (stderr, res, 0);
  968. XX  (void) putc ('\n', stderr);
  969. XX#endif
  970. XX  return (res);
  971. XX}
  972. XX
  973. XX/* following are the character functions which I have come up with,
  974. XX * namely newline, implode, explode */
  975. XX
  976. XX/* constant function returning the new-line character */
  977. XXfp_data newline (data)
  978. XXfp_data data;
  979. XX{
  980. XX  static struct fp_charc nlc =
  981. XX                {(short) CHARCONST, (short) 1, '\n'};
  982. XX  static struct fp_constant nl =
  983. XX                {(short) VECTOR, (short) 1, (long) 0, (fp_data) &nlc};
  984. XX  register fp_data res;
  985. XX
  986. XX#ifdef DEBUG
  987. XX  (void) fprintf (stderr, "entering newline, object is ");
  988. XX  printfpdata (stderr, data, 0);
  989. XX  (void) putc ('\n', stderr);
  990. XX#endif
  991. XX  dec_ref (data);
  992. XX  res = (fp_data) & (nl);
  993. XX  inc_ref (res);
  994. XX#ifdef DEBUG
  995. XX  (void) fprintf (stderr, "exiting newline\n");
  996. XX#endif
  997. XX  return (res);
  998. XX}
  999. XX
  1000. XXstatic fp_data toFPstring (str)
  1001. XXregister char * str;
  1002. XX{
  1003. XX  register fp_data chase, ch;
  1004. XX  register fp_data res;
  1005. XX
  1006. XX  if (*str == '\0')
  1007. XX    res = fp_nil;
  1008. XX  else
  1009. XX  {
  1010. XX    res = chase = newcell ();
  1011. XX    while (1)
  1012. XX    {
  1013. XX      ch = newconst (CHARCONST);
  1014. XX      ch->fp_header.fp_char = *(str++);
  1015. XX      chase->fp_entry = ch;
  1016. XX      if (*str == '\0')
  1017. XX        break;
  1018. XX      chase = chase->fp_header.fp_next = newcell ();
  1019. XX    }
  1020. XX  }
  1021. XX  return (res);
  1022. XX}
  1023. XX
  1024. XXstatic void toCstring (fp, c)
  1025. XXfp_data fp;
  1026. XXchar * c;
  1027. XX{
  1028. XX  for ( ; fp != 0; fp = fp->fp_header.fp_next)
  1029. XX    *(c++) = fp->fp_entry->fp_header.fp_char;
  1030. XX  *c = '\0';
  1031. XX}
  1032. XX
  1033. XXfp_data explode (data)
  1034. XXfp_data data;
  1035. XX{
  1036. XX  register fp_data res;
  1037. XX
  1038. XX#ifdef DEBUG
  1039. XX  (void) fprintf (stderr, "entering explode, object is ");
  1040. XX  printfpdata (stderr, data, 0);
  1041. XX  (void) putc ('\n', stderr);
  1042. XX#endif
  1043. XX#ifndef NOCHECK
  1044. XX  if (data->fp_type != ATOMCONST)
  1045. XX    genbottom ("explode: argument is not an atom", data);
  1046. XX#endif
  1047. XX  res = toFPstring (data->fp_header.fp_atom);
  1048. XX  dec_ref (data);
  1049. XX#ifdef DEBUG
  1050. XX  (void) fprintf (stderr, "exiting explode, object is ");
  1051. XX  printfpdata (stderr, res, 0);
  1052. XX  (void) putc ('\n', stderr);
  1053. XX#endif
  1054. XX  return (res);
  1055. XX}
  1056. XX
  1057. XXfp_data implode (data)
  1058. XXfp_data data;
  1059. XX{
  1060. XX  register unsigned len = 1;
  1061. XX  register fp_data res, chase;
  1062. XX  register char * str;
  1063. XX
  1064. XX#ifdef DEBUG
  1065. XX  (void) fprintf (stderr, "entering implode, object is ");
  1066. XX  printfpdata (stderr, data, 0);
  1067. XX  (void) putc ('\n', stderr);
  1068. XX#endif
  1069. XX#ifndef NOCHECK
  1070. XX  if (! isstring (data))
  1071. XX    genbottom ("implode: argument is not a string", data);
  1072. XX#endif
  1073. XX  for (chase = data; chase != 0; chase = chase->fp_header.fp_next)
  1074. XX    len++;
  1075. XX  res = newconst (ATOMCONST);
  1076. XX  res->fp_header.fp_atom = str = malloc (len);
  1077. XX  toCstring (data, str);
  1078. XX  dec_ref (data);
  1079. XX#ifdef DEBUG
  1080. XX  (void) fprintf (stderr, "exiting implode, object is ");
  1081. XX  printfpdata (stderr, res, 0);
  1082. XX  (void) putc ('\n', stderr);
  1083. XX#endif
  1084. XX  return (res);
  1085. XX}
  1086. XX
  1087. XX/* following is the real to integer conversion function. Note: to
  1088. XX * convert from integer to real, use (bu * 1.0) */
  1089. XX
  1090. XX/* function returning the floor of the value of any numeric parameter */
  1091. XXfp_data trunc (data)
  1092. XXfp_data data;
  1093. XX{
  1094. XX  register fp_data res;
  1095. XX
  1096. XX#ifdef DEBUG
  1097. XX  (void) fprintf (stderr, "entering trunc, object is ");
  1098. XX  printfpdata (stderr, data, 0);
  1099. XX  (void) putc ('\n', stderr);
  1100. XX#endif
  1101. XX  if (data->fp_type == INTCONST)    /* no-op */
  1102. XX    return (data);
  1103. XX#ifndef NOCHECK
  1104. XX  if (data->fp_type != FLOATCONST)
  1105. XX    genbottom ("trunc: argument is not a number", data);
  1106. XX#endif
  1107. XX  res = newconst (INTCONST);
  1108. XX  res->fp_header.fp_int = data->fp_header.fp_float;
  1109. XX  if (res->fp_header.fp_int > data->fp_header.fp_float)    /* adjust */
  1110. XX    res->fp_header.fp_int--;
  1111. XX  dec_ref (data);
  1112. XX#ifdef DEBUG
  1113. XX  (void) fprintf (stderr, "exiting trunc, object is ");
  1114. XX  printfpdata (stderr, res, 0);
  1115. XX  (void) putc ('\n', stderr);
  1116. XX#endif
  1117. XX  return (res);
  1118. XX}
  1119. XX
  1120. XX/* following are the I/O functions not described or hinted at in the
  1121. XX * Backus paper. They are documented one by one. */
  1122. XX
  1123. XX/* trace outputs its data, which must be a string, in raw output mode,
  1124. XX * and returns it */
  1125. XXfp_data trace (data)
  1126. XXfp_data data;
  1127. XX{
  1128. XX#ifdef DEBUG
  1129. XX  (void) fprintf (stderr, "entering trace, object is ");
  1130. XX  printfpdata (stderr, data, 0);
  1131. XX  (void) putc ('\n', stderr);
  1132. XX#endif
  1133. XX#ifndef NOCHECK
  1134. XX  if ((data->fp_type != NILOBJ) && ! isstring (data))
  1135. XX    genbottom ("trace: input is not a string", data);
  1136. XX#endif
  1137. XX  putfpstring (data, stderr);
  1138. XX#ifdef DEBUG
  1139. XX  (void) fprintf (stderr, "exiting trace, result is ");
  1140. XX  printfpdata (stderr, data, 0);
  1141. XX  (void) putc ('\n', stderr);
  1142. XX#endif
  1143. XX  return (data);
  1144. XX}
  1145. XX
  1146. XX/* takes as argument a string and the name of a function, and
  1147. XX * returns the file with the given name (opened for reading),
  1148. XX * which may be 0. It does not dec_ref data.
  1149. XX */
  1150. XXstatic FILE * openfile (data, funname)
  1151. XXfp_data data;
  1152. XXchar * funname;
  1153. XX{
  1154. XX  char name [FNAMELEN];
  1155. XX
  1156. XX#ifdef DEBUG
  1157. XX  (void) fprintf (stderr, "entering %s, object is ", funname);
  1158. XX  printfpdata (stderr, data, 0);
  1159. XX  (void) putc ('\n', stderr);
  1160. XX#endif
  1161. XX#ifndef NOCHECK
  1162. XX  if (! isstring (data))
  1163. XX  {
  1164. XX    sprintf (name, "%s: input is not a string", funname);
  1165. XX    genbottom (name, data);
  1166. XX  }
  1167. XX#endif
  1168. XX  toCstring (data, name);
  1169. XX  return (fopen (name, "r"));
  1170. XX}
  1171. XX
  1172. XXstatic void closefile (f, funname, data, res)
  1173. XXFILE * f;
  1174. XXchar * funname;
  1175. XXfp_data data, res;
  1176. XX{
  1177. XX  char errstr [100];
  1178. XX
  1179. XX  if (f != 0)
  1180. XX    if (fclose (f) == EOF)
  1181. XX#ifndef NOCHECK
  1182. XX    {
  1183. XX      sprintf (errstr, "%s: unable to close the file", funname);
  1184. XX      genbottom (errstr, data);
  1185. XX    }
  1186. XX#else
  1187. XX      ;
  1188. XX#endif
  1189. XX  dec_ref (data);
  1190. XX#ifdef DEBUG
  1191. XX  (void) fprintf (stderr, "exiting %s, result is ", res);
  1192. XX  printfpdata (stderr, res, 0);
  1193. XX  (void) putc ('\n', stderr);
  1194. XX#endif
  1195. XX}
  1196. XX
  1197. XX/* filetype takes as input a string and returns:
  1198. XX * none if the file does not exist
  1199. XX * empty if the file exists but has no data
  1200. XX * binary if the file contains non-textual characters
  1201. XX * data if the file can be read by the parser
  1202. XX * text otherwise.
  1203. XX * A text file can usually be read as data (just returns
  1204. XX * the first word as an atom; that is however still
  1205. XX * marked as text. It is data if it has a single symbol
  1206. XX * alone on the first nonblank line. A data file may
  1207. XX * usually be read as text.
  1208. XX */
  1209. XXfp_data filetype (data)
  1210. XXfp_data data;
  1211. XX{
  1212. XX  static struct fp_atom none =
  1213. XX                {(short) ATOMCONST, (short) 1, (char *) "none"};
  1214. XX  static struct fp_atom empty =
  1215. XX                {(short) ATOMCONST, (short) 1, (char *) "empty"};
  1216. XX  static struct fp_atom datafile =
  1217. XX                {(short) ATOMCONST, (short) 1, (char *) "data"};
  1218. XX  static struct fp_atom text =
  1219. XX                {(short) ATOMCONST, (short) 1, (char *) "text"};
  1220. XX  static struct fp_atom binary =
  1221. XX                {(short) ATOMCONST, (short) 1, (char *) "binary"};
  1222. XX  fp_data res;
  1223. XX  FILE * f;
  1224. XX  int intch;
  1225. XX  char c;
  1226. XX  int isbinfile ();
  1227. XX 
  1228. XX  f = openfile (data, "filetype");
  1229. XX  if (f == 0)
  1230. XX    res = (fp_data) & none;
  1231. XX  else if ((intch = getc (f)) == EOF)
  1232. XX    res = (fp_data) & empty;
  1233. XX  else
  1234. XX  {
  1235. XX/* criteria for datafile:
  1236. XX * the first nonempty line contains a symbol by itsef --> datafile
  1237. XX * the datafile begins with a parseable vector or string --> datafile
  1238. XX * else --> text file or binary file
  1239. XX */
  1240. XX    while (isspace (intch))    /* find the first nonempty line */
  1241. XX      intch = getc (f);
  1242. XX    if (isalpha (intch))    /* is it a symbol on an empty line? */
  1243. XX    {
  1244. XX      while (isalnum (intch))
  1245. XX        intch = getc (f);
  1246. XX      while ((intch == ' ') || (intch == '\t'))
  1247. XX        intch = getc (f);
  1248. XX      if ((intch == '\n') || (intch == EOF))
  1249. XX        res = (fp_data) & datafile;
  1250. XX      else if (isbinfile (f, intch))
  1251. XX    res = (fp_data) & binary;
  1252. XX      else
  1253. XX    res = (fp_data) & text;
  1254. XX    }
  1255. XX    else
  1256. XX    {
  1257. XX      c = intch;
  1258. XX      if (readfpdata (f, &c, 1) ->fp_type == TRUEOBJ)
  1259. XX    res = (fp_data) & datafile;
  1260. XX/* notice readfpdata returned the last character it read */
  1261. XX      else if (isbinfile (f, c))
  1262. XX    res = (fp_data) & binary;
  1263. XX      else
  1264. XX    res = (fp_data) & text;
  1265. XX    }
  1266. XX  }
  1267. XX  inc_ref (res);
  1268. XX  closefile (f, "filetype", data, res);
  1269. XX  return (res);
  1270. XX}
  1271. XX
  1272. XXstatic int isbinfile (f, ch)
  1273. XXFILE * f;
  1274. XXint ch;
  1275. XX{
  1276. XX  for (; ch != EOF; ch = getc (f))
  1277. XX    if (! (isprint (ch) || isspace (ch)))
  1278. XX      return (1);
  1279. XX  return (0);
  1280. XX}
  1281. XX
  1282. XXfp_data readfile (data)
  1283. XXfp_data data;
  1284. XX{
  1285. XX  FILE * f;
  1286. XX  int c;
  1287. XX  char input;
  1288. XX  fp_data res;
  1289. XX
  1290. XX  f = openfile (data, "readfile");
  1291. XX  if ((f == 0) || ((c = getc (f)) == EOF))
  1292. XX    res = fp_nil;
  1293. XX  else
  1294. XX  {
  1295. XX    input = c;
  1296. XX    res = readfpdata (f, &input, 0);
  1297. XX  }
  1298. XX  closefile (f, "readfile", data, res);
  1299. XX  return (res);
  1300. XX}
  1301. XX
  1302. XXfp_data inputfile (data)
  1303. XXfp_data data;
  1304. XX{
  1305. XX  fp_data res;
  1306. XX  FILE * f;
  1307. XX
  1308. XX  f = openfile (data, "inputfile");
  1309. XX  res = readfpstring (f);
  1310. XX  closefile (f, "inputfile", data, res);
  1311. XX  return (res);
  1312. XX}
  1313. XX
  1314. XX/* the next function ignores its input and returns the arguments
  1315. XX * given in the call to the program. The arguments are returned
  1316. XX * in the following form:
  1317. XX * <argopt*>, where
  1318. XX * argopt ::= "argument" | option
  1319. XX * option ::= <'option, "value"> | <'option, <>>
  1320. XX */
  1321. XXfp_data arguments (data)
  1322. XXfp_data data;
  1323. XX{
  1324. XX  static fp_data res = 0;    /* re-use it after it has been initialized */
  1325. XX  fp_data old, option;
  1326. XX
  1327. XX  dec_ref (data);
  1328. XX  if (res == 0)            /* do the work, once and for all */
  1329. XX  {
  1330. XX    if (fpargc == 1)        /* no arguments, options */
  1331. XX      res = fp_nil;
  1332. XX    while ((fpargc--) > 1)    /* else: read arguments in reverse order */
  1333. XX    {
  1334. XX      old = res;
  1335. XX      res = newcell ();
  1336. XX      res->fp_header.fp_next = old;
  1337. XX      if (fpargv [fpargc] [0] == '-')    /* it's an option */
  1338. XX      {
  1339. XX        option = newpair ();
  1340. XX        option->fp_entry = newconst (CHARCONST);
  1341. XX        option->fp_entry->fp_header.fp_char = fpargv [fpargc] [1];
  1342. XX        option->fp_header.fp_next->fp_entry =
  1343. XX      toFPstring (& (fpargv [fpargc] [2]));
  1344. XX      }
  1345. XX      else                /* it's an argument */
  1346. XX        res->fp_entry = toFPstring (fpargv [fpargc]);
  1347. XX    }
  1348. XX#ifndef NOCHECK
  1349. XX    old = staticstore;
  1350. XX    staticstore = newcell ();
  1351. XX    staticstore->fp_header.fp_next = old;
  1352. XX    staticstore->fp_entry = res;
  1353. XX#endif
  1354. XX  }
  1355. XX  inc_ref (res);
  1356. XX  return (res);
  1357. XX}
  1358. SHAR_EOF
  1359. if test 34144 -ne "`wc -c fp.c.part2`"
  1360. then
  1361. echo shar: error transmitting fp.c.part2 '(should have been 34144 characters)'
  1362. fi
  1363. echo shar: extracting mkffp.c '(5533 characters)'
  1364. sed 's/^XX//' << \SHAR_EOF > mkffp.c
  1365. XX/* mkffp.c: this file, when linked with the FP preprocessor, will
  1366. XX *        produce an FP to FFP compiler. The compiler will read in
  1367. XX *        one or more FP files and for each FP function defined
  1368. XX *        will produce a corresponding FFP file function.ffp.
  1369. XX */
  1370. XX
  1371. XX#include <stdio.h>
  1372. XX#include <strings.h>
  1373. XX#include "fpc.h"
  1374. XX#include "parse.h"
  1375. XX#include "code.h"
  1376. XX
  1377. XXFILE * outfile;
  1378. XX
  1379. XX/* set newname to "" to indicate that no file should be opened */
  1380. XXvoid newfname (oldname, newname)
  1381. XXchar * oldname, * newname;
  1382. XX{
  1383. XX  *newname = '\0';
  1384. XX}
  1385. XX
  1386. XXstatic void codeobj (tree)
  1387. XXfpexpr tree;
  1388. XX{
  1389. XX  switch (tree->exprtype)
  1390. XX  {
  1391. XX    case NIL:
  1392. XX      (void) fprintf (outfile, "<>");
  1393. XX      break;
  1394. XX    case TRUE:
  1395. XX      (void) fprintf (outfile, "T");
  1396. XX      break;
  1397. XX    case FALSE:
  1398. XX      (void) fprintf (outfile, "F");
  1399. XX      break;
  1400. XX    case INT:
  1401. XX      (void) fprintf (outfile, "%d", tree->fpexprv.intobj);
  1402. XX      break;
  1403. XX    case FLOAT:
  1404. XX      (void) fprintf (outfile, "%f", tree->fpexprv.floatobj);
  1405. XX      break;
  1406. XX    case SYM:
  1407. XX      (void) fprintf (outfile, "%s", tree->fpexprv.symbol);
  1408. XX      break;
  1409. XX    case CHAR:
  1410. XX      (void) fprintf (outfile, "'%c", tree->fpexprv.character);
  1411. XX      break;
  1412. XX    case LIST:
  1413. XX      (void) putc ('<', outfile);
  1414. XX      while (tree != 0)
  1415. XX      {
  1416. XX    codeobj (tree->fpexprv.listobj.listel);
  1417. XX        (void) putc (' ', outfile);
  1418. XX    tree = tree->fpexprv.listobj.listnext;
  1419. XX      }
  1420. XX      (void) fprintf (outfile, ">\n");
  1421. XX      break;
  1422. XX    default:
  1423. XX      yyerror ("compiler error 11");
  1424. XX  }
  1425. XX}
  1426. XX
  1427. XXstatic void codeexpr (tree)
  1428. XXfpexpr tree;
  1429. XX{
  1430. XX#define STKSIZE    128
  1431. XX  fpexpr stack [STKSIZE];
  1432. XX  int stkptr;
  1433. XX
  1434. XX  switch (tree->exprtype)
  1435. XX  {
  1436. XX    case COND:
  1437. XX      (void) fprintf (outfile, "<cond ");
  1438. XX      codeexpr (tree->fpexprv.conditional [0]);
  1439. XX      (void) putc (' ', outfile);
  1440. XX      codeexpr (tree->fpexprv.conditional [1]);
  1441. XX      (void) putc (' ', outfile);
  1442. XX      codeexpr (tree->fpexprv.conditional [2]);
  1443. XX      (void) fprintf (outfile, ">\n");
  1444. XX      break;
  1445. XX    case BUR:
  1446. XX    case BU:
  1447. XX      if (tree->exprtype != BU)
  1448. XX    (void) fprintf (outfile, "<bur ");
  1449. XX      else
  1450. XX    (void) fprintf (outfile, "<bu ");
  1451. XX      codeexpr (tree->fpexprv.bulr.bufun);
  1452. XX      (void) putc (' ', outfile);
  1453. XX      codeobj (tree->fpexprv.bulr.buobj);
  1454. XX      (void) fprintf (outfile, ">\n");
  1455. XX      break;
  1456. XX    case WHILE:
  1457. XX      (void) fprintf (outfile, "<while ");
  1458. XX      codeexpr (tree->fpexprv.whilestat [0]);
  1459. XX      (void) putc (' ', outfile);
  1460. XX      codeexpr (tree->fpexprv.whilestat [1]);
  1461. XX      (void) fprintf (outfile, ">\n");
  1462. XX      break;
  1463. XX    case COMP:
  1464. XX      (void) fprintf (outfile, "<compose ");
  1465. XX      stkptr = 0;
  1466. XX      while (tree != 0)
  1467. XX      {
  1468. XX    if (stkptr >= STKSIZE)
  1469. XX      yyerror ("compiler stack overflow, compose too long");
  1470. XX        stack [stkptr++] = tree->fpexprv.compconstr.compexpr;
  1471. XX    tree = tree->fpexprv.compconstr.compnext;
  1472. XX      }
  1473. XX      while (stkptr != 0)
  1474. XX      {
  1475. XX        codeexpr (stack [--stkptr]);
  1476. XX        (void) putc (' ', outfile);
  1477. XX      }
  1478. XX      (void) fprintf (outfile, ">\n");
  1479. XX      break;
  1480. XX    case AA:
  1481. XX      (void) fprintf (outfile, "<aa ");
  1482. XX      codeexpr (tree->fpexprv.aains);
  1483. XX      (void) fprintf (outfile, ">\n");
  1484. XX      break;
  1485. XX    case CONSTR:
  1486. XX      (void) fprintf (outfile, "<constr ");
  1487. XX      while (tree != 0)
  1488. XX      {
  1489. XX        codeexpr (tree->fpexprv.compconstr.compexpr);
  1490. XX        (void) putc (' ', outfile);
  1491. XX    tree = tree->fpexprv.compconstr.compnext;
  1492. XX      }
  1493. XX      (void) fprintf (outfile, ">\n");
  1494. XX      break;
  1495. XX    case TREE:
  1496. XX    case RINSERT:
  1497. XX    case INSERT:
  1498. XX      if ((tree->fpexprv.aains->exprtype == FNCALL) &&
  1499. XX      (strcmp (tree->fpexprv.aains->fpexprv.funcall, "plus") == 0))
  1500. XX        (void) fprintf (outfile, "plus");
  1501. XX      else if ((tree->fpexprv.aains->exprtype == FNCALL) &&
  1502. XX      (strcmp (tree->fpexprv.aains->fpexprv.funcall, "times") == 0))
  1503. XX        (void) fprintf (outfile, "times");
  1504. XX      else if ((tree->fpexprv.aains->exprtype == FNCALL) &&
  1505. XX      (strcmp (tree->fpexprv.aains->fpexprv.funcall, "and") == 0))
  1506. XX        (void) fprintf (outfile, "and");
  1507. XX      else if ((tree->fpexprv.aains->exprtype == FNCALL) &&
  1508. XX      (strcmp (tree->fpexprv.aains->fpexprv.funcall, "or") == 0))
  1509. XX        (void) fprintf (outfile, "or");
  1510. XX      else
  1511. XX      {
  1512. XX    if (tree->exprtype == TREE)
  1513. XX          (void) fprintf (outfile, "<tree ");
  1514. XX        else if (tree->exprtype == RINSERT)
  1515. XX          (void) fprintf (outfile, "<rinsert ");
  1516. XX        else /* (tree->exprtype == INSERT) */
  1517. XX          (void) fprintf (outfile, "<insert ");
  1518. XX        codeexpr (tree->fpexprv.aains);
  1519. XX        (void) fprintf (outfile, ">\n");
  1520. XX      }
  1521. XX      break;
  1522. XX    case RSEL:
  1523. XX      (void) fprintf (outfile, "<rselect %d>\n", tree->fpexprv.lrsel);
  1524. XX      break;
  1525. XX    case SEL:
  1526. XX      (void) fprintf (outfile, "<select %d>\n", tree->fpexprv.lrsel);
  1527. XX      break;
  1528. XX    case FNCALL:
  1529. XX      (void) fprintf (outfile, "%s", tree->fpexprv.funcall);
  1530. XX      break;
  1531. XX    default:
  1532. XX      if ((tree->exprtype >= NIL) && (tree->exprtype <= CHAR))
  1533. XX      {
  1534. XX    (void) fprintf (outfile, "<const ");
  1535. XX        codeobj (tree);
  1536. XX    (void) fprintf (outfile, ">\n");
  1537. XX      }
  1538. XX      else
  1539. XX        yyerror ("compiler error 10");
  1540. XX  }
  1541. XX}
  1542. XX
  1543. XX/* called for each source FP function */
  1544. XXvoid code (fun, tree)
  1545. XXchar * fun;
  1546. XXfpexpr tree;
  1547. XX{
  1548. XX  char name [256];
  1549. XX
  1550. XX  (void) strcpy (name, fun);
  1551. XX  (void) strcpy (name + strlen (fun), ".ffp");
  1552. XX  outfile = fopen (name, "w");
  1553. XX  if (outfile == 0)
  1554. XX  {
  1555. XX    (void) sprintf (name, "unable to open file %s, aborting\n", name);
  1556. XX    yyerror (name);
  1557. XX  }
  1558. XX  codeexpr (tree);
  1559. XX  (void) fclose (outfile);
  1560. XX}
  1561. XX
  1562. XX/* the following two functions are provided for compatibility */
  1563. XXvoid putfileheader (inname, outname)
  1564. XXchar * inname;
  1565. XXchar * outname;
  1566. XX{
  1567. XX}
  1568. XX
  1569. XXvoid putfiletail ()
  1570. XX{
  1571. XX}
  1572. SHAR_EOF
  1573. if test 5533 -ne "`wc -c mkffp.c`"
  1574. then
  1575. echo shar: error transmitting mkffp.c '(should have been 5533 characters)'
  1576. fi
  1577. #    End of shell archive
  1578. exit 0
  1579.  
  1580.