home *** CD-ROM | disk | FTP | other *** search
/ The Datafile PD-CD 3 / PDCD_3.iso / languages / pot / potsrc / lib / Core / c / pOtRTL < prev    next >
Text File  |  1995-02-21  |  19KB  |  733 lines
  1. /* pOt RTL implementation file, DT Wed Jan 26 1994 */
  2.  
  3. #include <pOtRTL.h>
  4. #include <stddef.h>
  5. #include <stdlib.h>
  6. #include <stdio.h>
  7. #include <string.h>
  8. #include <ctype.h>
  9. #include <math.h>
  10.  
  11. #ifdef __sun__
  12. #define memmove(d,s,size) bcopy(s,d,size)
  13. #endif
  14.  
  15. #define PtrSize 4
  16.  
  17. #define MinChar 0x0
  18. #define MaxChar 0x0FF
  19. #define MinBool 0
  20. #define MaxBool 1
  21. #define MinSInt -128
  22. #define MaxSInt 127
  23. #define MinInt -32768
  24. #define MaxInt 32767
  25. #define MinLInt ((pOt_LONGINT)0x80000000)
  26. #define MaxLInt 0x7FFFFFFF
  27.  
  28. #define MinReal -3.40282347E+38
  29. #define MaxReal 3.40282347E+38
  30. #define MinLReal -1.7976931348623157E+308
  31. #define MaxLReal 1.7976931348623157E+308
  32. #define MinSet 0
  33. #define MaxSet 31
  34.  
  35. typedef struct pOt__tag_gc_node {
  36.   struct pOt__tag_gc_node *next;
  37.   void *pvar[1];
  38. } pOt__gc_node;
  39.  
  40. int pOt__gc_enabled = 1;
  41. pOt__gc_node *pOt__gc_root = pOt_NIL;
  42. char *pOt__parfilename = NULL;
  43.  
  44. extern void pOt__gc pOt__ARGS((void));
  45. static void pOt__gc_register pOt__ARGS((void *p, pOt_LONGINT size));
  46.  
  47. void pOt__init_var(rec,td)
  48.     pOt__TypDsc **rec; pOt__TypDsc *td;
  49. {
  50.   *rec = td;
  51.   switch(td->mode) {
  52.     case 0: /* rec */ {
  53.       pOt_LONGINT i, stop;
  54.       pOt__RecTypDsc *rtd = (pOt__RecTypDsc *)td;
  55.  
  56.       for(;;) {
  57.         stop = rtd->nstr; i = 0;
  58.         while(i != stop) {
  59.           pOt__init_var((pOt__TypDsc**)((char *)rec + rtd->tab[i].poffs), rtd->tab[i].fld_td);
  60.           i++;
  61.         }
  62.         stop += rtd->nptr + rtd->npro;
  63.         while(i != stop) {
  64.           *(void **)((char *)rec + rtd->tab[i++].poffs) = pOt_NIL;
  65.         }
  66.         if(!(i = rtd->extlev)) break;
  67.         rtd = rtd->base_td[i-1];
  68.       }
  69.     }
  70.     break;
  71.     case 1: /* basic arr */
  72.       /* no initialization required */
  73.     break;
  74.     case 2: /* ptr arr */
  75.     case 3: /* proc arr */
  76.     {
  77.       pOt_LONGINT i;
  78.       pOt__PtrArrTypDsc *atd = (pOt__PtrArrTypDsc *)td;
  79.  
  80.       i = 0; rec = (pOt__TypDsc**)((char*)rec + sizeof(pOt__PtrArrTypDsc *));
  81.       while(i++ != atd->nofel) {
  82.         *rec = pOt_NIL;
  83.         rec = (pOt__TypDsc**)((char*)rec + atd->elsize);
  84.       }
  85.     }
  86.     break;
  87.     case 4: /* rec arr */ {
  88.       pOt_LONGINT i;
  89.       pOt__StrArrTypDsc *atd = (pOt__StrArrTypDsc *)td;
  90.  
  91.       i = 0; rec = (pOt__TypDsc**)((char*)rec + sizeof(pOt__StrArrTypDsc *));
  92.       while(i++ != atd->nofel) {
  93.         pOt__init_var(rec, atd->base_td);
  94.         rec = (pOt__TypDsc**)((char*)rec + atd->elsize);
  95.       }
  96.     }
  97.     break;
  98.   }
  99. }
  100.  
  101. /* halt */
  102. void pOt__halt(
  103.     char *filename, unsigned long line, pOt_SHORTINT trapnum)
  104. {
  105.   printf("\n%s(%lu):trap %i\n", filename, line, trapnum);
  106.   exit(trapnum);
  107. }
  108.  
  109. /* checks */
  110. pOt_LONGINT pOt__inxchk(
  111.     char *filename, unsigned long line, pOt_LONGINT len, pOt_LONGINT li)
  112. {
  113.   if((0 > li) || (li >= len)) {
  114.     pOt__halt(filename,line,3);
  115.   }
  116.   return li;
  117. }
  118.  
  119. void *pOt__nilchk(filename,line,ptr)
  120.     char *filename; unsigned long line; void *ptr;
  121. {
  122.   if(ptr == NULL) pOt__halt(filename,line,5);
  123.   return ptr;
  124. }
  125.  
  126. pOt_REAL pOt__rngchk_r(filename,line,lr)
  127.     char *filename; unsigned long line; pOt_LONGREAL lr;
  128. {
  129.   if((lr < MinReal) || (MaxReal < lr)) pOt__halt(filename,line,4);
  130.   return (pOt_REAL)lr;
  131. }
  132.  
  133. pOt_LONGINT  pOt__rngchk_li(filename,line,lr)
  134.     char *filename; unsigned long line; pOt_LONGREAL lr;
  135. {
  136.   pOt_LONGREAL flr;
  137.   flr = floor(lr);
  138.   if((flr < (pOt_LONGREAL)MinLInt) || ((pOt_LONGREAL)MaxLInt < flr)) pOt__halt(filename,line,4);
  139.   return (pOt_LONGINT)flr;
  140. }
  141.  
  142. pOt_INTEGER  pOt__rngchk_i(filename,line,li)
  143.     char *filename; unsigned long line; pOt_LONGINT li;
  144. {
  145.   if((li < MinInt) || (MaxInt < li)) pOt__halt(filename,line,4);
  146.   return (pOt_INTEGER)li;
  147. }
  148.  
  149. pOt_SHORTINT pOt__rngchk_si(
  150.     char *filename, unsigned long line, pOt_INTEGER i)
  151. {
  152.   if((i < MinSInt) || (MaxSInt < i)) pOt__halt(filename,line,4);
  153.   return (pOt_SHORTINT)i;
  154. }
  155.  
  156. pOt_SHORTINT pOt__rngchk_se(filename,line,i)
  157.     char *filename; unsigned long line; pOt_LONGINT i;
  158. {
  159.   if((i < MinSet) || (MaxSet < i)) pOt__halt(filename,line,4);
  160.   return (pOt_SHORTINT)i;
  161. }
  162.  
  163. unsigned char pOt__rngchk_cn(filename,line,li)
  164.     char *filename; unsigned long line; pOt_LONGINT li;
  165. {
  166.   if((li < MinChar) || (MaxChar < li)) pOt__halt(filename,line,4);
  167.   return (unsigned char)li;
  168. }
  169.  
  170. pOt__RecTypDsc **pOt__typchk(filename,line,rec,td,extlev)
  171.     char *filename; unsigned long line; pOt__RecTypDsc**rec; pOt__RecTypDsc *td; pOt_LONGINT extlev;
  172. {
  173.   if((((*rec)->extlev > extlev) && ((*rec)->base_td[extlev] != td)) || ((*rec) != td)) pOt__halt(filename,line,18);
  174.   return rec;
  175. }
  176.  
  177. /* operations */
  178. pOt_LONGINT pOt__div(x,y)
  179.     pOt_LONGINT x; pOt_LONGINT y;
  180. {
  181.   if(x >= 0) return x/y; return -((-x - 1)/y + 1);
  182. }
  183.  
  184. pOt_LONGINT pOt__addchk(
  185.     char *filename, unsigned long line, pOt_LONGINT x, pOt_LONGINT y, pOt_SHORTINT typ)
  186. {
  187.   x += y;
  188.   switch(typ) {
  189.   case 4: if((MinSInt > x) || (x > MaxSInt)) pOt__halt(filename,line,4); break;
  190.   case 5: if((MinInt > x) || (x > MaxInt)) pOt__halt(filename,line,4); break;
  191.   case 6: break;
  192.   default: pOt__halt(filename,line,16); break;
  193.   }
  194.   return x;
  195. }
  196.  
  197. pOt_LONGINT pOt__subchk(
  198.     char *filename, unsigned long line, pOt_LONGINT x, pOt_LONGINT y, pOt_SHORTINT typ)
  199. {
  200.   x -= y;
  201.   switch(typ) {
  202.   case 4: if((MinSInt > x) || (x > MaxSInt)) pOt__halt(filename,line,4); break;
  203.   case 5: if((MinInt > x) || (x > MaxInt)) pOt__halt(filename,line,4); break;
  204.   case 6: break;
  205.   default: pOt__halt(filename,line,16); break;
  206.   }
  207.   return x;
  208. }
  209.  
  210. pOt_LONGINT pOt__mulchk(
  211.     char *filename, unsigned long line, pOt_LONGINT x, pOt_LONGINT y, pOt_SHORTINT typ)
  212. {
  213.   x *= y;
  214.   switch(typ) {
  215.   case 4: if((MinSInt > x) || (x > MaxSInt)) pOt__halt(filename,line,4); break;
  216.   case 5: if((MinInt > x) || (x > MaxInt)) pOt__halt(filename,line,4); break;
  217.   case 6: break;
  218.   default: pOt__halt(filename,line,16); break;
  219.   }
  220.   return x;
  221. }
  222.  
  223.  
  224. pOt_LONGINT pOt__divchk(
  225.     char *filename, unsigned long line, pOt_LONGINT x, pOt_LONGINT y, pOt_SHORTINT typ)
  226. {
  227.   if(y == 0) pOt__halt(filename,line,6);
  228.   if(y < 0) pOt__halt(filename,line,7);
  229.   if(x >= 0) return x/y; return -((-x - 1)/y + 1);
  230. }
  231.  
  232. pOt_LONGINT pOt__mod(x,y)
  233.     pOt_LONGINT x; pOt_LONGINT y;
  234. {
  235.   if(x >= 0) return x%y; return y - 1 - (-x-1)%y;
  236. }
  237.  
  238. pOt_LONGINT pOt__modchk(
  239.     char *filename, unsigned long line, pOt_LONGINT x, pOt_LONGINT y, pOt_SHORTINT typ)
  240. {
  241.   if(y == 0) pOt__halt(filename,line,6);
  242.   if(y < 0) pOt__halt(filename,line,7);
  243.   if(x >= 0) return x%y; return y - 1 - (-x-1)%y;
  244. }
  245.  
  246. pOt_BOOLEAN pOt__typtest(rec,td,extlev)
  247.     pOt__RecTypDsc **rec; pOt__RecTypDsc *td; pOt_LONGINT extlev;
  248. {
  249.   if((*rec)->extlev > extlev) return (*rec)->base_td[extlev] == td;
  250.   return (*rec) == td;
  251. }
  252.  
  253. /* strings relations */
  254. pOt_BOOLEAN pOt__cmpss(
  255.     pOt_CHAR *s1, pOt_CHAR *s2, pOt_INTEGER op)
  256. {
  257.   pOt_LONGINT i;
  258.   s1 += sizeof(pOt__ArrTypDsc*); s2 += sizeof(pOt__ArrTypDsc*);
  259.   i = 0; while((s1[i] != '\0') && (s1[i] == s2[i])) i++;
  260.   if(s1[i] == s2[i]) {
  261.     switch(op) {
  262.     case 9: case 12: case 14: return pOt_TRUE;
  263.     case 10: case 11: case 13: return pOt_FALSE;
  264.     }
  265.   }
  266.   else {
  267.     switch(op) {
  268.     case 9: return pOt_FALSE;
  269.     case 10: return pOt_TRUE;
  270.     case 11: case 12: return s1[i] < s2[i];
  271.     case 13: case 14: return s1[i] > s2[i];
  272.     }
  273.   }
  274. }
  275.  
  276. pOt_BOOLEAN pOt__cmpsc(
  277.     pOt_CHAR *s1, pOt_CHAR c2, pOt_INTEGER op)
  278. {
  279.   s1 += sizeof(pOt__ArrTypDsc*);
  280.   if(s1[0] == c2) {
  281.     switch(op) {
  282.     case 9: return s1[1] == '\0';
  283.     case 10: return s1[1] != '\0';
  284.     case 11: return pOt_FALSE;
  285.     case 12: return s1[1] == '\0';
  286.     case 13: return s1[1] > '\0';
  287.     case 14: return s1[1] >= '\0';
  288.     }
  289.   }
  290.   else {
  291.     switch(op) {
  292.     case 9: return pOt_FALSE;
  293.     case 10: return pOt_TRUE;
  294.     case 11: case 12: return s1[0] < c2;
  295.     case 13: case 14: return s1[0] > c2;
  296.     }
  297.   }
  298. }
  299.  
  300. pOt_BOOLEAN pOt__cmpcs(
  301.     pOt_CHAR c1, pOt_CHAR *s2, pOt_INTEGER op)
  302. {
  303.   s2 += sizeof(pOt__ArrTypDsc*);
  304.   if(c1 == s2[0]) {
  305.     switch(op) {
  306.     case 9: return s2[1] == '\0';
  307.     case 10: return s2[1] != '\0';
  308.     case 11: return s2[1] > '\0';
  309.     case 12: return s2[1] >= '\0';
  310.     case 13: return pOt_FALSE;
  311.     case 14: return s2[1] == '\0';
  312.     }
  313.   }
  314.   else {
  315.     switch(op) {
  316.     case 9: return pOt_FALSE;
  317.     case 10: return pOt_TRUE;
  318.     case 11: case 12: return c1 < s2[0];
  319.     case 13: case 14: return c1 > s2[0];
  320.     }
  321.   }
  322. }
  323.  
  324. /* built-in functions */
  325. void pOt__new(filename,lin