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