home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / forth / pfe-0.000 / pfe-0 / pfe-0.9.13 / src / support.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-07-17  |  43.2 KB  |  2,306 lines
  1. /*
  2.  * This file is part of the portable Forth environment written in ANSI C.
  3.  * Copyright (C) 1995  Dirk Uwe Zoller
  4.  *
  5.  * This library is free software; you can redistribute it and/or
  6.  * modify it under the terms of the GNU Library General Public
  7.  * License as published by the Free Software Foundation; either
  8.  * version 2 of the License, or (at your option) any later version.
  9.  *
  10.  * This library is distributed in the hope that it will be useful,
  11.  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12.  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  13.  * See the GNU Library General Public License for more details.
  14.  *
  15.  * You should have received a copy of the GNU Library General Public
  16.  * License along with this library; if not, write to the Free
  17.  * Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  *
  19.  * This file is version 0.9.13 of 17-July-95
  20.  * Check for the latest version of this package via anonymous ftp at
  21.  *    roxi.rz.fht-mannheim.de:/pub/languages/forth/pfe-VERSION.tar.gz
  22.  * or    sunsite.unc.edu:/pub/languages/forth/pfe-VERSION.tar.gz
  23.  * or    ftp.cygnus.com:/pub/forth/pfe-VERSION.tar.gz
  24.  *
  25.  * Please direct any comments via internet to
  26.  *    duz@roxi.rz.fht-mannheim.de.
  27.  * Thank You.
  28.  */
  29. /*
  30.  * support.c ---      Subroutines for the Forth-System
  31.  * (duz 09Jul93)
  32.  */
  33.  
  34. #include "forth.h"
  35. #include "support.h"
  36. #include "compiler.h"
  37. #include "dblsub.h"
  38. #include "term.h"
  39. #include "lined.h"
  40.  
  41. #include <stdio.h>
  42. #include <stdlib.h>
  43. #include <stdarg.h>
  44. #include <math.h>
  45. #include <limits.h>
  46. #include <errno.h>
  47. #include <string.h>
  48. #include <ctype.h>
  49. #include <setjmp.h>
  50.  
  51. #ifdef HAVE_UNISTD_H
  52. #include <unistd.h>        /* access() if available */
  53. #endif
  54.  
  55. #include "missing.h"
  56.  
  57. Cell
  58. aligned (Cell n)        /* return Cell-aligned address */
  59. {
  60.   while (!ALIGNED (n))
  61.     n++;
  62.   return n;
  63. }
  64.  
  65. Cell
  66. dfaligned (Cell n)        /* return double float-aligned address */
  67. {
  68.   while (!DFALIGNED (n))
  69.     n++;
  70.   return n;
  71. }
  72.  
  73. void *
  74. getmem (size_t size)        /* allocate memory, die when failed */
  75. {
  76.   void *p = malloc (size);
  77.  
  78.   if (p == NULL)
  79.     fatal ("out of memory");
  80.   return p;
  81. }
  82.  
  83. void *
  84. xalloc (size_t size)        /* allocate memory, throw when failed */
  85. {
  86.   void *p = malloc (size);
  87.  
  88.   if (p == NULL)
  89.     tHrow (THROW_OUT_OF_MEMORY);
  90.   return p;
  91. }
  92.  
  93. /************************************************************************/
  94. /* miscellaneous execution semantics and runtimes                       */
  95. /************************************************************************/
  96.  
  97. void
  98. sysvar_runtime (void)
  99. {
  100.   *--sp = PFA[0];
  101. }
  102.  
  103. void
  104. sysconst_runtime (void)
  105. {
  106.   *--sp = *(Cell *) PFA[0];
  107. }
  108.  
  109. void
  110. dictvar_runtime (void)
  111. {
  112.   *--sp = (Cell) ((char *) sys.dict + PFA[0]);
  113. }
  114.  
  115. void
  116. dictconst_runtime (void)
  117. {
  118.   *--sp = *(Cell *) ((char *) sys.dict + PFA[0]);
  119. }
  120.  
  121. void                /* compiles the execution semantics */
  122. compile1 (void)            /* of a state smart word */
  123. {
  124.   question_comp_ ();
  125.   COMMA (&((Semant **) W)[-1]->exec[0]);
  126. }
  127.  
  128. void                /* compiles the alternative exec.sem. */
  129. compile2 (void)            /* of an even smarter word (e.g. TO) */
  130. {
  131.   question_comp_ ();
  132.   COMMA (&((Seman2 **) W)[-1]->exec[1]);
  133. }
  134.  
  135. /************************************************************************/
  136. /* strings                                                              */
  137. /************************************************************************/
  138.  
  139. void
  140. strpush (const char *s)
  141. {
  142.   if (s)
  143.     *--sp = (Cell)s, *--sp = strlen (s);
  144.   else
  145.     *--sp = 0, *--sp = 0;
  146. }
  147.  
  148. char *
  149. pocket (void)
  150. {
  151.   char *p = membot.pocket[sys.pocket];
  152.  
  153.   sys.pocket = (sys.pocket + 1) % option.pockets;
  154.   return p;
  155. }
  156.  
  157. int
  158. dash_trailing (char *s, int n)
  159. {
  160.   while (n > 0 && isspace (s[n - 1]))
  161.     n--;
  162.   return n;
  163. }
  164.  
  165. #if 0
  166. char *
  167. strlwr (char *str)
  168. {
  169.   char *p;
  170.   for (p = str; *p; p++)
  171.     *p = tolower (*p);
  172.   return str;
  173. }
  174.  
  175. char *
  176. strupr (char *str)
  177. {
  178.   char *p;
  179.   for (p = str; *p; p++)
  180.     *p = tolower (*p);
  181.   return str;
  182. }
  183. #endif
  184.  
  185. void
  186. lower (char *p, int n)        /* tolower() applied to counted string */
  187. {
  188.   while (--n >= 0)
  189.     *p = tolower (*p), p++;
  190. }
  191.  
  192. void
  193. upper (char *p, int n)        /* toupper() applied to counted string */
  194. {
  195.   while (--n >= 0)
  196.     *p = toupper (*p), p++;
  197. }
  198.  
  199. char *
  200. store_c_string (const char *src, int n, char *dst, int max)
  201. {
  202.   if (n >= max)
  203.     n = max - 1;
  204.   memcpy (dst, src, n);
  205.   dst[n] = '\0';
  206.   return dst;
  207. }
  208.  
  209. char *
  210. store_filename (const char *src, int n, char *dst, int max)
  211. {
  212.   if (n >= max)
  213.     n = max - 1;
  214.   memcpy (dst, src, n);
  215.   dst[n] = '\0';
  216.   if (LOWER_CASE_FN)
  217.     lower (dst, n);
  218.   return dst;
  219. }
  220.  
  221. /************************************************************************/
  222. /* string comparision and pattern matching                              */
  223. /************************************************************************/
  224.  
  225. char *
  226. search (const char *p1, int u1, const char *p2, int u2)
  227. /* search for substring p2/u2 in string p1/u1 */
  228. {
  229.   if (u2 == 0)
  230.     return (char *) p1;
  231.   if (u2 > u1)
  232.     return NULL;
  233.   u1 -= u2;
  234.   for (;;)
  235.     {
  236.       char *p = (char *) memchr (p1, *p2, u1 + 1);
  237.  
  238.       if (p == NULL)
  239.     return NULL;
  240.       if (memcmp (p, p2, u2) == 0)
  241.     return (char *) p;
  242.       u1 -= p - p1;
  243.       if (u1 == 0)
  244.     return NULL;
  245.       p1 = p + 1;
  246.       u1--;
  247.     }
  248. }
  249.  
  250. static int
  251. do_match (const short *pattern, const char *string)
  252. /* match with a processed pattern, i.e. one without `\' escapes */
  253. {
  254.   int c;
  255.  
  256.   for (;;)
  257.     switch (c = *pattern++)
  258.       {
  259.       case '\0':
  260.     return *string == '\0';
  261.       case -'*':
  262.     while (*string && !do_match (pattern, string))
  263.       string++;
  264.     continue;
  265.       case -'?':
  266.     if (*string++)
  267.       continue;
  268.     return 0;
  269.       default:
  270.     if (*string++ == c)
  271.       continue;
  272.     return 0;
  273.       }
  274. }
  275.  
  276. int
  277. match (const char *pattern, const char *string)
  278. /*
  279.  * Match string against pattern.
  280.  * Pattern knows wildcards `*' and `?' and `\' to escape a wildcard.
  281.  */
  282. {
  283.   short buf[0x100], *p = buf;
  284.  
  285.   /* preprocess pattern, remove `\' */
  286.   for (;;)
  287.     {
  288.       int c = *(unsigned char *) pattern;
  289.  
  290.       pattern++;
  291.       switch (c)
  292.     {
  293.     default:
  294.       *p++ = c;
  295.       continue;
  296.     case '\0':
  297.       *p = 0;
  298.       break;
  299.     case '?':
  300.       *p++ = -'?';
  301.       continue;
  302.     case '*':
  303.       *p++ = -'*';
  304.       continue;
  305.     case '\\':
  306.       if (*pattern)
  307.         *p++ = *pattern++;
  308.       else
  309.         *p++ = c;
  310.       continue;
  311.     }
  312.       break;
  313.     }
  314.   /* match with preprocessed pattern */
  315.   return do_match (buf, string);
  316. }
  317.  
  318. /************************************************************************/
  319. /* expanding file names with paths and extensions                       */
  320. /************************************************************************/
  321.  
  322. static const char *
  323. get_token (const char *toks, char del, char *s)
  324. /*
  325.  * Sort of strtok() which is useless here since it isn't reentrant and
  326.  * can't handle empty tokens.
  327.  * Isolates a string delimited by del from toks, copies it to s.
  328.  * Returns a pointer to just after the delimiter inside toks
  329.  * or to the delimiting '\0' of toks if the token was the last one.
  330.  */
  331. {
  332.   while (*toks != del)
  333.     {
  334.       if (*toks == '\0')
  335.     {
  336.       *s = '\0';
  337.       return toks;
  338.     }
  339.       *s++ = *toks++;
  340.     }
  341.   toks++;
  342.   *s = '\0';
  343.   return toks;
  344. }
  345.  
  346. static int
  347. try_extensions (char *nm, const char *ext)
  348. /*
  349.  * Append all extensions from ext to nm.
  350.  * Check if file exists, if so return true, else false.
  351.  */
  352. {
  353.   char *z = nm + strlen (nm);
  354.  
  355.   while (*ext)
  356.     {
  357.       ext = get_token (ext, PATH_DELIMITER, z);
  358.       if (access (nm, F_OK) == 0)
  359.     return 1;
  360.     }
  361.   return 0;
  362. }
  363.  
  364. #define stpcpy(D,S) (strcpy (D, S) + strlen (S))
  365.  
  366. char *
  367. expand_filename (const char *nm, const char *paths,
  368.          const char *exts, char *fn)
  369. /*
  370.  * nm file name input, short
  371.  * path search path for files
  372.  * ext  default file extensions
  373.  * fn   full file name, output
  374.  */
  375. {
  376.   char buf[PATH_LENGTH], *p;
  377.   char *home = getenv ("HOME");
  378.  
  379.   if (*nm == '~' && home)
  380.     {
  381.       p = buf;
  382.       p = stpcpy (p, home);
  383.       p = stpcpy (p, ++nm);
  384.       if (try_extensions (buf, exts))
  385.     return strcpy (fn, buf);
  386.     }
  387.   else
  388.     {
  389.       while (*paths)
  390.     {
  391.       p = buf;
  392.       if (*paths == '~' && home)
  393.         {
  394.           paths++;
  395.           p = stpcpy (p, home);
  396.         }
  397.       paths = get_token (paths, PATH_DELIMITER, p);
  398.       strcat (buf, nm);
  399.       if (try_extensions (buf, exts))
  400.         return strcpy (fn, buf);
  401.     }
  402.     }
  403.   return strcpy (fn, nm);
  404. }
  405.  
  406. /************************************************************************/
  407. /* unsigned and floored divide and number i/o conversion                */
  408. /************************************************************************/
  409.  
  410. udiv_t
  411. udiv (uCell num, uCell denom)    /* unsigned divide procedure, single prec */
  412. {
  413.   udiv_t res;
  414.  
  415.   res.quot = num / denom;
  416.   res.rem = num % denom;
  417.   return res;
  418. }
  419.  
  420. fdiv_t
  421. fdiv (Cell num, Cell denom)    /* floored divide procedure, single prec */
  422. {
  423.   fdiv_t res;
  424.  
  425.   res.quot = num / denom;
  426.   res.rem = num % denom;
  427.   if (res.rem && (num ^ denom) < 0)
  428.     {
  429.       res.quot--;
  430.       res.rem += denom;
  431.     }
  432.   return res;
  433. }
  434.  
  435. uCell
  436. u_d_div (udCell *ud, uCell denom)
  437. /*
  438.  * Divides *ud by denom, leaves result in *ud, returns remainder.
  439.  * For number output conversion: dividing by BASE.
  440.  */
  441. {
  442.   udCell nom = *ud;
  443.   udiv_t h;
  444.  
  445.   h = udiv (D0 (nom), denom);
  446.   D0 (*ud) = h.quot;
  447.   D0 (nom) = h.rem;
  448.   h = udiv (nom.hi, denom);
  449.   D1 (*ud) = h.quot;
  450.   D1 (nom) = h.rem;
  451.   h = udiv (CELL (D1 (nom), D2 (nom)), denom);
  452.   D2 (*ud) = h.quot;
  453.   D2 (nom) = h.rem;
  454.   h = udiv (nom.lo, denom);
  455.   D3 (*ud) = h.quot;
  456.   return h.rem;
  457. }
  458.  
  459. void
  460. u_d_mul (udCell *ud, uCell w, uCell c)
  461. /*
  462.  * Computes *ud * w + c, where w is actually only half of a Cell in size.
  463.  * Leaves result in *ud.
  464.  * For number input conversion: multiply by BASE and add digit.
  465.  */
  466. {
  467.   c += D3 (*ud) * w, D3 (*ud) = W1 (c), c >>= HALFCELL;
  468.   c += D2 (*ud) * w, D2 (*ud) = W1 (c), c >>= HALFCELL;
  469.   c += D1 (*ud) * w, D1 (*ud) = W1 (c), c >>= HALFCELL;
  470.   D0 (*ud) = D0 (*ud) * w + c;
  471. }
  472.  
  473. int
  474. dig2num (Byte c, uCell *n, uCell base)
  475. /*
  476.  * Get value of digit c into *n, return flag: valid digit.
  477.  */
  478. {
  479.   if (c < '0')
  480.     return FALSE;
  481.   if (c <= '9')
  482.     c -= '0';
  483.   else
  484.     {
  485.       if (LOWER_CASE)
  486.     c = toupper (c);
  487.       if (c < 'A')
  488.     return FALSE;
  489.       if (c <= 'Z')
  490.     c -= 'A' - ('9' - '0' + 1);
  491.       else
  492.     {
  493.       if (LOWER_CASE || c < 'a')
  494.         return FALSE;
  495.       c -= 'a' - ('9' - '0' + 1) - ('Z' - 'A' + 1);
  496.     }
  497.     }
  498.   if (c >= base)
  499.     return FALSE;
  500.   *n = c;
  501.   return TRUE;
  502. }
  503.  
  504. char
  505. num2dig (uCell n)        /* make digit */
  506. {
  507.   if (n < 10)
  508.     return n + '0';
  509.   if (n < 10 + 'Z' - 'A' + 1)
  510.     return n - 10 + 'A';
  511.   else
  512.     return n - (10 + 'Z' - 'A' + 1) + 'a';
  513. }
  514.  
  515. void
  516. hold (char c)            /* insert into pictured numeric */
  517. {                /* output string */
  518.   if (HLD <= (char *) DP)
  519.     tHrow (THROW_PICNUM_OVER);
  520.   *--HLD = c;
  521. }
  522.  
  523. const char *
  524. to_number (const char *p, uCell *n, udCell *d, uCell base)
  525. {
  526.   for (; *n > 0; p++, --*n)
  527.     {
  528.       uCell c;
  529.  
  530.       if (!dig2num (*p, &c, base))
  531.     break;
  532.       u_d_mul (d, base, c);
  533.       if (DPL >= 0)
  534.     DPL++;
  535.     }
  536.   return p;
  537. }
  538.  
  539. int
  540. number_question (const char *p, uCell n, dCell *d)
  541. {
  542.   uCell base = 0;
  543.   int sign = 0;
  544.  
  545.   for (; n; p++, n--)
  546.     {
  547.       switch (*p)
  548.     {
  549.     default:
  550.       break;
  551.     case '-':
  552.       if (sign)
  553.         return 0;
  554.       sign = 1;
  555.       continue;
  556. #if PREFIX_HEX
  557.     case PREFIX_HEX:
  558.       if (base)
  559.         return 0;
  560.       base = 16;
  561.       continue;
  562. #endif
  563. #if PREFIX_BINARY
  564.     case PREFIX_BINARY:
  565.       if (base)
  566.         return 0;
  567.       base = 2;
  568.       continue;
  569. #endif
  570.     }
  571.       break;
  572.     }
  573.   if (base == 0)
  574.     base = BASE;
  575.   d->lo = d->hi = 0;
  576.   DPL = -1;
  577.   p = to_number (p, &n, (udCell *) d, base);
  578.   if (n == 0)
  579.     goto happy;
  580.   if (*p != '.')
  581.     return 0;
  582.   DPL = 0;
  583.   p++;
  584.   n--;
  585.   p = to_number (p, &n, (udCell *) d, base);
  586.   if (n != 0)
  587.     return 0;
  588. happy:
  589.   if (sign)
  590.     dnegate (d);
  591.   return 1;
  592. }
  593.  
  594. #if defined USE_STRTOD        /* most systems have good strtod */
  595.  
  596. static int
  597. to_float (char *p, Cell n, double *r)
  598. {
  599.   char buf[80], *q;
  600.  
  601.   store_c_string (p, n, buf, sizeof buf);
  602.   if (tolower (buf[n - 1]) == 'e')
  603.     {
  604.       buf[n++] = '0';
  605.       buf[n] = '\0';
  606.     }
  607.   *r = strtod (buf, &q);
  608.   if (q == NULL)
  609.     return 1;
  610.   while (isspace (*q))
  611.     q++;
  612.   return *q == '\0';
  613. }
  614.  
  615. #else                /* but some haven't */
  616.  
  617. static int
  618. to_float (char *p, Cell n, double *r)
  619. {
  620.   enum state             /* states of the state machine */
  621.   {
  622.     bpn,            /* before point, maybe sign */
  623.     bp,                /* before point, no more sign (had one) */
  624.     ap,                /* after point */
  625.     exn,            /* exponent, maybe sign */
  626.     ex                /* exponent, no more sign */
  627.   };
  628.   enum state state = bpn;
  629.   int sign = 1;            /* sign of mantissa */
  630.   long double mant = 0;        /* the mantissa */
  631.   int esign = 1;        /* sign of exponent */
  632.   int exp = 0;            /* the exponent */
  633.   int scale = 0;        /* number of digits after point */
  634.  
  635.   while (--n >= 0)
  636.     {
  637.       char c = *p++;
  638.  
  639.       switch (state)
  640.     {
  641.     case bpn:
  642.       switch (c)
  643.         {
  644.         case '-':
  645.           sign = -1;
  646.         case '+':
  647.           state = bp;
  648.           continue;
  649.         case '.':
  650.           state = ap;
  651.           continue;
  652.         default:
  653.           if (isspace (c))
  654.         continue;
  655.           if (isdigit (c))
  656.         {
  657.           mant = c - '0';
  658.           state = bp;
  659.           continue;
  660.         }
  661.         }
  662.       return 0;
  663.     case bp:
  664.       switch (c)
  665.         {
  666.         case '.':
  667.           state = ap;
  668.           continue;
  669.         case '-':
  670.           esign = -1;
  671.         case '+':
  672.           state = ex;
  673.           continue;
  674.         case 'e':
  675.           if (!LOWER_CASE)
  676.         return 0;
  677.         case 'E':
  678.           state = exn;
  679.           continue;
  680.         default:
  681.           if (isdigit (c))
  682.         {
  683.           mant *= 10;
  684.           mant += c - '0';
  685.           continue;
  686.         }
  687.         }
  688.       return 0;
  689.     case ap:
  690.       switch (c)
  691.         {
  692.         case '-':
  693.           esign = -1;
  694.         case '+':
  695.           state = ex;
  696.           continue;
  697.         case 'e':
  698.           if (!LOWER_CASE)
  699.         return 0;
  700.         case 'E':
  701.           state = exn;
  702.           continue;
  703.         default:
  704.           if (isdigit (c))
  705.         {
  706.           mant *= 10;
  707.           mant += c - '0';
  708.           scale--;
  709.           continue;
  710.         }
  711.         }
  712.       return 0;
  713.     case exn:
  714.       switch (c)
  715.         {
  716.         case '-':
  717.           esign = -1;
  718.         case '+':
  719.           state = ex;
  720.           continue;
  721.         default:
  722.           if (isdigit (c))
  723.         {
  724.           exp = c - '0';
  725.           state = ex;
  726.           continue;
  727.         }
  728.         }
  729.       return 0;
  730.     case ex:
  731.       if (isdigit (c))
  732.         {
  733.           exp *= 10;
  734.           exp += c - '0';
  735.           continue;
  736.         }
  737.       return 0;
  738.     }
  739.     }
  740.   *r = sign * mant * pow10 (scale + esign * exp);
  741.   return 1;
  742. }
  743.  
  744. #endif
  745.  
  746. /*
  747.  * These are for internal use only (SEE and debugger),
  748.  * The real `UD.R' etc. words use HOLD and the memory area below PAD
  749.  */
  750.  
  751. char *
  752. str_ud_dot_r (udCell ud, char *p, int w, int base)
  753. {
  754.   *--p = '\0';
  755.   do
  756.     {
  757.       *--p = num2dig (u_d_div (&ud, base));
  758.       w--;
  759.     }
  760.   while (ud.lo || ud.hi);
  761.   while (w > 0)
  762.     *--p = ' ', w--;
  763.   return p;
  764. }
  765.  
  766. char *
  767. str_d_dot_r (dCell d, char *p, int w, int base)
  768. {
  769.   int sign = 0;
  770.  
  771.   if (d.hi < 0)
  772.     dnegate (&d), sign = 1;
  773.   *--p = '\0';
  774.   do
  775.     {
  776.       *--p = num2dig (u_d_div ((udCell *) &d, base));
  777.       w--;
  778.     }
  779.   while (d.lo || d.hi);
  780.   if (sign)
  781.     *--p = '-', w--;
  782.   while (w > 0)
  783.     *--p = ' ', w--;
  784.   return p;
  785. }
  786.  
  787. char *
  788. str_dot (Cell n, char *p, int base)
  789. {
  790.   dCell d;
  791.   char *bl;
  792.  
  793.   *--p = '\0';
  794.   bl = p - 1;
  795.   d.lo = n;
  796.   d.hi = n < 0 ? -1 : 0;
  797.   p = str_d_dot_r (d, p, 0, base);
  798.   *bl = ' ';
  799.   return p;
  800. }
  801.  
  802. /************************************************************************/
  803. /* console i/o                                                          */
  804. /************************************************************************/
  805.  
  806. /* output adjusting the OUT variable */
  807.  
  808. void
  809. outc (char c)            /* emit single character */
  810. {
  811.   int x, y;
  812.  
  813.   c_putc (c);
  814.   c_wherexy (&x, &y);
  815.   OUT = x;
  816. }
  817.  
  818. void
  819. outs (const char *s)        /* type a string */
  820. {
  821.   int x, y;
  822.  
  823.   c_puts (s);
  824.   c_wherexy (&x, &y);
  825.   OUT = x;
  826. }
  827.  
  828. int
  829. outf (const char *s,...)    /* type a string with formatting */
  830. {
  831.   char buf[0x200];
  832.   va_list p;
  833.   int r;
  834.  
  835.   va_start (p, s);
  836.   r = vsprintf (buf, s, p);
  837.   outs (buf);
  838.   va_end (p);
  839.   return r;
  840. }
  841.  
  842. void
  843. type (const char *s, Cell n)    /* TYPE counted string to terminal */
  844. {
  845.   int x, y;
  846.  
  847.   while (--n >= 0)
  848.     c_putc_noflush (*s++);
  849.   c_wherexy (&x, &y);
  850.   OUT = x;
  851.   c_flush ();
  852. }
  853.  
  854. void
  855. type_on_line (const char *s, Cell n)
  856. {
  857.   if (OUT + n >= cols)
  858.     cr_ ();
  859.   type (s, n);
  860. }
  861.  
  862. void
  863. spaces (int n)
  864. {
  865.   int x, y;
  866.  
  867.   while (--n >= 0)
  868.     c_putc_noflush (' ');
  869.   fflush (stdout);
  870.   c_wherexy (&x, &y);
  871.   OUT = x;
  872. }
  873.  
  874. void
  875. tab (int n)
  876. {
  877.   spaces (n - OUT % n);
  878. }
  879.  
  880. void
  881. dot_line (File *fid, Cell n, Cell l)
  882. {
  883.   char *p = block (fid, n) + l * 64;
  884.   type (p, dash_trailing (p, 64));
  885. }
  886.  
  887. /* input */
  888.  
  889. static int
  890. get_line (char *p, Cell n)
  891. {
  892.   char *q, buf[0x100];
  893.   extern code (bye);
  894.  
  895.   q = fgets (buf, n, stdin);
  896.   if (q == NULL)
  897.     bye_ ();
  898.   q = strrchr (q, '\n');
  899.   if (q)
  900.     *q = '\0';
  901.   strcpy (p, buf);
  902.   return strlen (p);
  903. }
  904.  
  905. int
  906. expect (char *p, Cell n)    /* EXPECT counted string from terminal, */
  907. {                /* simple editing facility with Backspace, */
  908.   int i;            /* very traditional, use lined() instead! */
  909.   char c;
  910.  
  911.   if (option.canonical)
  912.     return get_line (p, n);
  913.   for (i = 0; i < n;)
  914.     {
  915.       switch (c = c_getkey ())
  916.     {
  917.     default:
  918.       p[i++] = c;
  919.       outc (c);
  920.       continue;
  921.     case 27:
  922.       for (; i > 0; i--)
  923.         backspace_ ();
  924.       continue;
  925.     case '\t':
  926.       while (i < n)
  927.         {
  928.           p[i++] = ' ';
  929.           space_ ();
  930.           if (OUT % 8 == 0)
  931.         break;
  932.         }
  933.       continue;
  934.     case '\r':
  935.     case '\n':
  936.       space_ ();
  937.       goto fin;
  938.     case 127:
  939.     case '\b':
  940.       if (i <= 0)
  941.         {
  942.           c_bell ();
  943.           continue;
  944.         }
  945.       i--;
  946.       backspace_ ();
  947.       continue;
  948.     }
  949.     }
  950. fin:p[i] = 0;
  951.   SPAN = i;
  952.   return i;
  953. }
  954.  
  955. int
  956. aCcept (char *p, int n)        /* better input facility using lined() */
  957. {
  958.   extern struct lined accept_lined;
  959.  
  960.   if (option.canonical)
  961.     return get_line (p, n);
  962.   accept_lined.string = p;
  963.   accept_lined.max_length = n;
  964.   lined (&accept_lined, NULL);
  965.   space_ ();
  966.   return accept_lined.length;
  967. }
  968.  
  969. int
  970. question_stop (void)        /* check for 'q' pressed */
  971. {
  972.   if (ekeypressed ())
  973.     {
  974.       if (tolower (c_getkey ()) == 'q')
  975.     return 1;
  976.       if (tolower (c_getkey ()) == 'q')
  977.     return 1;
  978.     }
  979.   return 0;
  980. }
  981.  
  982. int
  983. question_cr (void)
  984. /*
  985.  * Like CR but stop after one screenful and return flag if 'q' pressed.
  986.  * Improved by aph@oclc.org (Andrew Houghton)
  987.  */
  988. {
  989.   static char more[] = "more? ";
  990.   static char help[] = "\r[next line=<return>, next page=<space>, quit=q] ";
  991.  
  992.   cr_ ();
  993.   if (option.canonical)
  994.     return 0;
  995.   if (sys.lines < sys.more)
  996.     return 0;
  997.   sys.lines = 0;
  998.   for (;;)
  999.     {
  1000.       outs (more);
  1001.       switch (tolower (c_getkey ()))
  1002.     {
  1003.     case 'n':        /* no more */
  1004.     case 'q':        /* quit    */
  1005.       return 1;
  1006.     case 'y':        /* more    */
  1007.     case ' ':        /* page    */
  1008.       while (OUT)
  1009.         backspace_ ();
  1010.       sys.more = rows - 1;
  1011.       return 0;
  1012.     case '\r':        /* line    */
  1013.     case '\n':        /* line    */
  1014.       while (OUT)
  1015.         backspace_ ();
  1016.       sys.more = 1;
  1017.       return 0;
  1018.     default:        /* unknown */
  1019.       c_bell ();
  1020.       /* ... */
  1021.     case '?':        /* help    */
  1022.     case 'h':        /* help    */
  1023.       outs (help);
  1024.       break;
  1025.     }
  1026.     }
  1027. }
  1028.  
  1029. /************************************************************************/
  1030. /* files                                                                */
  1031. /************************************************************************/
  1032.  
  1033. void
  1034. file_errorz (const char *fn)
  1035. {
  1036.   tHrow (-256 - errno, fn);
  1037. }
  1038.  
  1039. void
  1040. file_error (const char *fn, int len)
  1041. {
  1042.   char buf[PATH_LENGTH];
  1043.  
  1044.   store_filename (fn, len, buf, sizeof buf);
  1045.   file_errorz (buf);
  1046. }
  1047.  
  1048. static File *
  1049. free_file_slot (void)
  1050. {
  1051.   File *f;
  1052.  
  1053.   for (f = membot.files; f < memtop.files; f++)
  1054.     if (f->f == NULL)
  1055.       {
  1056.     memset (f, 0, sizeof *f);
  1057.     return f;
  1058.       }
  1059.   return NULL;
  1060. }
  1061.  
  1062. int
  1063. file_access (const char *fn, int len)
  1064. /*
  1065.  * Return best possible access method,
  1066.  * 0 if no access but file exists, -1 if file doesn't exist.
  1067.  */
  1068. {
  1069.   char buf[PATH_LENGTH];
  1070.  
  1071.   store_filename (fn, len, buf, sizeof buf);
  1072.   if (access (buf, F_OK) != 0)
  1073.     return -1;
  1074.   if (access (buf, R_OK | W_OK) == 0)
  1075.     return FMODE_RW;
  1076.   if (access (buf, R_OK) == 0)
  1077.     return FMODE_RO;
  1078.   if (access (buf, W_OK) == 0)
  1079.     return FMODE_WO;
  1080.   return 0;
  1081. }
  1082.  
  1083. static char open_mode[][4] =    /* mode strings for fopen() */
  1084. {
  1085.   "r", "r+", "r+",        /* R/O W/O R/W */
  1086.   "rb", "r+b", "r+b",        /* after application of BIN */
  1087. };
  1088.  
  1089. File *
  1090. open_file (const char *name, int len, int mode)
  1091. {
  1092.   File *fid;
  1093.  
  1094.   fid = free_file_slot ();
  1095.   if (fid == NULL)
  1096.     return NULL;
  1097.   store_filename (name, len, fid->name, sizeof fid->name);
  1098.   fid->mode = mode;
  1099.   fid->last_op = 0;
  1100.   strcpy (fid->mdstr, open_mode[mode - FMODE_RO]);
  1101.   if ((fid->f = fopen (fid->name, fid->mdstr)) == NULL)
  1102.     return NULL;
  1103.   fid->size = (uCell) (fsize (fid->f) / BPBUF);
  1104.   fid->n = (unsigned) -1;
  1105.   return fid;
  1106. }
  1107.  
  1108. File *
  1109. create_file (const char *name, int len, int mode)
  1110. {
  1111.   char fn[PATH_LENGTH];
  1112.   File *fid;
  1113.  
  1114.   store_filename (name, len, fn, sizeof fn);
  1115.   fclose (fopen (fn, "wb"));
  1116.   fid = open_file (name, len, mode);
  1117.   if (fid)
  1118.     {
  1119.       return fid;
  1120.     }
  1121.   else
  1122.     {
  1123.       remove (fn);
  1124.       return NULL;
  1125.     }
  1126. }
  1127.  
  1128. int
  1129. close_file (File *fid)
  1130. {
  1131.   int res = 0;
  1132.  
  1133.   if (fid->f)
  1134.     {
  1135.       res = fclose (fid->f);
  1136.       memset (fid, 0, sizeof *fid);
  1137.     }
  1138.   return res;
  1139. }
  1140.  
  1141. int
  1142. reposition_file (File *fid, long pos)
  1143. {
  1144.   fid->last_op = 0;
  1145.   return fseek (fid->f, pos, SEEK_SET) ? errno : 0;
  1146. }
  1147.  
  1148. static int
  1149. can_read (File *fid)
  1150. /*
  1151.  * Called before trying to read from a file.
  1152.  * Checks if you may, maybe fseeks() so you can.
  1153.  */
  1154. {
  1155.   switch (fid->mode)        /* check permission */
  1156.     {
  1157.     case FMODE_WO:
  1158.     case FMODE_WOB:
  1159.       return 0;
  1160.     }
  1161.   if (fid->last_op < 0)        /* last operation was write? */
  1162.     fseek (fid->f, 0, SEEK_CUR); /* then seek to this position */
  1163.   fid->last_op = 1;
  1164.   return 1;
  1165. }
  1166.  
  1167. static int
  1168. can_write (File *fid)
  1169. /*
  1170.  * Called before trying to write to a file.
  1171.  * Checks if you may, maybe fseeks() so you can.
  1172.  */
  1173. {
  1174.   switch (fid->mode)        /* check permission */
  1175.     {
  1176.     case FMODE_RO:
  1177.     case FMODE_ROB:
  1178.       return 0;
  1179.     }
  1180.   if (fid->last_op > 0)        /* last operation was read? */
  1181.     fseek (fid->f, 0, SEEK_CUR); /* then seek to this position */
  1182.   fid->last_op = -1;
  1183.   return 1;
  1184. }
  1185.  
  1186. int
  1187. read_file (void *p, uCell *n, File *fid)
  1188. {
  1189.   int m;
  1190.  
  1191.   if (!can_read (fid))
  1192.     return EPERM;
  1193.   errno = 0;
  1194.   m = fread (p, 1, *n, fid->f);
  1195.   if (m != *n)
  1196.     {
  1197.       *n = m;
  1198.       return errno;
  1199.     }
  1200.   else
  1201.     return 0;
  1202. }
  1203.  
  1204. int
  1205. write_file (void *p, uCell n, File *fid)
  1206. {
  1207.   if (!can_write (fid))
  1208.     return EPERM;
  1209.   errno = 0;
  1210.   return fwrite (p, 1, n, fid->f) != n ? errno : 0;
  1211. }
  1212.  
  1213. int
  1214. resize_file (File *fid, long size)
  1215. {
  1216.   long pos;
  1217.   int r;
  1218.  
  1219.   if (fid == NULL || fid->f == NULL)
  1220.     tHrow (THROW_FILE_NEX);
  1221.  
  1222.   pos = ftell (fid->f);
  1223.   if (pos == -1)
  1224.     return -1;
  1225.  
  1226.   fclose (fid->f);
  1227.   r = resize (fid->name, size);
  1228.   fid->f = fopen (fid->name, fid->mdstr);
  1229.  
  1230.   if (pos < size)
  1231.     fseek (fid->f, pos, SEEK_SET);
  1232.   else
  1233.     fseek (fid->f, 0, SEEK_END);
  1234.   return r;
  1235. }
  1236.  
  1237. int
  1238. read_line (char *p, uCell *u, File *fid, Cell *ior)
  1239. {
  1240.   int c, n;
  1241.  
  1242.   if (!can_read (fid))
  1243.     return EPERM;
  1244.   if (feof (fid->f))
  1245.     {
  1246.       *u = 0;
  1247.       *ior = 0;
  1248.       return FALSE;
  1249.     }
  1250.   fid->pos = ftell (fid->f);
  1251.   for (n = 0; n < *u; n++)
  1252.     switch (c = getc (fid->f))
  1253.       {
  1254.       case EOF:
  1255.     if (!ferror (fid->f))
  1256.       goto happy;
  1257.     *u = n;
  1258.     *ior = errno;
  1259.     return FALSE;
  1260.       case '\r':
  1261.     c = getc (fid->f);
  1262.     if (c != '\n')
  1263.       ungetc (c, fid->f);
  1264.       case '\n':
  1265.     goto happy;
  1266.       default:
  1267.     *p++ = c;
  1268.       }
  1269. happy:
  1270.   *u = n;
  1271.   *ior = 0;
  1272.   fid->n++;
  1273.   return TRUE;
  1274. }
  1275.  
  1276. int
  1277. systemf (const char *s,...)    /* issue a system() call after formatting */
  1278. {
  1279.   char buf[0x100];
  1280.   va_list p;
  1281.   int r;
  1282.  
  1283.   va_start (p, s);
  1284.   vsprintf (buf, s, p);
  1285.   va_end (p);
  1286.   system_terminal ();
  1287.   swap_signals ();
  1288.   r = system (buf);
  1289.   swap_signals ();
  1290.   interactive_terminal ();
  1291.   c_normal ();
  1292.   return r;
  1293. }
  1294.  
  1295. /************************************************************************/
  1296. /* source input                                                         */
  1297. /************************************************************************/
  1298.  
  1299. /* 1. read from terminal */
  1300.  
  1301. code (query)
  1302. {
  1303.   SOURCE_ID = 0;
  1304.   BLK = 0;
  1305.   TO_IN = 0;
  1306.   TIB = membot.tib;
  1307.   NUMBER_TIB = aCcept (TIB, TIB_SIZE);
  1308.   SPAN = NUMBER_TIB;
  1309. }
  1310.  
  1311. /* 2. read from text-file */
  1312.  
  1313. int
  1314. next_line (void)
  1315. {
  1316.   Cell ior;
  1317.   uCell len;
  1318.  
  1319.   len = sizeof SOURCE_FILE->buffer;
  1320.   if (!read_line (SOURCE_FILE->buffer, &len, SOURCE_FILE, &ior))
  1321.     {
  1322.       SOURCE_FILE->len = len;
  1323.       return 0;
  1324.     }
  1325.   TIB = SOURCE_FILE->buffer;
  1326.   NUMBER_TIB = SOURCE_FILE->len = len;
  1327.   BLK = 0;
  1328.   TO_IN = 0;
  1329.   return 1;
  1330. }
  1331.  
  1332. /* 3. read from block-file */
  1333.  
  1334. File *
  1335. open_block_file (const char *name, int len)
  1336. {
  1337.   char nm[PATH_LENGTH], fn[PATH_LENGTH];
  1338.   int mode;
  1339.  
  1340.   store_filename (name, len, nm, sizeof nm);
  1341.   expand_filename (nm, option.blkpaths, option.blkext, fn);
  1342.   mode = file_access (fn, strlen (fn));
  1343.   if (mode <= 0)
  1344.     return NULL;
  1345.   return open_file (fn, strlen (fn), mode + FMODE_BIN);
  1346. }
  1347.  
  1348. int
  1349. use_block_file (const char *name, int len)
  1350. {
  1351.   File *fid;
  1352.  
  1353.   fid = open_block_file (name, len);
  1354.   if (fid == NULL)
  1355.     return FALSE;
  1356.   if (BLOCK_FILE)
  1357.     {
  1358.       save_buffers_ ();
  1359.       close_file (BLOCK_FILE);
  1360.     }
  1361.   BLOCK_FILE = fid;
  1362.   return TRUE;
  1363. }
  1364.  
  1365. void
  1366. read_write (File *fid, char *p, uCell n, int readflag)
  1367. /* very traditional block read/write primitive */
  1368. {
  1369.   size_t len;
  1370.  
  1371.   question_file_open (fid);
  1372.   clearerr (fid->f);
  1373.   if (n > fid->size)
  1374.     tHrow (THROW_INVALID_BLOCK);
  1375.   if (readflag && n == fid->size)
  1376.     {
  1377.       memset (p, ' ', BPBUF);
  1378.       return;
  1379.     }
  1380.   if (fseek (fid->f, n * BPBUF, SEEK_SET) != 0)
  1381.     file_errorz (fid->name);
  1382.   if (readflag)
  1383.     {
  1384.       if (!can_read (fid))
  1385.     tHrow (THROW_BLOCK_READ);
  1386.       len = fread (p, 1, BPBUF, fid->f);
  1387.       if (ferror (fid->f))
  1388.     file_errorz (fid->name);
  1389.       memset (p + len, ' ', BPBUF - len);
  1390.     }
  1391.   else
  1392.     {
  1393.       if (!can_write (fid))
  1394.     tHrow (THROW_BLOCK_WRITE);
  1395.       len = fwrite (p, 1, BPBUF, fid->f);
  1396.       if (len < BPBUF || ferror (fid->f))
  1397.     file_errorz (fid->name);
  1398.       if (n == fid->size)
  1399.     fid->size++;
  1400.     }
  1401.   return;
  1402. }
  1403.  
  1404. char *
  1405. buffer (File *fid, uCell n, int *reload)
  1406. {
  1407.   question_file_open (fid);
  1408.   if (fid->n != n)
  1409.     {
  1410.       if (fid->updated)
  1411.     read_write (fid, fid->buffer, fid->n, FALSE);
  1412.       fid->n = n;
  1413.       *reload = 1;
  1414.     }
  1415.   else
  1416.     *reload = 0;
  1417.   return fid->buffer;
  1418. }
  1419.  
  1420. char *
  1421. block (File *fid, uCell n)
  1422. {
  1423.   char *p;
  1424.   int reload;
  1425.  
  1426.   p = buffer (fid, n, &reload);
  1427.   if (reload)
  1428.     read_write (fid, p, n, TRUE);
  1429.   return p;
  1430. }
  1431.  
  1432. void
  1433. empty_buffers (File *fid)
  1434. {
  1435.   question_file_open (fid);
  1436.   ZERO (fid->buffer);
  1437.   fid->n = UINT_MAX;
  1438.   fid->updated = 0;
  1439. }
  1440.  
  1441. void
  1442. save_buffers (File *fid)
  1443. {
  1444.   if (fid && fid->updated)
  1445.     {
  1446.       read_write (fid, fid->buffer, fid->n, FALSE);
  1447.       fflush (fid->f);
  1448.       fid->updated = 0;
  1449.     }
  1450. }
  1451.  
  1452. void
  1453. update (File *fid)
  1454. {
  1455.   question_file_open (fid);
  1456.   if ((int) fid->n < 0)
  1457.     tHrow (THROW_INVALID_BLOCK);
  1458.   fid->updated = 1;
  1459. }
  1460.  
  1461. void
  1462. list (File *fid, int n)
  1463. {
  1464.   int i;
  1465.  
  1466.   for (i = 0; i < 16; i++)
  1467.     {
  1468.       cr_ ();
  1469.       outf ("%2d: ", i);
  1470.       dot_line (fid, n, i);
  1471.     }
  1472.   space_ ();
  1473.   SCR = n;
  1474. }
  1475.  
  1476. /* dispatch input source */
  1477.  
  1478. void
  1479. source (char **p, int *n)
  1480. {
  1481.   switch (SOURCE_ID)
  1482.     {
  1483.     case -1:            /* string from EVALUATE */
  1484.       *p = TIB;
  1485.       *n = NUMBER_TIB;
  1486.       break;
  1487.     case 0:            /* string from QUERY or BLOCK */
  1488.       if (BLK)
  1489.     {
  1490.       *p = block (BLOCK_FILE, BLK);
  1491.       *n = BPBUF;
  1492.     }
  1493.       else
  1494.     {
  1495.       *p = TIB;
  1496.       *n = NUMBER_TIB;
  1497.     }
  1498.       break;
  1499.     default:            /* source line from text file */
  1500.       *p = SOURCE_FILE->buffer;
  1501.       *n = SOURCE_FILE->len;
  1502.     }
  1503. }
  1504.  
  1505. void *
  1506. save_input (void *p)
  1507. {
  1508.   Iframe *iframe = (Iframe *) p;
  1509.  
  1510.   --iframe;
  1511.   iframe->magic = INPUT_MAGIC;
  1512.   iframe->input = sys.input;
  1513.   iframe->prev = sys.saved_input;
  1514.   sys.saved_input = iframe;
  1515.  
  1516.   p = (void *) iframe;
  1517.   return p;
  1518. }
  1519.  
  1520. void *
  1521. restore_input (void *p)
  1522. {
  1523.   Iframe *iframe = (Iframe *) p;
  1524.  
  1525.   if (iframe->magic != INPUT_MAGIC)
  1526.     tHrow (THROW_ARG_TYPE);
  1527.   sys.input = iframe->input;
  1528.   sys.saved_input = iframe->prev;
  1529.   ++iframe;
  1530.  
  1531.   p = (void *) iframe;
  1532.   return p;
  1533. }
  1534.  
  1535. int
  1536. refill (void)
  1537. {
  1538.   switch (SOURCE_ID)
  1539.     {
  1540.     case -1:
  1541.       return 0;
  1542.     case 0:
  1543.       if (BLK)
  1544.     {
  1545.       BLK++;
  1546.       TO_IN = 0;
  1547.     }
  1548.       else
  1549.     query_ ();
  1550.       return 1;
  1551.     default:
  1552.       return next_line ();
  1553.     }
  1554. }
  1555.  
  1556. void
  1557. skip_delimiter (char del)
  1558. {
  1559.   char *q;
  1560.   int i, n;
  1561.  
  1562.   source (&q, &n);
  1563.   if (del == ' ')
  1564.     for (i = TO_IN; i < n && isascii (q[i]) && isspace (q[i]); i++);
  1565.   else
  1566.     for (i = TO_IN; i < n && q[i] == del; i++);
  1567.   TO_IN = i;
  1568. }
  1569.  
  1570. int
  1571. parse (char del, char **p, uCell *l)
  1572. {
  1573.   char *q;
  1574.   int i, n;
  1575.  
  1576.   source (&q, &n);
  1577.   *p = q + TO_IN;
  1578.   if (del == ' ')
  1579.     for (i = TO_IN; i < n && !(isascii (q[i]) && isspace (q[i])); i++);
  1580.   else
  1581.     for (i = TO_IN; i < n && q[i] != del; i++);
  1582.   *l = i - TO_IN;
  1583.   if (i == n)
  1584.     {
  1585.       TO_IN = i;
  1586.       return 0;
  1587.     }
  1588.   else
  1589.     {
  1590.       TO_IN = i + 1;
  1591.       return 1;
  1592.     }
  1593. }
  1594.  
  1595. char *
  1596. word (char del)            /* action of WORD callable from C functions */
  1597. {
  1598.   char *p, *q;
  1599.   int n, i;
  1600.  
  1601.   skip_delimiter (del);
  1602.   source (&q, &n);
  1603.   q += TO_IN;
  1604.   n -= TO_IN;
  1605.   p = (char *) DP + 1;
  1606.   if (del == ' ')
  1607.     for (i = 0; i < n && !(isascii (*q) && isspace (*q)); i++)
  1608.       *p++ = *q++;
  1609.   else
  1610.     for (i = 0; i < n && *q != del; i++)
  1611.       *p++ = *q++;
  1612.   TO_IN += i + (i < n);
  1613.   *p = '\0';
  1614.   if (i > 255)
  1615.     tHrow (THROW_PARSE_OVER);
  1616.   *DP = i;
  1617.   return (char *) DP;
  1618. }
  1619.  
  1620. /************************************************************************/
  1621. /* inner and outer interpreter                                          */
  1622. /************************************************************************/
  1623.  
  1624. typedef struct            /* jumpbuf is a jmp_buf enhanced by */
  1625. {                /* space to preserve global variables */
  1626.   jmp_buf jmp;            /* stored in registers. */
  1627. #ifdef REGRP
  1628.   Xt **rp;
  1629. #endif
  1630. #ifdef REGSP
  1631.   Cell *sp;
  1632. #endif
  1633. #ifdef REGLP
  1634.   Cell *lp;
  1635. #endif
  1636. #ifdef REGFP
  1637.   double *fp;
  1638. #endif
  1639. }
  1640. jumpbuf;
  1641.  
  1642. Code (jump)            /* longjmp via (jumpbuf*) following inline */
  1643. {                /* purpose: stop the inner interpreter */
  1644.   jumpbuf *buf = (jumpbuf *) *ip;
  1645.  
  1646. #ifdef REGRP            /* save global register variables */
  1647.   buf->rp = rp;
  1648. #endif
  1649. #ifdef REGSP
  1650.   buf->sp = sp;
  1651. #endif
  1652. #ifdef REGLP
  1653.   buf->lp = lp;
  1654. #endif
  1655. #ifdef REGFP
  1656.   buf->fp = fp;
  1657. #endif
  1658.   longjmp (buf->jmp, 1);
  1659. }
  1660.  
  1661. void
  1662. run_forth (Xt xt)        /* Run a forth word from within C-code. */
  1663. {                /* This is the inner interpreter. */
  1664.   static pCode jump_p = jump_;
  1665.   jumpbuf stop;
  1666.   Xt list[3];
  1667.  
  1668.   list[0] = xt;
  1669.   list[1] = &jump_p;
  1670.   list[2] = (Xt) &stop;
  1671.   ip = list;
  1672.   if (setjmp (stop.jmp))
  1673.     {
  1674. #ifdef REGRP            /* restore global register variables */
  1675.       rp = stop.rp;        /* clobbered by longjmp() */
  1676. #endif
  1677. #ifdef REGSP
  1678.       sp = stop.sp;
  1679. #endif
  1680. #ifdef REGLP
  1681.       lp = stop.lp;
  1682. #endif
  1683. #ifdef REGFP
  1684.       fp = stop.fp;
  1685. #endif
  1686.       return;
  1687.     }
  1688.   for (;;)
  1689.     {
  1690. #ifdef W
  1691.       Xt w;
  1692. #define NEXT w = *ip++, (*w) ()    /* ip is register but W isn't */
  1693. #else
  1694. #define NEXT W = *ip++, (*W) ()    /* ip and W are same: register or not */
  1695. #endif
  1696. #ifdef UNROLL_NEXT        /* if it helps */
  1697.       NEXT; NEXT; NEXT; NEXT;    /* do a little loop unrolling for speed */
  1698.       NEXT; NEXT; NEXT; NEXT;
  1699. #else
  1700.       NEXT;            /* on some machines it doesn't do any good */
  1701. #endif
  1702.     }
  1703. }
  1704.  
  1705. void
  1706. call_forth (Xt xt)
  1707. {
  1708. #if 0 && defined SunOS
  1709.   void *saved_ip;
  1710.  
  1711.   saved_ip = ip;
  1712.   printf ("%X/%X\n", ip, saved_ip);
  1713.   run_forth (xt);
  1714.   printf ("%X/%X\n", ip, saved_ip);
  1715.   ip = saved_ip;
  1716.   printf ("%X/%X\n\n", ip, saved_ip);
  1717. #else
  1718.   Xt *saved_ip = ip;
  1719.  
  1720.   run_forth (xt);
  1721.   ip = saved_ip;
  1722. #endif
  1723. }
  1724.  
  1725. void
  1726. normal_execute (Xt xt)        /* i.e. w/o debugging */
  1727. {
  1728. #ifdef W
  1729.   call_forth (xt);
  1730. #else
  1731.   W = xt;
  1732.   (*W) ();
  1733. #endif
  1734. }
  1735.  
  1736. void (*execute) (Xt xt) = normal_execute;
  1737.  
  1738. code (interpret)
  1739. {
  1740.   char *s, *p;
  1741.   int len;
  1742.   dCell d;
  1743.   double f;
  1744.  
  1745.   for (;;)
  1746.     {
  1747.       for (;;)
  1748.     {
  1749.       p = word (' ');
  1750.       if ((len = *(Byte *) p++) != 0)
  1751.         break;
  1752.       switch (SOURCE_ID)
  1753.         {
  1754.         default:
  1755.           if (next_line ())
  1756.         continue;
  1757.         case 0:
  1758.         case -1:
  1759.           return;
  1760.         }
  1761.     }
  1762.       if (STATE)
  1763.     {
  1764.       if (sys.locals && compile_local (p, len))
  1765.         continue;
  1766.       s = find (p, len);
  1767.       if (s != NULL)
  1768.         {
  1769.           Xt xt = name_from (s);
  1770.  
  1771.           if (*s & IMMEDIATE)
  1772.         {
  1773.           call_forth (xt);
  1774.           question_stack_ ();
  1775.         }
  1776.           else
  1777.         COMMA (xt);
  1778.           continue;
  1779.         }
  1780.       if (number_question (p, len, &d))
  1781.         {
  1782.           if (DPL >= 0)
  1783.         {
  1784.           COMPILE1 (two_literal);
  1785.           COMMA (d.hi);
  1786.         }
  1787.           else
  1788.         COMPILE1 (literal);
  1789.           COMMA (d.lo);
  1790.           continue;
  1791.         }
  1792.       if (BASE == 10 && FLOAT_INPUT && to_float (p, len, &f))
  1793.         {
  1794. #if DFLOAT_ALIGN > CELL_ALIGN
  1795.           if (DFALIGNED (DP))
  1796.         COMPILE2 (f_literal);
  1797. #endif
  1798.           COMPILE1 (f_literal);
  1799.           FCOMMA (f);
  1800.           continue;
  1801.         }
  1802.     }
  1803.       else
  1804.     {
  1805.       s = find (p, len);
  1806.       if (s != NULL)
  1807.         {
  1808.           call_forth (name_from (s));
  1809.           question_stack_ ();
  1810.           continue;
  1811.         }
  1812.       if (number_question (p, len, &d))
  1813.         {
  1814.           *--sp = d.lo;
  1815.           if (DPL >= 0)
  1816.         *--sp = d.hi;
  1817.           continue;
  1818.         }
  1819.       if (BASE == 10 && FLOAT_INPUT && to_float (p, len, &f))
  1820.         {
  1821.           *--fp = f;
  1822.           continue;
  1823.         }
  1824.     }
  1825.       tHrow (THROW_UNDEFINED);
  1826.     }
  1827. }
  1828.  
  1829. void
  1830. evaluate (char *p, int n)
  1831. {
  1832.   rp = (Xt **) save_input (rp);
  1833.   SOURCE_ID = -1;
  1834.   BLK = 0;
  1835.   TIB = p;
  1836.   NUMBER_TIB = n;
  1837.   TO_IN = 0;
  1838.   interpret_ ();
  1839.   rp = (Xt **) restore_input (rp);
  1840. }
  1841.  
  1842. void
  1843. load (File *fid, uCell blk)
  1844. {
  1845.   if (blk == 0)
  1846.     tHrow (THROW_INVALID_BLOCK);
  1847.   rp = (Xt **) save_input (rp);
  1848.   BLOCK_FILE = fid;
  1849.   SOURCE_ID = 0;
  1850.   BLK = blk;
  1851.   TO_IN = 0;
  1852.   interpret_ ();
  1853.   rp = (Xt **) restore_input (rp);
  1854. }
  1855.  
  1856. void
  1857. load_file (char *fn, int cnt, int blk)
  1858. {
  1859.   File *fid = open_block_file (fn, cnt);
  1860.  
  1861.   if (fid == NULL)
  1862.     file_error (fn, cnt);
  1863.   load (fid, blk);
  1864. }
  1865.  
  1866. void
  1867. thru (File *fid, int lo, int hi)
  1868. {
  1869.   int i;
  1870.  
  1871.   for (i = lo; i <= hi; i++)
  1872.     load (fid, i);
  1873. }
  1874.  
  1875. void
  1876. include_file (File *fid)
  1877. {
  1878.   if (fid == NULL || fid->f == NULL)
  1879.     tHrow (THROW_FILE_NEX);
  1880.   rp = (Xt **) save_input (rp);
  1881.   SOURCE_ID = (Cell) fid;
  1882.   BLK = 0;
  1883.   TO_IN = 0;
  1884.   interpret_ ();
  1885.   rp = (Xt **) restore_input (rp);
  1886. }
  1887.  
  1888. void
  1889. included (const char *name, int len)
  1890. {
  1891.   char nm[0x80], fn[0x100];
  1892.   File *f;
  1893.  
  1894.   store_filename (name, len, nm, sizeof nm);
  1895.   expand_filename (nm, option.incpaths, option.incext, fn);
  1896.   f = open_file (fn, strlen (fn), FMODE_RO);
  1897.   if (!f)
  1898.     tHrow (THROW_FILE_NEX);
  1899.   include_file (f);
  1900.   close_file (f);
  1901. }
  1902.  
  1903. static void
  1904. unnest_input (Iframe *p)
  1905. {
  1906.   while (sys.saved_input && sys.saved_input != p)
  1907.     {
  1908.       switch (SOURCE_ID)
  1909.     {
  1910.     case -1:
  1911.     case 0:
  1912.       break;
  1913.     default:
  1914.       close_file (SOURCE_FILE);
  1915.     }
  1916.       rp = (Xt **) restore_input (sys.saved_input);
  1917.     }
  1918. }
  1919.  
  1920. /************************************************************************/
  1921. /* QUIT, ABORT and exception handling                                   */
  1922. /************************************************************************/
  1923.  
  1924. jmp_buf quit_dest;        /* QUIT and ABORT do a THROW which longjmp() */
  1925. jmp_buf abort_dest;        /* here thus C-stack gets cleaned up too */
  1926.  
  1927. static void
  1928. quit_initializations (void)    /* Things quit has to initialize: */
  1929. {
  1930.   rp = sys.r0;            /* return stack */
  1931.   lp = NULL;            /* including all local variables */
  1932.   STATE = FALSE;        /* interpreting now */
  1933.   sys.cAtch = NULL;        /* and no exceptions caught */
  1934.   debug_off ();            /* turn off debugger */
  1935. }
  1936.  
  1937. static void            /* normal interactive QUIT */
  1938. do_quit (void)            /* doing the QUERY-INTERPRET loop */
  1939. {
  1940.   setjmp (quit_dest);
  1941.   quit_initializations ();
  1942.   unnest_input (NULL);
  1943.   for (;;)
  1944.     {
  1945.       cr_ ();
  1946.       query_ ();
  1947.       interpret_ ();
  1948.       question_stack_ ();
  1949.       if (!STATE)
  1950.     outs ("ok");
  1951.     }
  1952. }
  1953.  
  1954. static void
  1955. abort_initializations (void)    /* Things ABORT has to initialize: */
  1956. {
  1957.   sp = sys.s0;            /* stacks */
  1958.   fp = sys.f0;
  1959.   reset_order_ ();        /* reset search order */
  1960.   definitions_ ();        /* and vocabulary in extension */
  1961.   decimal_ ();            /* number i/o base */
  1962.   standard_io_ ();        /* disable i/o redirection */
  1963. }
  1964.  
  1965. void
  1966. do_abort (void)
  1967. {
  1968.   setjmp (abort_dest);
  1969.   abort_initializations ();
  1970.   do_quit ();
  1971. }
  1972.  
  1973. static void
  1974. show_error (char *fmt,...)
  1975. {
  1976.   char buf[128];
  1977.   va_list p;
  1978.   int n;
  1979.  
  1980.   sys.input_err = sys.input;    /* save input specification of error */
  1981.   va_start (p, fmt);
  1982.   vsprintf (buf, fmt, p);
  1983.   va_end (p);
  1984.   outf ("\nError: \"%.*s\" %s\n", *DP, DP + 1, buf);
  1985.   switch (SOURCE_ID)
  1986.     {
  1987.     case 0:
  1988.       if (BLK && BLOCK_FILE && !ferror (BLOCK_FILE->f))
  1989.     {
  1990.       outf ("Block %lu line %d:\n",
  1991.         (unsigned long) BLK, (int) TO_IN / 64);
  1992.       dot_line (BLOCK_FILE, BLK, TO_IN / 64);
  1993.       n = TO_IN % 64;
  1994.       break;
  1995.     }
  1996.     case -1:
  1997.       type (TIB, NUMBER_TIB);
  1998.       n = TO_IN;
  1999.       break;
  2000.     default:
  2001.       outf ("File %s line %lu:\n",
  2002.         SOURCE_FILE->name, (unsigned long) SOURCE_FILE->n);
  2003.       type (TIB, NUMBER_TIB);
  2004.       n = TO_IN;
  2005.     }
  2006.   outf ("\n%*s", n, "^");
  2007.   longjmp (abort_dest, 2);
  2008. }
  2009.  
  2010. static void
  2011. throw_msg (int id, char *msg)
  2012. {
  2013.   /* *INDENT-OFF* */
  2014.   static char *throw_explanation[] =
  2015.   {
  2016.     /*  -1 */ NULL, /* ABORT */
  2017.     /*  -2 */ NULL, /* ABORT" */
  2018.     /*  -3 */ "stack overflow",
  2019.     /*  -4 */ "stack underflow",
  2020.     /*  -5 */ "return stack overflow",
  2021.     /*  -6 */ "return stack underflow",
  2022.     /*  -7 */ "do-loops nested too deeply during execution",
  2023.     /*  -8 */ "dictionary overflow",
  2024.     /*  -9 */ "invalid memory address",
  2025.     /* -10 */ "division by zero",
  2026.     /* -11 */ "result out of range",
  2027.     /* -12 */ "argument type mismatch",
  2028.     /* -13 */ "undefined word",
  2029.     /* -14 */ "interpreting a compile-only word",
  2030.     /* -15 */ "invalid FORGET",
  2031.     /* -16 */ "attempt to use a zero-length string as a name",
  2032.     /* -17 */ "pictured numeric output string overflow",
  2033.     /* -18 */ "parsed string overflow",
  2034.     /* -19 */ "definition name too long",
  2035.     /* -20 */ "write to a read-only location",
  2036.     /* -21 */ "unsupported operation",
  2037.     /* -22 */ "control structure mismatch",
  2038.     /* -23 */ "address alignment exception",
  2039.     /* -24 */ "invalid numeric argument",
  2040.     /* -25 */ "return stack imbalance",
  2041.     /* -26 */ "loop parameters unavailable",
  2042.     /* -27 */ "invalid recursion",
  2043.     /* -28 */ "user interrupt",
  2044.     /* -29 */ "compiler nesting",
  2045.     /* -30 */ "obsolescent feature",
  2046.     /* -31 */ ">BODY used on non-CREATEDd definition",
  2047.     /* -32 */ "invalid name argument",
  2048.     /* -33 */ "block read exception",
  2049.     /* -34 */ "block write exception",
  2050.     /* -35 */ "invalid block number",
  2051.     /* -36 */ "invalid file position",
  2052.     /* -37 */ "file I/O exception",
  2053.     /* -38 */ "non-existent file",
  2054.     /* -39 */ "unexpected end of file",
  2055.     /* -40 */ "invalid BASE for floating-point conversion",
  2056.     /* -41 */ "loss of precision",
  2057.     /* -42 */ "floating-point divide by zero",
  2058.     /* -43 */ "floating-point result out of range",
  2059.     /* -44 */ "floating-point stack overflow",
  2060.     /* -45 */ "floating-point stack underflow",
  2061.     /* -46 */ "floating-point invalid argument",
  2062.     /* -47 */ "compilation word list deleted",
  2063.     /* -48 */ "invalid POSTPONE",
  2064.     /* -49 */ "search-order overflow",
  2065.     /* -50 */ "search-order underflow",
  2066.     /* -51 */ "compilation word list changed",
  2067.     /* -52 */ "control flow stack overflow",
  2068.     /* -53 */ "exception stack overflow",
  2069.     /* -54 */ "floating-point underflow",
  2070.     /* -55 */ "floating-point unidentified fault",
  2071.     /* -56 */ NULL, /* QUIT */
  2072.     /* -57 */ "error in sending or receiving a character",
  2073.     /* -58 */ "[IF], [ELSE] or [THEN] error"
  2074.   }, *pfe_throw_explanation[] =
  2075.   {
  2076.     /* -2048 */ "no or not matching binary image",
  2077.     /* -2049 */ "binary image too big",
  2078.     /* -2050 */ "out of memory",
  2079.     /* -2051 */ "index out of range",
  2080.   };
  2081.   /* *INDENT-ON* */
  2082.  
  2083.   if (-1 - DIM (throw_explanation) < id && id <= -1)
  2084.     strcpy (msg, throw_explanation[-1 - id]);
  2085.   else if (-2048 < id && id <= -256)
  2086.     {
  2087.       char fn[PATH_LENGTH];
  2088.  
  2089.       strcpy (fn, msg);
  2090.       sprintf (msg, ": File %s: %s", fn, strerror (-256 - id));
  2091.     }
  2092.   else if (-2048 - DIM (pfe_throw_explanation) < id && id <= -2048)
  2093.     strcpy (msg, pfe_throw_explanation[-2048 - id]);
  2094.   else
  2095.     sprintf (msg, "%d THROW unassigned", id);
  2096. }
  2097.  
  2098. int
  2099. cAtch (Xt xt)
  2100. {
  2101.   Except *x = DEC (rp, Except);
  2102.   int id;
  2103.  
  2104.   x->magic = EXCEPTION_MAGIC;
  2105.   x->ip = ip;
  2106.   x->sp = sp;
  2107.   x->lp = lp;
  2108.   x->fp = fp;
  2109.   x->iframe = sys.saved_input;
  2110.   x->prev = sys.cAtch;
  2111.   sys.cAtch = x;
  2112.   id = setjmp (x->jmp);
  2113.   if (!id)
  2114.     call_forth (xt);
  2115.   sys.cAtch = x->prev;
  2116.   rp = (Xt **) &x[1];
  2117.   return id;
  2118. }
  2119.  
  2120. void
  2121. tHrow (int id,...)
  2122. {
  2123.   Except *x = sys.cAtch;
  2124.   va_list p;
  2125.   char msg[80];
  2126.  
  2127.   if (x && x->magic == EXCEPTION_MAGIC)
  2128.     {
  2129.       ip = x->ip;
  2130.       sp = x->sp;
  2131.       lp = x->lp;
  2132.       fp = x->fp;
  2133.       unnest_input (x->iframe);
  2134.       longjmp (x->jmp, id);
  2135.     }
  2136.   switch (id)
  2137.     {
  2138.     case THROW_ABORT_QUOTE:
  2139.       {
  2140.     char *addr;
  2141.     int len;
  2142.  
  2143.     va_start (p, id);
  2144.     addr = va_arg (p, char *);
  2145.     len = va_arg (p, int);
  2146.     va_end (p);
  2147.     show_error ("%.*s", len, addr);
  2148.       }
  2149.     case THROW_ABORT:
  2150.       longjmp (abort_dest, 1);
  2151.     case THROW_QUIT:
  2152.       longjmp (quit_dest, 1);
  2153.     default:
  2154.       if (-2048 < id && id <= -256)
  2155.     {
  2156.       va_start (p, id);
  2157.       strcpy (msg, va_arg (p, char *));
  2158.       va_end (p);
  2159.     }
  2160.       throw_msg (id, msg);
  2161.       show_error (msg);
  2162.     }
  2163. }
  2164.  
  2165. void
  2166. abortq (const char *fmt,...)
  2167. {
  2168.   char buf[128];
  2169.   int n;
  2170.   va_list p;
  2171.  
  2172.   va_start (p, fmt);
  2173.   n = vsprintf (buf, fmt, p);
  2174.   va_end (p);
  2175.   tHrow (THROW_ABORT_QUOTE, buf, n);
  2176. }
  2177.  
  2178. void
  2179. question_pairs (Cell n)
  2180. {
  2181.   if (n != *sp++)
  2182.     tHrow (THROW_CONTROL_MISMATCH);
  2183. }
  2184.  
  2185. void
  2186. question_file_open (File *fid)
  2187. {
  2188.   if (fid == NULL || fid->f == NULL)
  2189.     tHrow (THROW_FILE_NEX);
  2190. }
  2191.  
  2192. /************************************************************************/
  2193. /* Initialize dictionary, and system variables, include files           */
  2194. /************************************************************************/
  2195.  
  2196. static void
  2197. init_dictionary (Dict *dict, uCell size)
  2198. {
  2199.   Dict *saved_sysdict;
  2200.  
  2201.   /* Temporarily activate this dictionary: */
  2202.   saved_sysdict = sys.dict;
  2203.   sys.dict = dict;
  2204.  
  2205.   if (option.load_dict)
  2206.     {
  2207.       if (!reload_dictionary (option.load_dict, sys.dict))
  2208.     fatal ("Couldn't reload dictionary file %s", option.load_dict);
  2209.     }
  2210.   else
  2211.     {
  2212.       /* Wipe the dictionary: */
  2213.       memset (dict, 0, size);
  2214.       preload_dictionary ();
  2215.  
  2216.       /* Define the following default search order:
  2217.        * ONLY EXTENSIONS ALSO FORTH ALSO */
  2218.       only_runtime ();
  2219.       CONTEXT[0] = FORTH;
  2220.       CONTEXT[1] = extensions_list.wid;
  2221.       also_ ();
  2222.       default_order_ ();
  2223.     }
  2224.   /* Action of ABORT and QUIT, but don't enter the interactive QUIT */
  2225.   abort_initializations ();
  2226.   quit_initializations ();
  2227.  
  2228.   /* Include .pferc if it exists: */
  2229.   if (option.pferc_file && access (option.pferc_file, R_OK) == 0)
  2230.     included (option.pferc_file, strlen (option.pferc_file));
  2231.  
  2232.   /* Include file from command line: */
  2233.   if (option.include_file)
  2234.     included (option.include_file, strlen (option.include_file));
  2235.  
  2236.   /* Switch back to the former dictionary: */
  2237.   sys.dict = saved_sysdict;
  2238. }
  2239.  
  2240. void                /* set up all system variables */
  2241. initialize_system (void)    /* and initialize the dictionary */
  2242. {
  2243.   memset (&sys, 0, sizeof sys);
  2244.   sys.dict = (Dict *) membot.dict;
  2245.   sys.s0 = memtop.stack;
  2246.   sys.f0 = memtop.fstack;
  2247.   sys.r0 = memtop.rstack;
  2248.   TIB = membot.tib;
  2249.   BASE = 10;
  2250.   DPL = -1;
  2251.   PRECISION = 6;
  2252.   LOWER_CASE = option.lower_case_on;
  2253.   LOWER_CASE_FN = option.lower_case_fn;
  2254.   FLOAT_INPUT = option.float_input;
  2255.   sys.local = (char (*)[32]) membot.stack;
  2256.  
  2257.   memset (memtop.files - 3, 0, sizeof (File) * 3);
  2258.  
  2259.   sys.stdIn = memtop.files - 3;
  2260.   sys.stdIn->f = stdin;
  2261.   strcpy (sys.stdIn->name, "<STDIN>");
  2262.   strcpy (sys.stdIn->mdstr, "r");
  2263.   sys.stdIn->mode = FMODE_RO;
  2264.  
  2265.   sys.stdOut = memtop.files - 2;
  2266.   sys.stdOut->f = stdout;
  2267.   strcpy (sys.stdOut->name, "<STDOUT>");
  2268.   strcpy (sys.stdOut->mdstr, "a");
  2269.   sys.stdOut->mode = FMODE_WO;
  2270.  
  2271.   sys.stdErr = memtop.files - 1;
  2272.   sys.stdErr->f = stderr;
  2273.   strcpy (sys.stdErr->name, "<STDERR>");
  2274.   strcpy (sys.stdErr->mdstr, "a");
  2275.   sys.stdErr->mode = FMODE_WO;
  2276.  
  2277.   if (option.block_file)
  2278.     {
  2279.       if (!use_block_file (option.block_file, strlen (option.block_file))
  2280.       && strcmp (option.block_file, DEFAULT_BLKFILE) != 0)
  2281.     fatal ("Can't find block file %s", option.block_file);
  2282.     }
  2283.  
  2284.   read_help_index (HELPDIR, "index");
  2285.  
  2286.   REDEFINED_MSG = FALSE;
  2287.   init_dictionary (sys.dict, memsiz.dict);
  2288.   REDEFINED_MSG = TRUE;
  2289.  
  2290.   if (option.save_dict)
  2291.     {
  2292.       extern void *getmem (size_t n);
  2293.       Dict *dict2 = (Dict *) getmem ((size_t) memsiz.dict);
  2294.       long size;
  2295.  
  2296.       init_dictionary (dict2, memsiz.dict);
  2297.       size = save_dictionary (sys.dict, dict2, option.save_dict);
  2298.       if (size)
  2299.     outf ("\nSaved dictionary to %s, wrote %ld bytes.\n",
  2300.           option.save_dict, size);
  2301.       else
  2302.     outs ("\nCouldn't create relocatable dictionary image.\n");
  2303.       free (dict2);
  2304.     }
  2305. }
  2306.