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