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