home *** CD-ROM | disk | FTP | other *** search
/ ftp.uni-stuttgart.de/pub/systems/acorn/ / Acorn.tar / Acorn / acornet / dev / oberon / potsrc.spk / 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,line,pp,td)
  326.     char *filename; unsigned long line; pOt__TypDsc ***pp; pOt__TypDsc *td;
  327. {
  328.   pOt_LONGINT size;
  329.  
  330.   if(td->mode == 0) size = ((pOt__RecTypDsc*)td)->size;
  331.   else size = sizeof(pOt__ArrTypDsc*) + ((pOt__ArrTypDsc*)td)->nofel*((pOt__ArrTypDsc*)td)->elsize;
  332.   *pp = (pOt__TypDsc**)malloc(size);
  333.   if(*pp == NULL) {
  334.     pOt__gc(); *pp = (pOt__TypDsc**)malloc(size);
  335.     if(*pp == NULL) pOt__halt(filename,line,1);
  336.   }
  337.   pOt__init_var(*pp, td);
  338.   pOt__gc_register(*pp, size);
  339. }
  340.  
  341. pOt_LONGINT pOt__abs(x) pOt_LONGINT x; {if(x < 0) return -x; return x;}
  342. pOt_LONGREAL pOt__fabs(x) pOt_LONGREAL x; {if(x < 0) return -x; return x;}
  343.  
  344. pOt_CHAR pOt__cap(pOt_CHAR c) {return toupper(c);}
  345. pOt_LONGINT pOt__entier(lr) pOt_LONGREAL lr; {return floor(lr);}
  346.  
  347. pOt_LONGINT pOt__ash(x,n)
  348.     pOt_LONGINT x; pOt_LONGINT n;
  349. {
  350.   if(n>0) {if(x>0) return x << n; return -(-x << n);}
  351.   else {if(x>0) return x >> -n; return -(-x >> -n);}
  352. }
  353.  
  354. pOt_LONGINT pOt__lsh(x,n)
  355.     pOt_LONGINT x; pOt_LONGINT n;
  356. {
  357.   if(n>0) return (unsigned long)x << n; return (unsigned long)x >> -n;
  358. }
  359.  
  360. pOt_LONGINT pOt__rot(
  361.     pOt_LONGINT x, pOt_SHORTINT l, pOt_LONGINT n)
  362. {
  363.   unsigned long a,b;
  364.  
  365.   if(n > 0) { n %= l; a = (unsigned long)x << n; b = (unsigned long)x >> (l - n);}
  366.   else {n = -n % l; a = (unsigned long)x >> n; b = (unsigned long)x << (l - n);}
  367.   return a | b;
  368. }
  369.  
  370. void pOt__copy(src,dst)
  371.     pOt_CHAR *src; pOt_CHAR *dst;
  372. {
  373.   src += PtrSize; dst += PtrSize; while(*(dst++) = *(src++));
  374. }
  375.  
  376. void pOt__copychk(filename,line,src,dst)
  377.     char *filename; unsigned long line; pOt_CHAR *src; pOt_CHAR *dst;
  378. {
  379.   pOt_LONGINT len, i;
  380.  
  381.   len = (*(pOt__ArrTypDsc**)src)->nofel < (*(pOt__ArrTypDsc**)dst)->nofel?
  382.           (*(pOt__ArrTypDsc**)src)->nofel : (*(pOt__ArrTypDsc**)dst)->nofel;
  383.   src += PtrSize; dst += PtrSize; i = 0;
  384.   for(;;) {
  385.     if((dst[i] = src[i]) == '\0') break;
  386.     if(++i == len) pOt__halt(filename, line, 3);
  387.   }
  388. }
  389.  
  390. void pOt__get(src,dst,size)
  391.     pOt_BYTE_SYSTEM *src; pOt_BYTE_SYSTEM *dst;pOt_LONGINT size;
  392. {
  393.   memmove((char*)dst,(char*)src,size);
  394. }
  395.  
  396. void pOt__put(dst,src,size)
  397.     pOt_BYTE_SYSTEM *dst; pOt_BYTE_SYSTEM *src; pOt_LONGINT size;
  398. {
  399.   memmove((char*)dst,(char*)src,size);
  400. }
  401.  
  402. void pOt__move(src,dst,size)
  403.     pOt_BYTE_SYSTEM *src; pOt_BYTE_SYSTEM *dst; pOt_LONGINT size;
  404. {
  405.   memmove((char*)dst,(char*)src,size);
  406. }
  407.  
  408. void *pOt__alloc(filename,line,size)
  409.     char *filename; unsigned long line; pOt_LONGINT size;
  410. {
  411.   void *pp;
  412.   pp = malloc(size);
  413.   if(pp == NULL) {
  414.     pOt__gc(); pp = malloc(size);
  415.     if(pp == NULL) pOt__halt(filename,line,1);
  416.   }
  417.   return pp;
  418. }
  419.  
  420. /* strings constants */
  421. pOt__ArrTypDsc pOt__str_td[pOt__MaxStrLen+1] = {
  422.   {1,   1, 1}, {1,   2, 1}, {1,   3, 1}, {1,   4, 1}, {1,   5, 1},
  423.   {1,   6, 1}, {1,   7, 1}, {1,   8, 1}, {1,   9, 1}, {1,  10, 1},
  424.   {1,  11, 1}, {1,  12, 1}, {1,  13, 1}, {1,  14, 1}, {1,  15, 1},
  425.   {1,  16, 1}, {1,  17, 1}, {1,  18, 1}, {1,  19, 1}, {1,  20, 1},
  426.   {1,  21, 1}, {1,  22, 1}, {1,  23, 1}, {1,  24, 1}, {1,  25, 1},
  427.   {1,  26, 1}, {1,  27, 1}, {1,  28, 1}, {1,  29, 1}, {1,  30, 1},
  428.   {1,  31, 1}, {1,  32, 1}, {1,  33, 1}, {1,  34, 1}, {1,  35, 1},
  429.   {1,  36, 1}, {1,  37, 1}, {1,  38, 1}, {1,  39, 1}, {1,  40, 1},
  430.   {1,  41, 1}, {1,  42, 1}, {1,  43, 1}, {1,  44, 1}, {1,  45, 1},
  431.   {1,  46, 1}, {1,  47, 1}, {1,  48, 1}, {1,  49, 1}, {1,  50, 1},
  432.   {1,  51, 1}, {1,  52, 1}, {1,  53, 1}, {1,  54, 1}, {1,  55, 1},
  433.   {1,  56, 1}, {1,  57, 1}, {1,  58, 1}, {1,  59, 1}, {1,  60, 1},
  434.   {1,  61, 1}, {1,  62, 1}, {1,  63, 1}, {1,  64, 1}, {1,  65, 1},
  435.   {1,  66, 1}, {1,  67, 1}, {1,  68, 1}, {1,  69, 1}, {1,  70, 1},
  436.   {1,  71, 1}, {1,  72, 1}, {1,  73, 1}, {1,  74, 1}, {1,  75, 1},
  437.   {1,  76, 1}, {1,  77, 1}, {1,  78, 1}, {1,  79, 1}, {1,  80, 1},
  438.   {1,  81, 1}, {1,  82, 1}, {1,  83, 1}, {1,  84, 1}, {1,  85, 1},
  439.   {1,  86, 1}, {1,  87, 1}, {1,  88, 1}, {1,  89, 1}, {1,  90, 1},
  440.   {1,  91, 1}, {1,  92, 1}, {1,  93, 1}, {1,  94, 1}, {1,  95, 1},
  441.   {1,  96, 1}, {1,  97, 1}, {1,  98, 1}, {1,  99, 1}, {1, 100, 1},
  442.   {1, 101, 1}, {1, 102, 1}, {1, 103, 1}, {1, 104, 1}, {1, 105, 1},
  443.   {1, 106, 1}, {1, 107, 1}, {1, 108, 1}, {1, 109, 1}, {1, 110, 1},
  444.   {1, 111, 1}, {1, 112, 1}, {1, 113, 1}, {1, 114, 1}, {1, 115, 1},
  445.   {1, 116, 1}, {1, 117, 1}, {1, 118, 1}, {1, 119, 1}, {1, 120, 1},
  446.   {1, 121, 1}, {1, 122, 1}, {1, 123, 1}, {1, 124, 1}, {1, 125, 1},
  447.   {1, 126, 1}, {1, 127, 1}, {1, 128, 1}
  448. };
  449.  
  450. pOt__ArrTypDsc **pOt__set_str_td(str,td)
  451.     pOt_CHAR *str; pOt__ArrTypDsc *td;
  452. {
  453.   *(pOt__ArrTypDsc**)str = td;
  454.   return (pOt__ArrTypDsc**)str;
  455. }
  456.  
  457. /* passing as parameters */
  458. pOt__BytArr pOt__make_byte_arr(
  459.     void *var, pOt_INTEGER form, pOt_LONGINT size)
  460. {
  461.   pOt__BytArr ba;
  462.   if(size == 0) {
  463.     switch(form) {
  464.     case 0: return *(pOt__BytArr*)var;
  465.     case 1:
  466.       ba.len = (*(pOt__ArrTypDsc**)var)->nofel;
  467.       ba.data = (pOt_BYTE_SYSTEM*)var + sizeof(pOt__ArrTypDsc*);
  468.     break;
  469.     case 2:
  470.       ba.len = (*(pOt__ArrTypDsc**)var)->nofel*(*(pOt__ArrTypDsc**)var)->elsize;
  471.       ba.data = (pOt_BYTE_SYSTEM*)var + sizeof(pOt__ArrTypDsc*);
  472.     break;
  473.     case 3:
  474.       ba.len = (*(pOt__RecTypDsc**)var)->size - sizeof(pOt__RecTypDsc*);
  475.       ba.data = (pOt_BYTE_SYSTEM*)var + sizeof(pOt__RecTypDsc*);
  476.     break;
  477.     }
  478.   }
  479.   else {
  480.     ba.len = size;
  481.     ba.data = (pOt_BYTE_SYSTEM*)var;
  482.   }
  483.   return ba;
  484. }
  485.  
  486. pOt__BytArr pOt__dup_byte_arr(
  487.     char *filename, unsigned long line, void*var, pOt_INTEGER form)
  488. {
  489.   pOt__BytArr ba;
  490.   switch(form) {
  491.   case 0:
  492.     ba.len = ((pOt__BytArr*)var)->len;
  493.     if((ba.data = (pOt_BYTE_SYSTEM*)malloc(ba.len)) == NULL) pOt__halt(filename,line,2);
  494.     memcpy((char*)ba.data, (char*)((pOt__BytArr*)var)->data, ba.len);
  495.   break;
  496.   case 1:
  497.     ba.len = (*(pOt__ArrTypDsc**)var)->nofel;
  498.     if((ba.data = (pOt_BYTE_SYSTEM*)malloc(ba.len)) == NULL) pOt__halt(filename,line,2);
  499.     memcpy((char*)ba.data, (char*)((pOt_BYTE_SYSTEM*)var + sizeof(pOt__ArrTypDsc*)), ba.len);
  500.   break;
  501.   }
  502.   return ba;
  503. }
  504.  
  505. void pOt__rm_byte_arr(ba) pOt__BytArr ba;
  506. {
  507.   free(ba.data);
  508. }
  509.  
  510. pOt__ArrTypDsc **pOt__dup_arr(filename,line,var)
  511.     char *filename; unsigned long line; pOt__ArrTypDsc**var;
  512. {
  513.   pOt__ArrTypDsc **arr;
  514.   pOt_LONGINT size;
  515.  
  516.   size = (*(pOt__ArrTypDsc**)var)->nofel*(*(pOt__ArrTypDsc**)var)->elsize + sizeof(pOt__ArrTypDsc*);
  517.   if((arr = (pOt__ArrTypDsc**)malloc(size)) == NULL) pOt__halt(filename,line,2);
  518.   memcpy((char*)arr, (char*)var, size);
  519.  
  520.   return arr;
  521. }
  522.  
  523. pOt__RecTypDsc **pOt__dup_rec(filename,line,var,td)
  524.     char *filename; unsigned long line; pOt__RecTypDsc**var;pOt__RecTypDsc*td;
  525. {
  526.   pOt__RecTypDsc **rec;
  527.  
  528.   if((rec = (pOt__RecTypDsc**)malloc(td->size)) == NULL) pOt__halt(filename,line,2);
  529.   memcpy((char*)(rec+1), (char*)(var+1), td->size - sizeof(pOt__RecTypDsc*));
  530.   *rec = td;
  531.   return rec;
  532. }
  533.  
  534. void pOt__rm_par(var)
  535.     pOt__TypDsc **var;
  536. {
  537.   free(var);
  538. }
  539.  
  540. /* assignment */
  541. void pOt__arr_assign(dst,src)
  542.     pOt__ArrTypDsc**dst; pOt__ArrTypDsc**src;
  543. {
  544.   memcpy((char*)(dst+1),(char*)(src+1), (*dst)->nofel*(*dst)->elsize);
  545. }
  546.  
  547. void pOt__rec_assign(dst,src)
  548.     pOt__RecTypDsc**dst;pOt__RecTypDsc**src;
  549. {
  550.   memcpy((char*)(dst+1), (char*)(src+1), (*dst)->size - sizeof(pOt__RecTypDsc*));
  551. }
  552.  
  553. void pOt__varrec_assign(filename,line,dst,src)
  554.     char*filename; unsigned long line; pOt__RecTypDsc**dst;pOt__RecTypDsc**src;
  555. {
  556.   if((*dst)->extlev > (*src)->extlev) pOt__halt(filename,line,19);
  557.   memcpy((char*)(dst+1), (char*)(src+1), (*dst)->size - sizeof(pOt__RecTypDsc*));
  558. }
  559.  
  560. /* system dependant keywords */
  561. #define pOt__interrupt
  562.  
  563. /* GC */
  564.  
  565. extern pOt_LONGINT pOt__gc_heapthreshold;
  566.  
  567. typedef struct pOt__gc_tag_HeapNodeDesc {
  568.   void *chunk;
  569.   struct pOt__gc_tag_HeapNodeDesc *next;
  570. } pOt__gc_HeapNodeDesc;
  571. typedef pOt__gc_HeapNodeDesc *pOt__gc_HeapNode;
  572.  
  573. static pOt__gc_HeapNode pOt__gc_marked = pOt_NIL, pOt__gc_heap = pOt_NIL;
  574. static long pOt__gc_heapdelta = 0L;
  575.  
  576. static void pOt__gc_register(p,size)
  577.     void *p; pOt_LONGINT size;
  578. {
  579.   pOt__gc_HeapNode node;
  580.   node = (pOt__gc_HeapNode)malloc(sizeof(pOt__gc_HeapNodeDesc));
  581.   if(node == NULL) {
  582.     pOt__gc();
  583.     node = (pOt__gc_HeapNode)malloc(sizeof(pOt__gc_HeapNodeDesc));
  584.     if(node == NULL) pOt__halt(__FILE__,__LINE__,20);
  585.   }
  586.   node->next = pOt__gc_heap;
  587.   pOt__gc_heap = node;
  588.   node->chunk = p;
  589.   pOt__gc_heapdelta += size;
  590.  
  591.   if(pOt__gc_heapdelta >= pOt__gc_heapthreshold) pOt__gc();
  592. }
  593.  
  594. static void *pOt__gc_markptr(p)
  595.     void *p;
  596. {
  597.   pOt__gc_HeapNode node, node1;
  598.  
  599.   node = pOt__gc_heap;
  600.   if(node == pOt_NIL) return pOt_NIL;
  601.   else if(node->chunk == p) {
  602.     pOt__gc_heap = node->next;
  603.     node->next = pOt__gc_marked;
  604.     pOt__gc_marked = node;
  605.   } else {
  606.     while((node->next != pOt_NIL) && (node->next->chunk != p)) node = node->next;
  607.     if(node->next != pOt_NIL) {
  608.       node1 = node->next;
  609.       node->next = node1->next;
  610.       node1->next = pOt__gc_marked;
  611.       pOt__gc_marked = node1;
  612.     } else return pOt_NIL;
  613.   }
  614.   return p;
  615. }
  616.  
  617. void pOt__gc_markvar(v)
  618.     pOt__TypDsc **v;
  619. {
  620.   void *p;
  621.  
  622.   switch((*v)->mode) {
  623.   case 0: /* rec */ {
  624.     pOt_LONGINT i, stop;
  625.     pOt__RecTypDsc *rtd = *(pOt__RecTypDsc**)v;
  626.     for(;;) {
  627.       stop = rtd->nstr; i = 0;
  628.       while(i != stop) {
  629.         pOt__gc_markvar((pOt__TypDsc**)((char*)v + rtd->tab[i].poffs));
  630.         i++;
  631.       }
  632.       stop += rtd->nptr;
  633.       while(i != stop) {
  634.         p = *(void**)((char*)v + rtd->tab[i].poffs);
  635.         if((p != pOt_NIL) && (pOt__gc_markptr(p) != pOt_NIL)) {
  636.           pOt__gc_markvar((pOt__TypDsc**)p);
  637.         }
  638.         i++;
  639.       }
  640.       if(!(i = rtd->extlev)) break;
  641.       rtd = rtd->base_td[i-1];
  642.     }
  643.   }
  644.   break;
  645.   case 1:
  646.   break;
  647.   case 2: {
  648.     pOt_LONGINT i;
  649.     pOt__PtrArrTypDsc *atd = *(pOt__PtrArrTypDsc**)v;
  650.  
  651.     i = 0;  v = (pOt__TypDsc**)((char*)v + sizeof(pOt__PtrArrTypDsc*));
  652.     while(i != atd->nofel) {
  653.       p = *v;
  654.       if((p != pOt_NIL) && (pOt__gc_markptr(p) != pOt_NIL)) {
  655.         pOt__gc_markvar((pOt__TypDsc**)p);
  656.       }
  657.       v = (pOt__TypDsc**)((char*)v + atd->elsize);
  658.       i++;
  659.     }
  660.  
  661.   }
  662.   break;
  663.   case 3:
  664.   break;
  665.   case 4: {
  666.     pOt_LONGINT i;
  667.     pOt__StrArrTypDsc *atd = *(pOt__StrArrTypDsc**)v;
  668.  
  669.     i = 0;  v = (pOt__TypDsc**)((char*)v + sizeof(pOt__StrArrTypDsc*));
  670.     while(i != atd->nofel) {
  671.       pOt__gc_markvar(v);
  672.       v = (pOt__TypDsc**)((char*)v + atd->elsize);
  673.       i++;
  674.     }
  675.   }
  676.   break;
  677.   default:
  678.     pOt__halt(__FILE__,__LINE__,21);
  679.   break;
  680.   }
  681. }
  682.  
  683. static void pOt__gc_mark()
  684. {
  685.   pOt__gc_node *frame;
  686.   pOt_LONGINT i;
  687.   pOt__TypDsc ***pptr, **pstr;
  688.  
  689.   frame = pOt__gc_root;
  690.   while(frame != pOt_NIL) {
  691.     i = 0;
  692.     for(;;) {
  693.       pstr = (pOt__TypDsc**)frame->pvar[i];
  694.       if(pstr == pOt_NIL) break;
  695.       pOt__gc_markvar(pstr);
  696.       i++;
  697.     }
  698.     frame = frame->next;
  699.     i = 0;
  700.     for(;;) {
  701.       pptr = (pOt__TypDsc***)frame->pvar[i];
  702.       if(pptr == pOt_NIL) break;
  703.       if((*pptr != pOt_NIL) && (pOt__gc_markptr(*pptr)!= pOt_NIL)) {
  704.         pOt__gc_markvar(*pptr);
  705.       }
  706.       i++;
  707.     }
  708.     frame = frame->next;
  709.   }
  710. }
  711.  
  712. static void pOt__gc_sweep()
  713. {
  714.   pOt__gc_HeapNode node;
  715.   node = pOt__gc_heap;
  716.   while(node != pOt_NIL) {
  717.     free(node->chunk); pOt__gc_heap = node->next;
  718.     free(node); node = pOt__gc_heap;
  719.   }
  720.   pOt__gc_heap = pOt__gc_marked; pOt__gc_marked = pOt_NIL;
  721.   pOt__gc_heapdelta = 0L;
  722. }
  723.  
  724. void pOt__gc()
  725. {
  726.   if(pOt__gc_enabled) {
  727.     pOt__gc_mark();
  728.     pOt__gc_sweep();
  729.   }
  730. }
  731.  
  732. /* the end */
  733.