home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / unix / volume6 / xlisp1.6 / part1 / xldmem.c < prev    next >
Encoding:
C/C++ Source or Header  |  1986-11-30  |  11.0 KB  |  569 lines
  1. /* xldmem - xlisp dynamic memory management routines */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* useful definitions */
  9. #define ALLOCSIZE (sizeof(struct segment) + (anodes-1) * sizeof(NODE))
  10.  
  11. /* external variables */
  12. extern NODE ***xlstack,***xlstkbase,***xlstktop;
  13. extern NODE *obarray;
  14. extern NODE *xlenv;
  15. extern long total;
  16. extern int anodes,nnodes,nsegs,nfree,gccalls;
  17. extern struct segment *segs;
  18. extern NODE *fnodes;
  19. extern char buf[];
  20.  
  21. /* external procedures */
  22. extern char *malloc();
  23. extern char *calloc();
  24.  
  25. /* forward declarations */
  26. FORWARD NODE *newnode();
  27. FORWARD char *strsave();
  28. FORWARD char *stralloc();
  29.  
  30. /* cons - construct a new cons node */
  31. NODE *cons(x,y)
  32.   NODE *x,*y;
  33. {
  34.     NODE *val;
  35.     val = newnode(LIST);
  36.     rplaca(val,x);
  37.     rplacd(val,y);
  38.     return (val);
  39. }
  40.  
  41. /* consa - (cons x nil) */
  42. NODE *consa(x)
  43.   NODE *x;
  44. {
  45.     NODE *val;
  46.     val = newnode(LIST);
  47.     rplaca(val,x);
  48.     return (val);
  49. }
  50.  
  51. /* consd - (cons nil x) */
  52. NODE *consd(x)
  53.   NODE *x;
  54. {
  55.     NODE *val;
  56.     val = newnode(LIST);
  57.     rplacd(val,x);
  58.     return (val);
  59. }
  60.  
  61. /* cvstring - convert a string to a string node */
  62. NODE *cvstring(str)
  63.   char *str;
  64. {
  65.     NODE ***oldstk,*val;
  66.     oldstk = xlsave(&val,(NODE **)NULL);
  67.     val = newnode(STR);
  68.     val->n_str = strsave(str);
  69.     val->n_strtype = DYNAMIC;
  70.     xlstack = oldstk;
  71.     return (val);
  72. }
  73.  
  74. /* cvcstring - convert a constant string to a string node */
  75. NODE *cvcstring(str)
  76.   char *str;
  77. {
  78.     NODE *val;
  79.     val = newnode(STR);
  80.     val->n_str = str;
  81.     val->n_strtype = STATIC;
  82.     return (val);
  83. }
  84.  
  85. /* cvsymbol - convert a string to a symbol */
  86. NODE *cvsymbol(pname)
  87.   char *pname;
  88. {
  89.     NODE ***oldstk,*val;
  90.     oldstk = xlsave(&val,(NODE **)NULL);
  91.     val = newnode(SYM);
  92.     val->n_symplist = newnode(LIST);
  93.     rplaca(val->n_symplist,cvstring(pname));
  94.     xlstack = oldstk;
  95.     return (val);
  96. }
  97.  
  98. /* cvcsymbol - convert a constant string to a symbol */
  99. NODE *cvcsymbol(pname)
  100.   char *pname;
  101. {
  102.     NODE ***oldstk,*val;
  103.     oldstk = xlsave(&val,(NODE **)NULL);
  104.     val = newnode(SYM);
  105.     val->n_symplist = newnode(LIST);
  106.     rplaca(val->n_symplist,cvcstring(pname));
  107.     xlstack = oldstk;
  108.     return (val);
  109. }
  110.  
  111. /* cvsubr - convert a function to a subr or fsubr */
  112. NODE *cvsubr(fcn,type)
  113.   NODE *(*fcn)(); int type;
  114. {
  115.     NODE *val;
  116.     val = newnode(type);
  117.     val->n_subr = fcn;
  118.     return (val);
  119. }
  120.  
  121. /* cvfile - convert a file pointer to a file */
  122. NODE *cvfile(fp)
  123.   FILE *fp;
  124. {
  125.     NODE *val;
  126.     val = newnode(FPTR);
  127.     setfile(val,fp);
  128.     setsavech(val,0);
  129.     return (val);
  130. }
  131.  
  132. /* cvfixnum - convert an integer to a fixnum node */
  133. NODE *cvfixnum(n)
  134.   FIXNUM n;
  135. {
  136.     NODE *val;
  137.     val = newnode(INT);
  138.     val->n_int = n;
  139.     return (val);
  140. }
  141.  
  142. /* cvflonum - convert a floating point number to a flonum node */
  143. NODE *cvflonum(n)
  144.   FLONUM n;
  145. {
  146.     NODE *val;
  147.     val = newnode(FLOAT);
  148.     val->n_float = n;
  149.     return (val);
  150. }
  151.  
  152. /* newstring - allocate and initialize a new string */
  153. NODE *newstring(size)
  154.   int size;
  155. {
  156.     NODE ***oldstk,*val;
  157.     oldstk = xlsave(&val,(NODE **)NULL);
  158.     val = newnode(STR);
  159.     val->n_str = stralloc(size);
  160.     *getstring(val) = 0;
  161.     val->n_strtype = DYNAMIC;
  162.     xlstack = oldstk;
  163.     return (val);
  164. }
  165.  
  166. /* newobject - allocate and initialize a new object */
  167. NODE *newobject(cls,size)
  168.   NODE *cls; int size;
  169. {
  170.     NODE *val;
  171.     val = newvector(size+1);
  172.     setelement(val,0,cls);
  173.     val->n_type = OBJ;
  174.     return (val);
  175. }
  176.  
  177. /* newvector - allocate and initialize a new vector node */
  178. NODE *newvector(size)
  179.   int size;
  180. {
  181.     NODE ***oldstk,*vect;
  182.     int bsize;
  183.  
  184.     /* establish a new stack frame */
  185.     oldstk = xlsave(&vect,(NODE **)NULL);
  186.  
  187.     /* allocate a vector node and set the size to zero (in case of gc) */
  188.     vect = newnode(VECT);
  189.     vect->n_vsize = 0;
  190.  
  191.     /* allocate memory for the vector */
  192.     bsize = size * sizeof(NODE *);
  193.     if ((vect->n_vdata = (NODE **) calloc(1,bsize)) == NULL) {
  194.     findmem();
  195.     if ((vect->n_vdata = (NODE **) calloc(1,bsize)) == NULL)
  196.         xlfail("insufficient vector space");
  197.     }
  198.     vect->n_vsize = size;
  199.     total += (long) bsize;
  200.  
  201.     /* restore the previous stack frame */
  202.     xlstack = oldstk;
  203.  
  204.     /* return the new vector */
  205.     return (vect);
  206. }
  207.  
  208. /* newnode - allocate a new node */
  209. LOCAL NODE *newnode(type)
  210.   int type;
  211. {
  212.     NODE *nnode;
  213.  
  214.     /* get a free node */
  215.     if ((nnode = fnodes) == NIL) {
  216.     findmem();
  217.     if ((nnode = fnodes) == NIL)
  218.         xlabort("insufficient node space");
  219.     }
  220.  
  221.     /* unlink the node from the free list */
  222.     fnodes = cdr(nnode);
  223.     nfree -= 1;
  224.  
  225.     /* initialize the new node */
  226.     nnode->n_type = type;
  227.     rplacd(nnode,NIL);
  228.  
  229.     /* return the new node */
  230.     return (nnode);
  231. }
  232.  
  233. /* stralloc - allocate memory for a string adding a byte for the terminator */
  234. LOCAL char *stralloc(size)
  235.   int size;
  236. {
  237.     char *sptr;
  238.  
  239.     /* allocate memory for the string copy */
  240.     if ((sptr = malloc(size+1)) == NULL) {
  241.     findmem();  
  242.     if ((sptr = malloc(size+1)) == NULL)
  243.         xlfail("insufficient string space");
  244.     }
  245.     total += (long) (size+1);
  246.  
  247.     /* return the new string memory */
  248.     return (sptr);
  249. }
  250.  
  251. /* strsave - generate a dynamic copy of a string */
  252. LOCAL char *strsave(str)
  253.   char *str;
  254. {
  255.     char *sptr;
  256.  
  257.     /* create a new string */
  258.     sptr = stralloc(strlen(str));
  259.     strcpy(sptr,str);
  260.  
  261.     /* return the new string */
  262.     return (sptr);
  263. }
  264.  
  265. /* strfree - free a string                 UNUSED
  266. LOCAL strfree(str)
  267.   char *str;
  268. {
  269.     total -= (long) (strlen(str)+1);
  270.     free(str);
  271. }
  272. */
  273.  
  274. /* findmem - find more memory by collecting then expanding */
  275. findmem()
  276. {
  277.     gc();
  278.     if (nfree < anodes)
  279.     addseg();
  280. }
  281.  
  282. /* gc - garbage collect */
  283. gc()
  284. {
  285.     NODE ***p;
  286.     void mark();
  287.  
  288.     /* mark the obarray and the current environment */
  289.     mark(obarray);
  290.     mark(xlenv);
  291.  
  292.     /* mark the evaluation stack */
  293.     for (p = xlstack; p < xlstktop; )
  294.     mark(**p++);
  295.  
  296.     /* sweep memory collecting all unmarked nodes */
  297.     sweep();
  298.  
  299.     /* count the gc call */
  300.     gccalls++;
  301. }
  302.  
  303. /* mark - mark all accessible nodes */
  304. void mark(ptr)
  305.   NODE *ptr;
  306. {
  307.     NODE *this,*prev,*tmp;
  308.  
  309.     /* just return on nil */
  310.     if (ptr == NIL)
  311.     return;
  312.  
  313.     /* initialize */
  314.     prev = NIL;
  315.     this = ptr;
  316.  
  317.     /* mark this list */
  318.     while (TRUE) {
  319.  
  320.     /* descend as far as we can */
  321.     while (TRUE) {
  322.  
  323.         /* check for this node being marked */
  324.         if (this->n_flags & MARK)
  325.         break;
  326.  
  327.         /* mark it and its descendants */
  328.         else {
  329.  
  330.         /* mark the node */
  331.         this->n_flags |= MARK;
  332.  
  333.         /* follow the left sublist if there is one */
  334.         if (livecar(this)) {
  335.             this->n_flags |= LEFT;
  336.             tmp = prev;
  337.             prev = this;
  338.             this = car(prev);
  339.             rplaca(prev,tmp);
  340.         }
  341.  
  342.         /* otherwise, follow the right sublist if there is one */
  343.         else if (livecdr(this)) {
  344.             this->n_flags &= ~LEFT;
  345.             tmp = prev;
  346.             prev = this;
  347.             this = cdr(prev);
  348.             rplacd(prev,tmp);
  349.         }
  350.         else
  351.             break;
  352.         }
  353.     }
  354.  
  355.     /* backup to a point where we can continue descending */
  356.     while (TRUE) {
  357.  
  358.         /* check for termination condition */
  359.         if (prev == NIL)
  360.         return;
  361.  
  362.         /* check for coming from the left side */
  363.         if (prev->n_flags & LEFT)
  364.         if (livecdr(prev)) {
  365.             prev->n_flags &= ~LEFT;
  366.             tmp = car(prev);
  367.             rplaca(prev,this);
  368.             this = cdr(prev);
  369.             rplacd(prev,tmp);
  370.             break;
  371.         }
  372.         else {
  373.             tmp = prev;
  374.             prev = car(tmp);
  375.             rplaca(tmp,this);
  376.             this = tmp;
  377.         }
  378.  
  379.         /* otherwise, came from the right side */
  380.         else {
  381.         tmp = prev;
  382.         prev = cdr(tmp);
  383.         rplacd(tmp,this);
  384.         this = tmp;
  385.         }
  386.     }
  387.     }
  388. }
  389.  
  390. /* vmark - mark a vector */
  391. vmark(n)
  392.   NODE *n;
  393. {
  394.     int i;
  395.     for (i = 0; i < getsize(n); ++i)
  396.     mark(getelement(n,i));
  397. }
  398.  
  399. /* sweep - sweep all unmarked nodes and add them to the free list */
  400. LOCAL sweep()
  401. {
  402.     struct segment *seg;
  403.     NODE *p;
  404.     int n;
  405.  
  406.     /* empty the free list */
  407.     fnodes = NIL;
  408.     nfree = 0;
  409.  
  410.     /* add all unmarked nodes */
  411.     for (seg = segs; seg != NULL; seg = seg->sg_next) {
  412.     p = &seg->sg_nodes[0];
  413.     for (n = seg->sg_size; n--; p++)
  414.         if (!(p->n_flags & MARK)) {
  415.         switch (ntype(p)) {
  416.         case STR:
  417.             if (p->n_strtype == DYNAMIC && p->n_str != NULL) {
  418.                 total -= (long) (strlen(p->n_str)+1);
  419.                 free(p->n_str);
  420.             }
  421.             break;
  422.         case FPTR:
  423.             if (p->n_fp)
  424.                 fclose(p->n_fp);
  425.             break;
  426.         case VECT:
  427.             if (p->n_vsize) {
  428.                 total -= (long) (p->n_vsize * sizeof(NODE **));
  429.                 free(p->n_vdata);
  430.             }
  431.             break;
  432.         }
  433.         p->n_type = FREE;
  434.         p->n_flags = 0;
  435.         rplaca(p,NIL);
  436.         rplacd(p,fnodes);
  437.         fnodes = p;
  438.         nfree++;
  439.         }
  440.         else
  441.         p->n_flags &= ~(MARK | LEFT);
  442.     }
  443. }
  444.  
  445. /* addseg - add a segment to the available memory */
  446. int addseg()
  447. {
  448.     struct segment *newseg;
  449.     NODE *p;
  450.     int n;
  451.  
  452.     /* check for zero allocation */
  453.     if (anodes == 0)
  454.     return (FALSE);
  455.  
  456.     /* allocate a new segment */
  457.     if ((newseg = (struct segment *) calloc(1,ALLOCSIZE)) != NULL) {
  458.  
  459.     /* initialize the new segment */
  460.     newseg->sg_size = anodes;
  461.     newseg->sg_next = segs;
  462.     segs = newseg;
  463.  
  464.     /* add each new node to the free list */
  465.     p = &newseg->sg_nodes[0];
  466.     for (n = anodes; n--; ) {
  467.         rplacd(p,fnodes);
  468.         fnodes = p++;
  469.     }
  470.  
  471.     /* update the statistics */
  472.     total += (long) ALLOCSIZE;
  473.     nnodes += anodes;
  474.     nfree += anodes;
  475.     nsegs++;
  476.  
  477.     /* return successfully */
  478.     return (TRUE);
  479.     }
  480.     else
  481.     return (FALSE);
  482. }
  483.  
  484. /* livecar - do we need to follow the car? */
  485. LOCAL int livecar(n)
  486.   NODE *n;
  487. {
  488.     switch (ntype(n)) {
  489.     case OBJ:
  490.     case VECT:
  491.         vmark(n);
  492.     case SUBR:
  493.     case FSUBR:
  494.     case INT:
  495.     case FLOAT:
  496.     case STR:
  497.     case FPTR:
  498.         return (FALSE);
  499.     case SYM:
  500.     case LIST:
  501.         return (car(n) != NIL);
  502.     default:
  503.         printf("bad node type (%d) found during left scan\n",ntype(n));
  504.         osfinish ();
  505.         exit(1);
  506.     }
  507.     /*NOTREACHED*/
  508. }
  509.  
  510. /* livecdr - do we need to follow the cdr? */
  511. LOCAL int livecdr(n)
  512.   NODE *n;
  513. {
  514.     switch (ntype(n)) {
  515.     case SUBR:
  516.     case FSUBR:
  517.     case INT:
  518.     case FLOAT:
  519.     case STR:
  520.     case FPTR:
  521.     case OBJ:
  522.     case VECT:
  523.         return (FALSE);
  524.     case SYM:
  525.     case LIST:
  526.         return (cdr(n) != NIL);
  527.     default:
  528.         printf("bad node type (%d) found during right scan\n",ntype(n));
  529.         osfinish ();
  530.         exit(1);
  531.     }
  532.     /*NOTREACHED*/
  533. }
  534.  
  535. /* stats - print memory statistics */
  536. stats()
  537. {
  538.     sprintf(buf,"Nodes:       %d\n",nnodes);  stdputstr(buf);
  539.     sprintf(buf,"Free nodes:  %d\n",nfree);   stdputstr(buf);
  540.     sprintf(buf,"Segments:    %d\n",nsegs);   stdputstr(buf);
  541.     sprintf(buf,"Allocate:    %d\n",anodes);  stdputstr(buf);
  542.     sprintf(buf,"Total:       %ld\n",total);  stdputstr(buf);
  543.     sprintf(buf,"Collections: %d\n",gccalls); stdputstr(buf);
  544. }
  545.  
  546. /* xlminit - initialize the dynamic memory module */
  547. xlminit()
  548. {
  549.     /* initialize our internal variables */
  550.     anodes = NNODES;
  551.     total = 0L;
  552.     nnodes = nsegs = nfree = gccalls = 0;
  553.     fnodes = NIL;
  554.     segs = NULL;
  555.  
  556.     /* initialize structures that are marked by the collector */
  557.     xlenv = obarray = NIL;
  558.  
  559.     /* allocate the evaluation stack */
  560.     if ((xlstkbase = (NODE ***)malloc(EDEPTH * sizeof(NODE **))) == NULL) {
  561.     printf("insufficient memory");
  562.     osfinish ();
  563.     exit(1);
  564.     }
  565.     total += (long)(EDEPTH * sizeof(NODE **));
  566.     xlstack = xlstktop = xlstkbase + EDEPTH;
  567. }
  568.  
  569.