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