home *** CD-ROM | disk | FTP | other *** search
/ APDL Public Domain 1 / APDL_PD1A.iso / program / language / huprolog / Source / C / MANAGER < prev    next >
Encoding:
Text File  |  1990-06-10  |  12.3 KB  |  435 lines
  1. /***************************************************
  2. ****************************************************
  3. **                                                **
  4. **  HU-Prolog     Portable Interpreter System     **
  5. **                                                **
  6. **  Release 1.62   January  1990                  **
  7. **                                                **
  8. **  Authors:      C.Horn, M.Dziadzka, M.Horn      **
  9. **                                                **
  10. **  (C) 1989      Humboldt-University             **
  11. **                Department of Mathematics       **
  12. **                GDR 1086 Berlin, P.O.Box 1297   **
  13. **                                                **
  14. ****************************************************
  15. ***************************************************/
  16.  
  17. #include "systems.h"
  18. #include "types.h"
  19. #include "errors.h"
  20. #include "atoms.h"
  21. #include "manager.h"
  22.  
  23. IMPORT ENV ENVTOP;
  24. IMPORT void ABORT(),ERROR(),SYSTEMERROR();      /* from linebufffer.c */
  25. IMPORT void ARGERROR(),ERROR();    /* from linebuff.c */
  26. FORWARD void reclaim_heap();
  27.  
  28.  
  29. /*
  30. EXPORT STRINGSTOP;
  31. EXPORT ATOMSTOP,ATOMHTOP;
  32. EXPORT setsize();  
  33. #if REALARITH
  34. EXPORT TERM mkreal(REAL);
  35. EXPORT REAL realval(TERM);
  36. #endif
  37. #if LONGARITH
  38. EXPORT TERM mklong(LONG);
  39. EXPORT LONG longval(TERM);
  40. #endif
  41. */
  42.  
  43.  
  44. /**********************************************************
  45. *                                                         *
  46. *  ATOMS                                                  *
  47. *                                                         *
  48. **********************************************************/
  49.  
  50. GLOBAL ATOM BASEATOM=atom_units(0);
  51. GLOBAL ATOM ATOMHTOP=LAST_ATOM;
  52. GLOBAL ATOM ATOMSTOP=MAXATOMS;
  53.  
  54. /*   0         =>       +----------------------------+  */
  55. /*                       |  predefined atoms          |  */
  56. /*   LASTATOM  =>       + - - - - - - - - - - - - - -+  */
  57. /*                       |  global atoms in           |  */
  58. /*                       |  hashtable      |  |  |    |  */
  59. /*   ATOMHTOP  =>       |                 v  v  v    |  */
  60. /*                       |  - free - free - free -    |  */
  61. /*                       |                            |  */
  62. /*   ATOMSTOP  =>       |                 ^  ^  ^    |  */
  63. /*                       |  local          |  |  |    |  */
  64. /*                       |  atomstack      |  |  |    |  */
  65. /*   MAXATOMS  =>       +----------------------------+  */
  66.  
  67. /**********************************************************
  68. *                                                         *
  69. *  TERMS                                                  *
  70. *                                                         *
  71. **********************************************************/
  72.  
  73. #if !POINTEROFFSET
  74. GLOBAL TERM BASETERM=term_units(0);
  75. GLOBAL TERM GLOTOP=term_units(1);       
  76. GLOBAL TERM HEAPTOP=MAXTERMS;
  77. GLOBAL TERM LASTTERM=MAXTERMS;
  78. #endif
  79.  
  80. #if POINTEROFFSET
  81. GLOBAL TERM BASETERM= &TERMAREA[0];
  82. GLOBAL TERM GLOTOP= &TERMAREA[1];       
  83. GLOBAL TERM HEAPTOP= &TERMAREA[MAXTERMS];
  84. GLOBAL TERM LASTTERM= &TERMAREA[MAXTERMS];
  85. #endif
  86.  
  87.                   /* increasing index of local variables */
  88.                   /*     |                               */
  89.                   /*     |                               */
  90.                   /*     V                               */
  91.                   /*                                     */
  92.                   /*     ^                               */
  93.                   /*     |                               */
  94.                   /*     |                               */
  95.                   /* decreasing index of heap nodes      */
  96.                
  97. /**********************************************************
  98. *                                                         *
  99. *  STRINGS                                                *
  100. *                                                         *
  101. **********************************************************/
  102.  
  103. GLOBAL STRING BASESTRING=0;
  104. GLOBAL STRING STRINGHTOP=1;
  105. GLOBAL STRING STRINGSTOP=MAXSTRINGS;
  106.  
  107. /* #if POINTEROFFSET
  108. GLOBAL STRING BASESTRING= &STRINGTAB[0];
  109. GLOBAL STRING STRINGHTOP= &STRINGTAB[1];
  110. GLOBAL STRING STRINGSTOP= &STRINGTAB[MAXSTRINGS];
  111. #endif
  112. */
  113.  
  114. /*   BASESTRING =>      +----------------------------+  */
  115. /*                       |  global strings            |  */
  116. /*                       |                 |  |  |    |  */
  117. /*   STRINGHTOP  =>     |                 v  v  v    |  */
  118. /*                       |  - free - free - free -    |   */
  119. /*                       |                            |  */
  120. /*   STRINGSTOP  =>     |                 ^  ^  ^    |  */
  121. /*                       |  local          |  |  |    |  */
  122. /*                       |  stringstack    |  |  |    |  */
  123. /*   MAXSTRINGS          +----------------------------+  */
  124.  
  125.  
  126.  
  127.  
  128. /**********************************************************
  129. *                                                         *
  130. *  ATOMS                                                  *
  131. *                                                         *
  132. **********************************************************/
  133.  
  134.  
  135. GLOBAL ATOM heapatom(void)
  136. {if(inc_atom(ATOMHTOP)>=ATOMSTOP) ABORT(ATOMSPACEE);
  137.  return (ATOM)ATOMHTOP ;
  138. }
  139.  
  140. GLOBAL ATOM stackatom(void)
  141. {if(dec_atom(ATOMSTOP)<=ATOMHTOP) ABORT(ATOMSPACEE);
  142.  nextatom(ATOMSTOP)=(card)STRINGSTOP;
  143.  return (ATOM)ATOMSTOP;
  144. }
  145.  
  146. #if ! INLINE
  147. GLOBAL boolean isheapatom(register ATOM A)
  148. {
  149.     return (A && A <=ATOMHTOP);
  150. }
  151. #endif
  152.  
  153. /**********************************************************
  154. *                                                         *
  155. *  TERMS                                                  *
  156. *                                                         *
  157. **********************************************************/
  158.  
  159. GLOBAL TERM arg1(register TERM T)
  160. { T=son(T); deref(T); return T; }
  161.  
  162. GLOBAL TERM arg2(register TERM T)
  163. { T=son(T)+term_units(1); /* T=br(T); */ deref(T); return T; }
  164.  
  165. GLOBAL TERM arg3(register TERM T)
  166. { T=son(T)+term_units(2); /* T=br(br(T)); */ deref(T); return T; }
  167.  
  168. GLOBAL TERM arg4(register TERM T)
  169. { T=son(T)+term_units(3); /* T=br(br(br(T))); */  deref(T); return T; }
  170.  
  171. GLOBAL TERM mkfunc(register ATOM N, register TERM T)
  172. { register TERM X;
  173.   X=GLOTOP; 
  174.   if(inc_term(GLOTOP)>=HEAPTOP) reclaim_heap(true);
  175.   name(X)=N; son(X)=T;
  176.   return X;
  177. }
  178.  
  179. GLOBAL TERM mkatom(ATOM N)
  180. { register TERM X;
  181.   X=GLOTOP; 
  182.   if(inc_term(GLOTOP)>=HEAPTOP) reclaim_heap(true);
  183.   name(X)=N; son(X)=nil_term;
  184.   return X;
  185. }
  186.  
  187. GLOBAL TERM mkint(int N)
  188. { register TERM X;
  189.   X=GLOTOP; 
  190.   if(inc_term(GLOTOP)>=HEAPTOP) reclaim_heap(true);
  191.   name(X)=INTT; ival(X)=N;
  192.   return X;
  193. }
  194.  
  195. GLOBAL TERM mkfreevar(void)
  196. { register TERM X;
  197.   X=GLOTOP; 
  198.   if(inc_term(GLOTOP)>=HEAPTOP) reclaim_heap(true);
  199.   name(X)=UNBOUNDT; son(X)=nil_term;
  200.   return X;
  201. }
  202.  
  203. GLOBAL TERM stackterms(register int N)
  204. { register TERM X;
  205.   if(N==0) return nil_term;
  206.   X=GLOTOP;
  207.   GLOTOP+=term_units(N);
  208.   if(GLOTOP>=HEAPTOP) reclaim_heap(true);
  209.   return X;
  210. }
  211.  
  212. GLOBAL TERM mk2sons(ATOM NAM1, TERM SON1, ATOM NAM2, TERM SON2)
  213. { register TERM T,TT;
  214.     T=GLOTOP; TT=GLOTOP+term_units(1); GLOTOP+=term_units(2);
  215.     if(GLOTOP>=HEAPTOP) reclaim_heap(true);
  216.     name(T)=NAM1; son(T)=SON1; 
  217.     name(TT)=NAM2; son(TT)=SON2; 
  218.     return T;
  219. }
  220.  
  221. GLOBAL TERM freelist[MAXARITY+1];  /* chain of disposed nodes */ 
  222.  
  223. GLOBAL void InitMemory(void)
  224. { int N;
  225.   for (N=0;N<=MAXARITY;N++) freelist[N]=nil_term;
  226. }
  227.  
  228. GLOBAL TERM heapterms(register int N)
  229. { register TERM T;
  230.   if(N > MAXARITY) SYSTEMERROR("heapterms");
  231.   if( N==0) return nil_term;
  232.   if(non_nil_term(T=freelist[N])) 
  233.     { freelist[N]=son(T); return T; }
  234.   T=HEAPTOP-term_units(N);
  235.   if(GLOTOP>=T) 
  236.   {
  237.       reclaim_heap(false);
  238.       if(GLOTOP >= (T=HEAPTOP-term_units(N))) 
  239.       ABORT(LOCALSPACEE);
  240.   }
  241.   HEAPTOP=T;
  242.   inc_term(T);
  243.   return T;
  244. }
  245.  
  246. GLOBAL void freeterms(REGISTER int N, REGISTER TERM T)
  247. { register int I;
  248.   register TERM X;
  249.   if(N==0) return;
  250.   /* if(N > MAXARITY || T==nil_term) SYSTEMERROR("freeterms"); */
  251.   for(I=N,X=T;--I>=0;next_br(X))
  252.     if(name(X)>FUNCNAME) 
  253.       freeterms(arity(name(X)),son(X));
  254.   name(T)=VART; son(T)=freelist[N]; freelist[N]=T;
  255. }
  256.  
  257. void reclaim_heap(boolean abort)
  258. /* reclaim heapnodes if possible */
  259. {
  260.     register TERM T,LASTT;
  261.     register int i;
  262.  
  263.   start:
  264.     for(i=1;i<=MAXARITY;++i)
  265.     if(LASTT= (T=freelist[i]))
  266.     {   
  267.         if(T== (HEAPTOP+term_units(1)))
  268.         {
  269.         HEAPTOP +=term_units(i);
  270.         /* sum +=i; */
  271.         if(T==LASTT) freelist[i]=son(T);
  272.         else son(LASTT)=son(T);
  273.         goto start;
  274.         }
  275.         LASTT=T; T=son(T);
  276.     }
  277.     if(abort && HEAPTOP <=GLOTOP)
  278.     ABORT(LOCALSPACEE);
  279. }
  280.  
  281. /**********************************************************
  282. *                                                         *
  283. *  STRINGS                                                *
  284. *                                                         *
  285. **********************************************************/
  286.  
  287. GLOBAL STRING heapstring(register string s)
  288. { register STRING P;
  289.   STRING Q;
  290.   Q=P=STRINGHTOP;
  291.   while(repchar(P++)= *s++);
  292.   if(P >=STRINGSTOP) ABORT(aSTRINGSPACEE);
  293.   STRINGHTOP=P;
  294.   return Q;
  295. }
  296.  
  297. GLOBAL STRING stackstring(register string s)
  298. { register STRING P;
  299.   register string ss;
  300.   ss=s; P= --STRINGSTOP; while(*ss++) P--;
  301.   nextatom(ATOMSTOP)=(card)(STRINGSTOP=P);
  302.   if(STRINGHTOP>=STRINGSTOP)ABORT(aSTRINGSPACEE); 
  303.   while(repchar(P++)= *s++);
  304.   return STRINGSTOP;
  305. }
  306.  
  307. /**********************************************************
  308. *                                                         *
  309. *  NUMBERS                                                *
  310. *                                                         *
  311. **********************************************************/
  312.  
  313. #if REALARITH
  314. LOCAL union{ REAL r; int ir[REALSIZE]; } ri;
  315. #endif
  316. #if LONGARITH
  317. LOCAL union{ LONG l; int il[LONGSIZE]; } li;
  318. #endif
  319.  
  320. #if REALARITH
  321. GLOBAL TERM mkreal(REAL R)
  322. { register TERM T;
  323.   register int I;
  324.   TERM TT; 
  325.   ri.r=R; 
  326.   T=TT=stackterms(REALSIZE);
  327.   for(I=0;I<REALSIZE;I++)
  328.    { name(T)=INTT ; ival(T)=ri.ir[I];next_br(T);} 
  329.   return mkfunc(REALT,TT);
  330. }
  331.  
  332. GLOBAL REAL realval(register TERM T)
  333. { register int I;
  334.   if(name(T)!=REALT) ARGERROR();
  335.   T=son(T);
  336.   for(I=0; I<REALSIZE; I++)
  337.     { if(name(T)!=INTT) ARGERROR();
  338.       ri.ir[I]=ival(T); next_br(T);
  339.     }
  340.   return ri.r;
  341. }
  342. #endif
  343.  
  344. #if LONGARITH
  345. GLOBAL TERM mklong(LONG L)
  346. { TERM T,TT; int I;
  347.   li.l=L; 
  348.   TT=T=stackterms(LONGSIZE);
  349. #if !MSC
  350.   for(I=0; I<LONGSIZE; I++) 
  351.    { name(T)=INTT ; ival(T)=li.il[I];next_br(T);}
  352. #endif
  353. #if MSC
  354. #if LONGSIZE !=2
  355.    Please change the following lines
  356. #endif
  357.    name(T)=INTT ; ival(T)=li.il[0] ; next_br(T); 
  358.    name(T)=INTT ; ival(T)=li.il[1] ;
  359. #endif
  360.   return mkfunc(LONGT,TT);
  361. }
  362.  
  363. GLOBAL LONG longval(register TERM T)
  364. { register int I;
  365.   if(name(T)!=LONGT) ARGERROR();
  366.   T=son(T);
  367. #if !MSC
  368.   for(I=0; I<LONGSIZE; I++)
  369.     { if(name(T)!=INTT) ARGERROR();
  370.       li.il[I]=ival(T); next_br(T);
  371.     }
  372. #endif
  373. #if MSC
  374. #if LONGSIZE !=2
  375.    Please change the following lines
  376. #endif
  377.     if(name(T) !=INTT) ARGERROR();
  378.     li.il[0]=ival(T); next_br(T);
  379.     if(name(T) !=INTT) ARGERROR();
  380.     li.il[0]=ival(T);
  381. #endif
  382.   return li.l;
  383. }
  384. #endif
  385. /**********************************************************
  386. *                                                         *
  387. *  STATISTICS                                             *
  388. *                                                         *
  389. **********************************************************/
  390.  
  391. LOCAL int PERCENT;
  392.  
  393. LOCAL void wtotal(register string S, register int MAX)
  394. { ws(S); wi(MAX); PERCENT=MAX/100; }
  395.  
  396. LOCAL void wpercent(register string S, register int N)
  397. { ws(S); wi(N);
  398.   ws(" ("); wi(N/PERCENT);ws("%)"); 
  399. }
  400.  
  401. #define helpunit=1
  402.  
  403. /* evaluable predicate stats */
  404. GLOBAL void DOSTATS (void)
  405. { int RN; TERM T; 
  406.   int I;
  407.   extern TRAIL TRAILEND,BASETRAIL;
  408.   ws("\nProlog Execution Statistics:\n");
  409.   RN=0;
  410.   for(I=0;I<=MAXARITY;I++)
  411.    { T=freelist[I]; while(non_nil_term(T)) { RN+=I; T=son(T); } }
  412.  
  413.   wtotal("\nNodes: ",MAX_TERMS);
  414.   wpercent(" Stack: ",(int)(GLOTOP-BASETERM)-1);
  415.   wpercent(" Heap: ",MAX_TERMS-(int)(HEAPTOP-BASETERM));
  416.   wpercent(" Released: ",RN);
  417.  
  418.   wtotal("\nAtoms: ",MAX_ATOMS);
  419.   wpercent(" Stack: ",MAX_ATOMS-(int)(ATOMSTOP/atom_units(1))-1);
  420.   wpercent(" Heap: ",(int)(ATOMHTOP/atom_units(1)));
  421.  
  422.   wtotal("\nStrings: ",MAX_STRINGS); 
  423.   wpercent(" Stack: ",MAX_STRINGS-(int)(STRINGSTOP-BASESTRING)-1);
  424.   wpercent(" Heap: ",(int)(STRINGHTOP-BASESTRING));
  425.  
  426.   wtotal("\nEnvironments: ",MAX_ENVS);
  427.   wpercent(" Used: ",(int)(ENVTOP/helpunit)-1);
  428.  
  429.   wtotal("\nTrail: ",MAX_TRAILER);
  430.   wpercent(" Used: ",(TRAILEND-BASETRAIL)/sizeof(int));
  431.  
  432.   ws("\n");
  433. }
  434.  
  435.