home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1992 March / Source_Code_CD-ROM_Walnut_Creek_March_1992.iso / usenet / altsrcs / 1 / 1652 / p2clib.c < prev    next >
Encoding:
C/C++ Source or Header  |  1990-12-28  |  16.3 KB  |  943 lines
  1.  
  2. /* Run-time library for use with "p2c", the Pascal to C translator */
  3.  
  4. /* "p2c"  Copyright (C) 1989 Dave Gillespie.
  5.  * This file may be copied, modified, etc. in any way.  It is not restricted
  6.  * by the licence agreement accompanying p2c itself.
  7.  */
  8.  
  9.  
  10.  
  11. #include "p2c.h"
  12.  
  13.  
  14. /* #define LACK_LABS     */   /* Define these if necessary */
  15. /* #define LACK_MEMMOVE  */
  16.  
  17.  
  18. #ifndef NO_TIME
  19. # include <time.h>
  20. #endif
  21.  
  22.  
  23. #define Isspace(c)  isspace(c)      /* or "((c) == ' ')" if preferred */
  24.  
  25.  
  26.  
  27.  
  28. int P_argc;
  29. char **P_argv;
  30.  
  31. short P_escapecode;
  32. int P_ioresult;
  33.  
  34. long EXCP_LINE;    /* Used by Pascal workstation system */
  35.  
  36. Anyptr __MallocTemp__;
  37.  
  38. __p2c_jmp_buf *__top_jb;
  39.  
  40.  
  41.  
  42.  
  43. void PASCAL_MAIN(argc, argv)
  44. int argc;
  45. char **argv;
  46. {
  47.     P_argc = argc;
  48.     P_argv = argv;
  49.     __top_jb = NULL;
  50.  
  51. #ifdef LOCAL_INIT
  52.     LOCAL_INIT();
  53. #endif
  54. }
  55.  
  56.  
  57.  
  58.  
  59.  
  60. /* In case your system lacks these... */
  61.  
  62. #ifdef LACK_LABS
  63. long labs(x)
  64. long x;
  65. {
  66.     return((x > 0) ? x : -x);
  67. }
  68. #endif
  69.  
  70.  
  71. #ifdef LACK_MEMMOVE
  72. Anyptr memmove(d, s, n)
  73. Anyptr d, s;
  74. register long n;
  75. {
  76.     if (d < s || d - s >= n) {
  77.     memcpy(d, s, n);
  78.     return d;
  79.     } else if (n > 0) {
  80.     register char *dd = d + n, *ss = s + n;
  81.     while (--n >= 0)
  82.         *--dd = *--ss;
  83.     }
  84.     return d;
  85. }
  86. #endif
  87.  
  88.  
  89. int my_toupper(c)
  90. int c;
  91. {
  92.     if (islower(c))
  93.     return _toupper(c);
  94.     else
  95.     return c;
  96. }
  97.  
  98.  
  99. int my_tolower(c)
  100. int c;
  101. {
  102.     if (isupper(c))
  103.     return _tolower(c);
  104.     else
  105.     return c;
  106. }
  107.  
  108.  
  109.  
  110.  
  111. long ipow(a, b)
  112. long a, b;
  113. {
  114.     long v;
  115.  
  116.     if (a == 0 || a == 1)
  117.     return a;
  118.     if (a == -1)
  119.     return (b & 1) ? -1 : 1;
  120.     if (b < 0)
  121.     return 0;
  122.     if (a == 2)
  123.     return 1 << b;
  124.     v = (b & 1) ? a : 1;
  125.     while ((b >>= 1) > 0) {
  126.     a *= a;
  127.     if (b & 1)
  128.         v *= a;
  129.     }
  130.     return v;
  131. }
  132.  
  133.  
  134.  
  135.  
  136. /* Common string functions: */
  137.  
  138. /* Store in "ret" the substring of length "len" starting from "pos" (1-based).
  139.    Store a shorter or null string if out-of-range.  Return "ret". */
  140.  
  141. char *strsub(ret, s, pos, len)
  142. register char *ret, *s;
  143. register int pos, len;
  144. {
  145.     register char *s2;
  146.  
  147.     if (--pos < 0 || len <= 0) {
  148.         *ret = 0;
  149.         return ret;
  150.     }
  151.     while (pos > 0) {
  152.         if (!*s++) {
  153.             *ret = 0;
  154.             return ret;
  155.         }
  156.         pos--;
  157.     }
  158.     s2 = ret;
  159.     while (--len >= 0) {
  160.         if (!(*s2++ = *s++))
  161.             return ret;
  162.     }
  163.     *s2 = 0;
  164.     return ret;
  165. }
  166.  
  167.  
  168. /* Return the index of the first occurrence of "pat" as a substring of "s",
  169.    starting at index "pos" (1-based).  Result is 1-based, 0 if not found. */
  170.  
  171. int strpos2(s, pat, pos)
  172. char *s;
  173. register char *pat;
  174. register int pos;
  175. {
  176.     register char *cp, ch;
  177.     register int slen;
  178.  
  179.     if (--pos < 0)
  180.         return 0;
  181.     slen = strlen(s) - pos;
  182.     cp = s + pos;
  183.     if (!(ch = *pat++))
  184.         return 0;
  185.     pos = strlen(pat);
  186.     slen -= pos;
  187.     while (--slen >= 0) {
  188.         if (*cp++ == ch && !strncmp(cp, pat, pos))
  189.             return cp - s;
  190.     }
  191.     return 0;
  192. }
  193.  
  194.  
  195. /* Case-insensitive version of strcmp. */
  196.  
  197. int strcicmp(s1, s2)
  198. register char *s1, *s2;
  199. {
  200.     register unsigned char c1, c2;
  201.  
  202.     while (*s1) {
  203.     if (*s1++ != *s2++) {
  204.         if (!s2[-1])
  205.         return 1;
  206.         c1 = toupper(s1[-1]);
  207.         c2 = toupper(s2[-1]);
  208.         if (c1 != c2)
  209.         return c1 - c2;
  210.     }
  211.     }
  212.     if (*s2)
  213.     return -1;
  214.     return 0;
  215. }
  216.  
  217.  
  218.  
  219.  
  220. /* HP and Turbo Pascal string functions: */
  221.  
  222. /* Trim blanks at left end of string. */
  223.  
  224. char *strltrim(s)
  225. register char *s;
  226. {
  227.     while (Isspace(*s++)) ;
  228.     return s - 1;
  229. }
  230.  
  231.  
  232. /* Trim blanks at right end of string. */
  233.  
  234. char *strrtrim(s)
  235. register char *s;
  236. {
  237.     register char *s2 = s;
  238.  
  239.     while (*++s2) ;
  240.     while (s2 > s && Isspace(*--s2))
  241.         *s2 = 0;
  242.     return s;
  243. }
  244.  
  245.  
  246. /* Store in "ret" "num" copies of string "s".  Return "ret". */
  247.  
  248. char *strrpt(ret, s, num)
  249. char *ret;
  250. register char *s;
  251. register int num;
  252. {
  253.     register char *s2 = ret;
  254.     register char *s1;
  255.  
  256.     while (--num >= 0) {
  257.         s1 = s;
  258.         while ((*s2++ = *s1++)) ;
  259.         s2--;
  260.     }
  261.     return ret;
  262. }
  263.  
  264.  
  265. /* Store in "ret" string "s" with enough pad chars added to reach "size". */
  266.  
  267. char *strpad(ret, s, padchar, num)
  268. char *ret;
  269. register char *s;
  270. register int padchar, num;
  271. {
  272.     register char *d = ret;
  273.  
  274.     if (s == d) {
  275.     while (*d++) ;
  276.     } else {
  277.     while ((*d++ = *s++)) ;
  278.     }
  279.     num -= (--d - ret);
  280.     while (--num >= 0)
  281.     *d++ = padchar;
  282.     *d = 0;
  283.     return ret;
  284. }
  285.  
  286.  
  287. /* Copy the substring of length "len" from index "spos" of "s" (1-based)
  288.    to index "dpos" of "d", lengthening "d" if necessary.  Length and
  289.    indices must be in-range. */
  290.  
  291. void strmove(len, s, spos, d, dpos)
  292. register char *s, *d;
  293. register int len, spos, dpos;
  294. {
  295.     s += spos - 1;
  296.     d += dpos - 1;
  297.     while (*d && --len >= 0)
  298.     *d++ = *s++;
  299.     if (len > 0) {
  300.     while (--len >= 0)
  301.         *d++ = *s++;
  302.     *d = 0;
  303.     }
  304. }
  305.  
  306.  
  307. /* Delete the substring of length "len" at index "pos" from "s".
  308.    Delete less if out-of-range. */
  309.  
  310. void strdelete(s, pos, len)
  311. register char *s;
  312. register int pos, len;
  313. {
  314.     register int slen;
  315.  
  316.     if (--pos < 0)
  317.         return;
  318.     slen = strlen(s) - pos;
  319.     if (slen <= 0)
  320.         return;
  321.     s += pos;
  322.     if (slen <= len) {
  323.         *s = 0;
  324.         return;
  325.     }
  326.     while ((*s = s[len])) s++;
  327. }
  328.  
  329.  
  330. /* Insert string "src" at index "pos" of "dst". */
  331.  
  332. void strinsert(src, dst, pos)
  333. register char *src, *dst;
  334. register int pos;
  335. {
  336.     register int slen, dlen;
  337.  
  338.     if (--pos < 0)
  339.         return;
  340.     dlen = strlen(dst);
  341.     dst += dlen;
  342.     dlen -= pos;
  343.     if (dlen <= 0) {
  344.         strcpy(dst, src);
  345.         return;
  346.     }
  347.     slen = strlen(src);
  348.     do {
  349.         dst[slen] = *dst;
  350.         --dst;
  351.     } while (--dlen >= 0);
  352.     dst++;
  353.     while (--slen >= 0)
  354.         *dst++ = *src++;
  355. }
  356.  
  357.  
  358.  
  359.  
  360. /* File functions */
  361.  
  362. /* Peek at next character of input stream; return EOF at end-of-file. */
  363.  
  364. int P_peek(f)
  365. FILE *f;
  366. {
  367.     int ch;
  368.  
  369.     ch = getc(f);
  370.     if (ch == EOF)
  371.     return EOF;
  372.     ungetc(ch, f);
  373.     return (ch == '\n') ? ' ' : ch;
  374. }
  375.  
  376.  
  377. /* Check if at end of file, using Pascal "eof" semantics.  End-of-file for
  378.    stdin is broken; remove the special case for it to be broken in a
  379.    different way. */
  380.  
  381. int P_eof(f)
  382. FILE *f;
  383. {
  384.     register int ch;
  385.  
  386.     if (feof(f))
  387.     return 1;
  388.     if (f == stdin)
  389.     return 0;    /* not safe to look-ahead on the keyboard! */
  390.     ch = getc(f);
  391.     if (ch == EOF)
  392.     return 1;
  393.     ungetc(ch, f);
  394.     return 0;
  395. }
  396.  
  397.  
  398. /* Check if at end of line (or end of entire file). */
  399.  
  400. int P_eoln(f)
  401. FILE *f;
  402. {
  403.     register int ch;
  404.  
  405.     ch = getc(f);
  406.     if (ch == EOF)
  407.         return 1;
  408.     ungetc(ch, f);
  409.     return (ch == '\n');
  410. }
  411.  
  412.  
  413. /* Read a packed array of characters from a file. */
  414.  
  415. Void P_readpaoc(f, s, len)
  416. FILE *f;
  417. char *s;
  418. int len;
  419. {
  420.     int ch;
  421.  
  422.     for (;;) {
  423.     if (len <= 0)
  424.         return;
  425.     ch = getc(f);
  426.     if (ch == EOF || ch == '\n')
  427.         break;
  428.     *s++ = ch;
  429.     --len;
  430.     }
  431.     while (--len >= 0)
  432.     *s++ = ' ';
  433.     if (ch != EOF)
  434.     ungetc(ch, f);
  435. }
  436.  
  437. Void P_readlnpaoc(f, s, len)
  438. FILE *f;
  439. char *s;
  440. int len;
  441. {
  442.     int ch;
  443.  
  444.     for (;;) {
  445.     ch = getc(f);
  446.     if (ch == EOF || ch == '\n')
  447.         break;
  448.     if (len > 0) {
  449.         *s++ = ch;
  450.         --len;
  451.     }
  452.     }
  453.     while (--len >= 0)
  454.     *s++ = ' ';
  455. }
  456.  
  457.  
  458. /* Compute maximum legal "seek" index in file (0-based). */
  459.  
  460. long P_maxpos(f)
  461. FILE *f;
  462. {
  463.     long savepos = ftell(f);
  464.     long val;
  465.  
  466.     if (fseek(f, 0L, SEEK_END))
  467.         return -1;
  468.     val = ftell(f);
  469.     if (fseek(f, savepos, SEEK_SET))
  470.         return -1;
  471.     return val;
  472. }
  473.  
  474.  
  475. /* Use packed array of char for a file name. */
  476.  
  477. char *P_trimname(fn, len)
  478. register char *fn;
  479. register int len;
  480. {
  481.     static char fnbuf[256];
  482.     register char *cp = fnbuf;
  483.     
  484.     while (--len >= 0 && *fn && !isspace(*fn))
  485.     *cp++ = *fn++;
  486.     return fnbuf;
  487. }
  488.  
  489.  
  490.  
  491.  
  492. /* Pascal's "memavail" doesn't make much sense in Unix with virtual memory.
  493.    We fix memory size as 10Meg as a reasonable compromise. */
  494.  
  495. long memavail()
  496. {
  497.     return 10000000;            /* worry about this later! */
  498. }
  499.  
  500. long maxavail()
  501. {
  502.     return memavail();
  503. }
  504.  
  505.  
  506.  
  507.  
  508. /* Sets are stored as an array of longs.  S[0] is the size of the set;
  509.    S[N] is the N'th 32-bit chunk of the set.  S[0] equals the maximum
  510.    I such that S[I] is nonzero.  S[0] is zero for an empty set.  Within
  511.    each long, bits are packed from lsb to msb.  The first bit of the
  512.    set is the element with ordinal value 0.  (Thus, for a "set of 5..99",
  513.    the lowest five bits of the first long are unused and always zero.) */
  514.  
  515. /* (Sets with 32 or fewer elements are normally stored as plain longs.) */
  516.  
  517. long *P_setunion(d, s1, s2)         /* d := s1 + s2 */
  518. register long *d, *s1, *s2;
  519. {
  520.     long *dbase = d++;
  521.     register int sz1 = *s1++, sz2 = *s2++;
  522.     while (sz1 > 0 && sz2 > 0) {
  523.         *d++ = *s1++ | *s2++;
  524.     sz1--, sz2--;
  525.     }
  526.     while (--sz1 >= 0)
  527.     *d++ = *s1++;
  528.     while (--sz2 >= 0)
  529.     *d++ = *s2++;
  530.     *dbase = d - dbase - 1;
  531.     return dbase;
  532. }
  533.  
  534.  
  535. long *P_setint(d, s1, s2)           /* d := s1 * s2 */
  536. register long *d, *s1, *s2;
  537. {
  538.     long *dbase = d++;
  539.     register int sz1 = *s1++, sz2 = *s2++;
  540.     while (--sz1 >= 0 && --sz2 >= 0)
  541.         *d++ = *s1++ & *s2++;
  542.     while (--d > dbase && !*d) ;
  543.     *dbase = d - dbase;
  544.     return dbase;
  545. }
  546.  
  547.  
  548. long *P_setdiff(d, s1, s2)          /* d := s1 - s2 */
  549. register long *d, *s1, *s2;
  550. {
  551.     long *dbase = d++;
  552.     register int sz1 = *s1++, sz2 = *s2++;
  553.     while (--sz1 >= 0 && --sz2 >= 0)
  554.         *d++ = *s1++ & ~*s2++;
  555.     if (sz1 >= 0) {
  556.         while (sz1-- >= 0)
  557.             *d++ = *s1++;
  558.     }
  559.     while (--d > dbase && !*d) ;
  560.     *dbase = d - dbase;
  561.     return dbase;
  562. }
  563.  
  564.  
  565. long *P_setxor(d, s1, s2)         /* d := s1 / s2 */
  566. register long *d, *s1, *s2;
  567. {
  568.     long *dbase = d++;
  569.     register int sz1 = *s1++, sz2 = *s2++;
  570.     while (sz1 > 0 && sz2 > 0) {
  571.         *d++ = *s1++ ^ *s2++;
  572.     sz1--, sz2--;
  573.     }
  574.     while (--sz1 >= 0)
  575.     *d++ = *s1++;
  576.     while (--sz2 >= 0)
  577.     *d++ = *s2++;
  578.     *dbase = d - dbase - 1;
  579.     return dbase;
  580. }
  581.  
  582.  
  583. int P_inset(val, s)                 /* val IN s */
  584. register unsigned val;
  585. register long *s;
  586. {
  587.     register int bit;
  588.     bit = val % SETBITS;
  589.     val /= SETBITS;
  590.     if (val < *s++ && ((1<<bit) & s[val]))
  591.     return 1;
  592.     return 0;
  593. }
  594.  
  595.  
  596. long *P_addset(s, val)              /* s := s + [val] */
  597. register long *s;
  598. register unsigned val;
  599. {
  600.     register long *sbase = s;
  601.     register int bit, size;
  602.     bit = val % SETBITS;
  603.     val /= SETBITS;
  604.     size = *s;
  605.     if (++val > size) {
  606.         s += size;
  607.         while (val > size)
  608.             *++s = 0, size++;
  609.         *sbase = size;
  610.     } else
  611.         s += val;
  612.     *s |= 1<<bit;
  613.     return sbase;
  614. }
  615.  
  616.  
  617. long *P_addsetr(s, v1, v2)              /* s := s + [v1..v2] */
  618. register long *s;
  619. register unsigned v1, v2;
  620. {
  621.     register long *sbase = s;
  622.     register int b1, b2, size;
  623.     if (v1 > v2)
  624.     return sbase;
  625.     b1 = v1 % SETBITS;
  626.     v1 /= SETBITS;
  627.     b2 = v2 % SETBITS;
  628.     v2 /= SETBITS;
  629.     size = *s;
  630.     v1++;
  631.     if (++v2 > size) {
  632.         while (v2 > size)
  633.             s[++size] = 0;
  634.         s[v2] = 0;
  635.         *s = v2;
  636.     }
  637.     s += v1;
  638.     if (v1 == v2) {
  639.         *s |= (~((-2)<<(b2-b1))) << b1;
  640.     } else {
  641.         *s++ |= (-1) << b1;
  642.         while (++v1 < v2)
  643.             *s++ = -1;
  644.         *s |= ~((-2) << b2);
  645.     }
  646.     return sbase;
  647. }
  648.  
  649.  
  650. long *P_remset(s, val)              /* s := s - [val] */
  651. register long *s;
  652. register unsigned val;
  653. {
  654.     register int bit;
  655.     bit = val % SETBITS;
  656.     val /= SETBITS;
  657.     if (++val <= *s)
  658.     s[val] &= ~(1<<bit);
  659.     return s;
  660. }
  661.  
  662.  
  663. int P_setequal(s1, s2)              /* s1 = s2 */
  664. register long *s1, *s2;
  665. {
  666.     register int size = *s1++;
  667.     if (*s2++ != size)
  668.         return 0;
  669.     while (--size >= 0) {
  670.         if (*s1++ != *s2++)
  671.             return 0;
  672.     }
  673.     return 1;
  674. }
  675.  
  676.  
  677. int P_subset(s1, s2)                /* s1 <= s2 */
  678. register long *s1, *s2;
  679. {
  680.     register int sz1 = *s1++, sz2 = *s2++;
  681.     if (sz1 > sz2)
  682.         return 0;
  683.     while (--sz1 >= 0) {
  684.         if (*s1++ & ~*s2++)
  685.             return 0;
  686.     }
  687.     return 1;
  688. }
  689.  
  690.  
  691. long *P_setcpy(d, s)                /* d := s */
  692. register long *d, *s;
  693. {
  694.     register long *save_d = d;
  695.  
  696. #ifdef SETCPY_MEMCPY
  697.     memcpy(d, s, (*s + 1) * sizeof(long));
  698. #else
  699.     register int i = *s + 1;
  700.     while (--i >= 0)
  701.         *d++ = *s++;
  702. #endif
  703.     return save_d;
  704. }
  705.  
  706.  
  707. /* s is a "smallset", i.e., a 32-bit or less set stored
  708.    directly in a long. */
  709.  
  710. long *P_expset(d, s)                /* d := s */
  711. register long *d;
  712. long s;
  713. {
  714.     if ((d[1] = s))
  715.         *d = 1;
  716.     else
  717.         *d = 0;
  718.     return d;
  719. }
  720.  
  721.  
  722. long P_packset(s)                   /* convert s to a small-set */
  723. register long *s;
  724. {
  725.     if (*s++)
  726.         return *s;
  727.     else
  728.         return 0;
  729. }
  730.  
  731.  
  732.  
  733.  
  734.  
  735. /* Oregon Software Pascal extensions, courtesy of William Bader */
  736.  
  737. int P_getcmdline(l, h, line)
  738. int l, h;
  739. Char *line;
  740. {
  741.     int i, len;
  742.     char *s;
  743.     
  744.     h = h - l + 1;
  745.     len = 0;
  746.     for(i = 1; i < P_argc; i++) {
  747.     s = P_argv[i];
  748.     while (*s) {
  749.         if (len >= h) return len;
  750.         line[len++] = *s++;
  751.     }
  752.     if (len >= h) return len;
  753.     line[len++] = ' ';
  754.     }
  755.     return len;
  756. }
  757.  
  758. Void TimeStamp(Day, Month, Year, Hour, Min, Sec)
  759. int *Day, *Month, *Year, *Hour, *Min, *Sec;
  760. {
  761. #ifndef NO_TIME
  762.     struct tm *tm;
  763.     long clock;
  764.  
  765.     time(&clock);
  766.     tm = localtime(&clock);
  767.     *Day = tm->tm_mday;
  768.     *Month = tm->tm_mon + 1;        /* Jan = 0 */
  769.     *Year = tm->tm_year;
  770.     if (*Year < 1900)
  771.     *Year += 1900;     /* year since 1900 */
  772.     *Hour = tm->tm_hour;
  773.     *Min = tm->tm_min;
  774.     *Sec = tm->tm_sec;
  775. #endif
  776. }
  777.  
  778.  
  779.  
  780.  
  781. /* SUN Berkeley Pascal extensions */
  782.  
  783. Void P_sun_argv(s, len, n)
  784. register char *s;
  785. register int len, n;
  786. {
  787.     register char *cp;
  788.  
  789.     if ((unsigned)n < P_argc)
  790.     cp = P_argv[n];
  791.     else
  792.     cp = "";
  793.     while (*cp && --len >= 0)
  794.     *s++ = *cp++;
  795.     while (--len >= 0)
  796.     *s++ = ' ';
  797. }
  798.  
  799.  
  800.  
  801.  
  802. int _OutMem()
  803. {
  804.     return _Escape(-2);
  805. }
  806.  
  807. int _CaseCheck()
  808. {
  809.     return _Escape(-9);
  810. }
  811.  
  812. int _NilCheck()
  813. {
  814.     return _Escape(-3);
  815. }
  816.  
  817.  
  818.  
  819.  
  820.  
  821. /* The following is suitable for the HP Pascal operating system.
  822.    It might want to be revised when emulating another system. */
  823.  
  824. char *_ShowEscape(buf, code, ior, prefix)
  825. char *buf, *prefix;
  826. int code, ior;
  827. {
  828.     char *bufp;
  829.  
  830.     if (prefix && *prefix) {
  831.         strcpy(buf, prefix);
  832.     strcat(buf, ": ");
  833.         bufp = buf + strlen(buf);
  834.     } else {
  835.         bufp = buf;
  836.     }
  837.     if (code == -10) {
  838.         sprintf(bufp, "Pascal system I/O error %d", ior);
  839.         switch (ior) {
  840.             case 3:
  841.                 strcat(buf, " (illegal I/O request)");
  842.                 break;
  843.             case 7:
  844.                 strcat(buf, " (bad file name)");
  845.                 break;
  846.             case FileNotFound:   /*10*/
  847.                 strcat(buf, " (file not found)");
  848.                 break;
  849.             case FileNotOpen:    /*13*/
  850.                 strcat(buf, " (file not open)");
  851.                 break;
  852.             case BadInputFormat: /*14*/
  853.                 strcat(buf, " (bad input format)");
  854.                 break;
  855.             case 24:
  856.                 strcat(buf, " (not open for reading)");
  857.                 break;
  858.             case 25:
  859.                 strcat(buf, " (not open for writing)");
  860.                 break;
  861.             case 26:
  862.                 strcat(buf, " (not open for direct access)");
  863.                 break;
  864.             case 28:
  865.                 strcat(buf, " (string subscript out of range)");
  866.                 break;
  867.             case EndOfFile:      /*30*/
  868.                 strcat(buf, " (end-of-file)");
  869.                 break;
  870.             case FileWriteError: /*38*/
  871.         strcat(buf, " (file write error)");
  872.         break;
  873.         }
  874.     } else {
  875.         sprintf(bufp, "Pascal system error %d", code);
  876.         switch (code) {
  877.             case -2:
  878.                 strcat(buf, " (out of memory)");
  879.                 break;
  880.             case -3:
  881.                 strcat(buf, " (reference to NIL pointer)");
  882.                 break;
  883.             case -4:
  884.                 strcat(buf, " (integer overflow)");
  885.                 break;
  886.             case -5:
  887.                 strcat(buf, " (divide by zero)");
  888.                 break;
  889.             case -6:
  890.                 strcat(buf, " (real math overflow)");
  891.                 break;
  892.             case -8:
  893.                 strcat(buf, " (value range error)");
  894.                 break;
  895.             case -9:
  896.                 strcat(buf, " (CASE value range error)");
  897.                 break;
  898.             case -12:
  899.                 strcat(buf, " (bus error)");
  900.                 break;
  901.             case -20:
  902.                 strcat(buf, " (stopped by user)");
  903.                 break;
  904.         }
  905.     }
  906.     return buf;
  907. }
  908.  
  909.  
  910. int _Escape(code)
  911. int code;
  912. {
  913.     char buf[100];
  914.  
  915.     P_escapecode = code;
  916.     if (__top_jb) {
  917.     __p2c_jmp_buf *jb = __top_jb;
  918.     __top_jb = jb->next;
  919.     longjmp(jb->jbuf, 1);
  920.     }
  921.     if (code == 0)
  922.         exit(0);
  923.     if (code == -1)
  924.         exit(1);
  925.     fprintf(stderr, "%s\n", _ShowEscape(buf, P_escapecode, P_ioresult, ""));
  926.     exit(1);
  927. }
  928.  
  929. int _EscIO(code)
  930. int code;
  931. {
  932.     P_ioresult = code;
  933.     return _Escape(-10);
  934. }
  935.  
  936.  
  937.  
  938.  
  939. /* End. */
  940.  
  941.  
  942.  
  943.