home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 22 gnu / 22-gnu.zip / gwm18a.zip / wl_coll.c < prev    next >
C/C++ Source or Header  |  1995-07-03  |  5KB  |  240 lines
  1. /* Copyright 1989 GROUPE BULL -- See license conditions in file COPYRIGHT
  2.  * Copyright 1989 Massachusetts Institute of Technology
  3.  */
  4. /**************************\
  5. *                *
  6. *  WOOL_OBJECT Collection  *
  7. *  BODY               *
  8. *                *
  9. \**************************/
  10.  
  11. #include "EXTERN.h"
  12. #include <stdio.h>
  13. #include "wool.h"
  14. #include "wl_number.h"
  15. #include "wl_atom.h"
  16. #include "wl_list.h"
  17. #include "INTERN.h"
  18. #include "wl_coll.h"
  19.  
  20. WOOL_OBJECT WLCollection_release();
  21.  
  22. /*
  23.  * wlcf (wool collection free)
  24.  * 
  25.  * management of an stack of free collections to avoid calls to malloc
  26.  */
  27.  
  28. #define WLCF_LIMIT 32
  29. #if WLCF_LIMIT
  30. static WOOL_Collection wlcf[WLCF_LIMIT];
  31. #else
  32. static WOOL_Collection wlcf[1];
  33. #endif
  34. static WOOL_Collection  *wlcf_last = wlcf;
  35. static int    wlcf_size, wlcf_limit = WLCF_LIMIT;
  36.  
  37. /* to be called once */
  38.  
  39. #ifdef STATS
  40. WOOL_OBJECT
  41. wlcfstats()
  42. {
  43.     wool_printf("wool-coll-free (wlcf)  has %d", wlcf_size);
  44.     wool_printf("/%d slots\n", wlcf_limit);
  45.     return NIL;
  46. }
  47. #endif /* STATS */
  48.  
  49. /* to release wlcf  */
  50.  
  51. wlcf_flush()
  52. {
  53.     WOOL_Collection *p = wlcf_last - 1;
  54.  
  55.     while (p >= wlcf) {
  56.     WLCollection_release(*p);
  57.         p--;
  58.     }
  59.     wlcf_size = 0;
  60.     wlcf_last = wlcf;
  61. }
  62.  
  63. /* put in wlcf */
  64.  
  65. WOOL_OBJECT 
  66. WLCollection_free(col)
  67. WOOL_Collection col;
  68. {
  69.     if (wlcf_size >= wlcf_limit) {
  70.     WLCollection_release(col);
  71.     } else {
  72.     wlcf_size++;
  73.     *wlcf_last++ = col;
  74.     col -> size = 0;
  75.     }
  76.     return NULL;
  77. }
  78.  
  79. /*
  80.  * Constructor:
  81.  * WLCollection_make
  82.  * do a wlcf_get in fact...
  83.  */
  84.  
  85. WOOL_Collection 
  86. WLCollection_make()
  87. {
  88.     WOOL_Collection col;
  89.  
  90.     if (wlcf_size) {
  91.     col = *(--wlcf_last);
  92.     wlcf_size--;
  93.     zrt_put(col);
  94.     } else {
  95.     col = (WOOL_Collection)
  96.         Malloc(sizeof(struct _WOOL_Collection));
  97.     zrt_put(col);
  98.     col -> type = WLCollection;
  99.     col -> size = 0;
  100.     col -> limit = INITIAL_COLLECTION_SIZE;
  101.     col -> list = (WOOL_OBJECT *) Malloc(col -> limit << 2);
  102.     }
  103.     return col;
  104. }
  105.  
  106. /* 
  107.  * WLCollection_print:
  108.  * Normally, never to be called.
  109.  */
  110.  
  111. WOOL_OBJECT 
  112. WLCollection_print(obj)
  113. WOOL_Collection obj;
  114. {
  115.     int             i;
  116.     WOOL_OBJECT    *p = obj -> list;
  117.  
  118.     wool_puts("{COLLECTION ");
  119.     for (i = 0; i < obj -> size; i++, p++) {
  120.     if (i)
  121.         wool_putchar(' ');
  122.     WOOL_send(WOOL_print, *p, (*p));
  123.     }
  124.     wool_putchar('}');
  125.     return (WOOL_OBJECT) obj;
  126. }
  127.  
  128. /*
  129.  * WLCollection_free
  130.  */
  131.  
  132. WOOL_OBJECT 
  133. WLCollection_release(col)
  134. WOOL_Collection col;
  135. {
  136.     Free(col -> list);
  137.     Free(col);
  138.     return NULL;
  139. }
  140.  
  141. /*
  142.  * trying to execute an collection is the same error than executing an atom.
  143.  */
  144.  
  145. /*
  146.  * WLCollection_add:
  147.  * Adds arg2 to arg1, just catenating if there is room, increasing limit
  148.  * of collection if not.
  149.  * (we know we have 4 bytes of overhead, thats the reason for our
  150.  * growing scheme: * 2 +4)
  151.  * WARNING: since a zrt_gc cannot occur during parsing, we do not set
  152.  * the reference count on the sons!
  153.  */
  154.  
  155. WOOL_Collection 
  156. WLCollection_add(col, obj)
  157. WOOL_Collection col;
  158. WOOL_OBJECT     obj;
  159. {
  160.     if (col -> size >= col -> limit) {
  161.     WOOL_OBJECT *oldlist = col -> list;
  162.  
  163.     col -> limit = col -> limit << 1 + 1;
  164.     col -> list = (WOOL_OBJECT *) Malloc((col -> limit) << 2);
  165.     bcopy(oldlist, col -> list, col -> size << 2);
  166.     Free(oldlist);
  167.     }
  168.     *(col -> list + (col -> size)++) = obj;
  169.     return col;
  170. }
  171.  
  172. /* makes a (progn <list>) of a collection
  173.  */
  174.  
  175. WOOL_OBJECT
  176. WLCollection_progn(col)
  177. WOOL_Collection col;
  178. {
  179.     if (col -> size) {
  180.     WOOL_List       object = wool_list_make(col->size +1);
  181.  
  182.     copy_n_objects(col -> list, object -> list + 1, col -> size);
  183.     increase_reference(object -> list[0] = WA_progn);
  184.     return (WOOL_OBJECT) object;
  185.     } else {                /* a list of size 0 is just NIL */
  186.     return NIL;
  187.     }
  188. }
  189.  
  190. /*******************************************************\
  191. *                                 *
  192. * QuotedExpr package for speeding up quoted constructs  *
  193. *                                 *
  194. \*******************************************************/
  195.  
  196. WOOL_QuotedExpr
  197. WLQuotedExpr_make(expr)
  198. WOOL_OBJECT    expr;
  199. {
  200.     WOOL_QuotedExpr object = (WOOL_QuotedExpr)
  201.     Malloc(sizeof(struct _WOOL_QuotedExpr));
  202.  
  203.     zrt_put(object);
  204.     object -> type = WLQuotedExpr;
  205.     increase_reference(object -> expr = expr);
  206.     return (WOOL_QuotedExpr) object;
  207. }
  208.  
  209. WOOL_OBJECT
  210. WLQuotedExpr_eval(obj)
  211. WOOL_QuotedExpr obj;
  212. {
  213.     return (WOOL_OBJECT) obj -> expr;
  214. }
  215.  
  216. WOOL_OBJECT
  217. WLQuotedExpr_print(obj)
  218. WOOL_QuotedExpr obj;
  219. {
  220.     wool_putchar('\'');
  221.     WOOL_send(WOOL_print, obj -> expr, (obj -> expr));
  222.     return (WOOL_OBJECT) obj;
  223. }
  224.  
  225. WOOL_OBJECT
  226. WLQuotedExpr_free(obj)
  227. WOOL_QuotedExpr obj;
  228. {
  229.     decrease_reference(obj -> expr);
  230.     Free(obj);
  231.     return NULL;
  232. }
  233.  
  234. WOOL_OBJECT
  235. WLQuotedExpr_equal(o1, o2)
  236. WOOL_QuotedExpr o1, o2;
  237. {
  238.     return WOOL_send(WOOL_equal, o1 -> expr, (o1 -> expr, o2 -> expr));
  239. }
  240.