home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / LANGUAGS / XLISP / XLISP11.ARK / XLDMEM.C < prev    next >
Text File  |  1986-10-12  |  9KB  |  437 lines
  1. /* xldmem - xlisp dynamic memory management routines */
  2.  
  3. #ifdef AZTEC
  4. #include "a:stdio.h"
  5. #else
  6. #include <stdio.h>
  7. #endif
  8.  
  9. #include "xlisp.h"
  10.  
  11. /* useful definitions */
  12. #define ALLOCSIZE (sizeof(struct segment) + anodes * sizeof(struct node))
  13.  
  14. /* memory segment structure definition */
  15. struct segment {
  16.     int sg_size;
  17.     struct segment *sg_next;
  18.     struct node sg_nodes[];
  19. };
  20.  
  21. /* external variables */
  22. extern struct node *oblist;
  23. extern struct node *xlstack;
  24. extern struct node *xlenv;
  25.  
  26. /* external procedures */
  27. extern char *malloc();
  28. extern char *calloc();
  29.  
  30. /* local variables */
  31. int anodes,nnodes,nsegs,nfree,gccalls;
  32. static struct segment *segs;
  33. static struct node *fnodes;
  34.  
  35. /* newnode - allocate a new node */
  36. struct node *newnode(type)
  37.   int type;
  38. {
  39.     struct node *nnode;
  40.  
  41.     /* get a free node */
  42.     if ((nnode = fnodes) == NULL) {
  43.     gc();
  44.     if ((nnode = fnodes) == NULL)
  45.         xlfail("insufficient node space");
  46.     }
  47.  
  48.     /* unlink the node from the free list */
  49.     fnodes = nnode->n_right;
  50.     nfree -= 1;
  51.  
  52.     /* initialize the new node */
  53.     nnode->n_type = type;
  54.     nnode->n_left = NULL;
  55.     nnode->n_right = NULL;
  56.  
  57.     /* return the new node */
  58.     return (nnode);
  59. }
  60.  
  61. /* stralloc - allocate memory for a string adding a byte for the terminator */
  62. char *stralloc(size)
  63.   int size;
  64. {
  65.     char *sptr;
  66.  
  67.     /* allocate memory for the string copy */
  68.     if ((sptr = malloc(size+1)) == NULL) {
  69.     gc();
  70.     if ((sptr = malloc(size+1)) == NULL)
  71.         xlfail("insufficient string space");
  72.     }
  73.  
  74.     /* return the new string memory */
  75.     return (sptr);
  76. }
  77.  
  78. /* strsave - generate a dynamic copy of a string */
  79. char *strsave(str)
  80.   char *str;
  81. {
  82.     char *sptr;
  83.  
  84.     /* create a new string */
  85.     sptr = stralloc(strlen(str));
  86.     strcpy(sptr,str);
  87.  
  88.     /* return the new string */
  89.     return (sptr);
  90. }
  91.  
  92. /* strfree - free string memory */
  93. strfree(str)
  94.   char *str;
  95. {
  96.     free(str);
  97. }
  98.  
  99. /* gc - garbage collect */
  100. static gc()
  101. {
  102.     /* unmark all nodes */
  103.     unmark();
  104.  
  105.     /* mark all accessible nodes */
  106.     mark(oblist);
  107.     mark(xlstack);
  108.     mark(xlenv);
  109.  
  110.     /* sweep memory collecting all unmarked nodes */
  111.     sweep();
  112.  
  113.     /* if there's still nothing available, allocate more memory */
  114.     if (fnodes == NULL)
  115.     addseg();
  116.  
  117.     /* count the gc call */
  118.     gccalls += 1;
  119. }
  120.  
  121. /* unmark - unmark each node */
  122. static unmark()
  123. {
  124.     struct node *n;
  125.  
  126.     /* unmark the stack */
  127.     for (n = xlstack; n != NULL ; n = n->n_listnext)
  128.     n->n_flags &= ~(MARK | LEFT);
  129. }
  130.  
  131. /* mark - mark all accessible nodes */
  132. static mark(ptr)
  133.   struct node *ptr;
  134. {
  135.     struct node *this,*prev,*tmp;
  136.  
  137.     /* just return on null */
  138.     if (ptr == NULL)
  139.     return;
  140.  
  141.     /* initialize */
  142.     prev = NULL;
  143.     this = ptr;
  144.  
  145.     /* mark this list */
  146.     while (TRUE) {
  147.  
  148.     /* descend as far as we can */
  149.     while (TRUE) {
  150.  
  151.         /* check for this node being marked */
  152.         if (this->n_flags & MARK)
  153.         break;
  154.  
  155.         /* mark it and its descendants */
  156.         else {
  157.  
  158.         /* mark the node */
  159.         this->n_flags |= MARK;
  160.  
  161.         /* follow the left sublist if there is one */
  162.         if (left(this)) {
  163.             this->n_flags |= LEFT;
  164.             tmp = prev;
  165.             prev = this;
  166.             this = prev->n_left;
  167.             prev->n_left = tmp;
  168.         }
  169.         else if (right(this)) {
  170.             this->n_flags &= ~LEFT;
  171.             tmp = prev;
  172.             prev = this;
  173.             this = prev->n_right;
  174.             prev->n_right = tmp;
  175.         }
  176.         else
  177.             break;
  178.         }
  179.     }
  180.  
  181.     /* backup to a point where we can continue descending */
  182.     while (TRUE) {
  183.  
  184.         /* check for termination condition */
  185.         if (prev == NULL)
  186.         return;
  187.  
  188.         /* check for coming from the left side */
  189.         if (prev->n_flags & LEFT)
  190.         if (right(prev)) {
  191.             prev->n_flags &= ~LEFT;
  192.             tmp = prev->n_left;
  193.             prev->n_left = this;
  194.             this = prev->n_right;
  195.             prev->n_right = tmp;
  196.             break;
  197.         }
  198.         else {
  199.             tmp = prev;
  200.             prev = tmp->n_left;
  201.             tmp->n_left = this;
  202.             this = tmp;
  203.         }
  204.  
  205.         /* came from the right side */
  206.         else {
  207.         tmp = prev;
  208.         prev = tmp->n_right;
  209.         tmp->n_right = this;
  210.         this = tmp;
  211.         }
  212.     }
  213.     }
  214. }
  215.  
  216. /* sweep - sweep all unmarked nodes and add them to the free list */
  217. static sweep()
  218. {
  219.     struct segment *seg;
  220.     struct node *n;
  221.     int i;
  222.  
  223.     /* empty the free list */
  224.     fnodes = NULL;
  225.     nfree = 0;
  226.  
  227.     /* add all unmarked nodes */
  228.     for (seg = segs; seg != NULL; seg = seg->sg_next)
  229.     for (i = 0; i < seg->sg_size; i++)
  230.         if (!((n = &seg->sg_nodes[i])->n_flags & MARK)) {
  231.         switch (n->n_type) {
  232.         case STR:
  233.             if (n->n_strtype == DYNAMIC && n->n_str != NULL)
  234.                 strfree(n->n_str);
  235.             break;
  236.         case SYM:
  237.             if (n->n_symname != NULL)
  238.                 strfree(n->n_symname);
  239.             break;
  240. #ifdef KEYMAPCLASS
  241.         case KMAP:
  242.             xlkmfree(n);
  243.             break;
  244. #endif
  245.         }
  246.         n->n_type = FREE;
  247.         n->n_left = NULL;
  248.         n->n_right = fnodes;
  249.         fnodes = n;
  250.         nfree += 1;
  251.         }
  252.         else
  253.         n->n_flags &= ~MARK;
  254. }
  255.  
  256. /* addseg - add a segment to the available memory */
  257. static int addseg()
  258. {
  259.     struct segment *newseg;
  260.     int i;
  261.  
  262.     /* allocate a new segment */
  263.     if ((newseg = (struct segment *) calloc(1,ALLOCSIZE)) != NULL) {
  264.  
  265.     /* initialize the new segment */
  266.     newseg->sg_size = anodes;
  267.     newseg->sg_next = segs;
  268.     segs = newseg;
  269.  
  270.     /* add each new node to the free list */
  271.     for (i = 0; i < newseg->sg_size; i++) {
  272.         newseg->sg_nodes[i].n_right = fnodes;
  273.         fnodes = &newseg->sg_nodes[i];
  274.     }
  275.  
  276.     /* update the statistics */
  277.     nnodes += anodes;
  278.     nfree += anodes;
  279.     nsegs += 1;
  280.  
  281.     /* return successfully */
  282.     return (TRUE);
  283.     }
  284.     else
  285.     return (FALSE);
  286. }
  287.  
  288. /* left - check for a left sublist */
  289. static int left(n)
  290.   struct node *n;
  291. {
  292.     switch (n->n_type) {
  293.     case SYM:
  294.     case SUBR:
  295.     case INT:
  296.     case STR:
  297.     case FPTR:
  298.         return (FALSE);
  299. #ifdef KEYMAPCLASS
  300.     case KMAP:
  301.         xlkmmark(n);
  302.         return (FALSE);
  303. #endif
  304.     case LIST:
  305.     case OBJ:
  306.         return (n->n_left != NULL);
  307.     default:
  308.         printf("bad node type (%d) found during left scan\n",n->n_type);
  309.         exit();
  310.     }
  311. }
  312.  
  313. /* right - check for a right sublist */
  314. static int right(n)
  315.   struct node *n;
  316. {
  317.     switch (n->n_type) {
  318.     case SUBR:
  319.     case INT:
  320.     case STR:
  321.     case FPTR:
  322.     case KMAP:
  323.         return (FALSE);
  324.     case SYM:
  325.     case LIST:
  326.     case OBJ:
  327.         return (n->n_right != NULL);
  328.     default:
  329.         printf("bad node type (%d) found during right scan\n",n->n_type);
  330.         exit();
  331.     }
  332. }
  333.  
  334. /* stats - print memory statistics */
  335. static stats()
  336. {
  337.     putchar('\n');
  338.     printf("Nodes:       %d\n",nnodes);
  339.     printf("Free nodes:  %d\n",nfree);
  340.     printf("Segments:    %d\n",nsegs);
  341.     printf("Allocate:    %d\n",anodes);
  342.     printf("Collections: %d\n",gccalls);
  343.     putchar('\n');
  344. }
  345.  
  346. /* fgc - xlisp function to force garbage collection */
  347. static struct node *fgc(args)
  348.   struct node *args;
  349. {
  350.     /* make sure there aren't any arguments */
  351.     xllastarg(args);
  352.  
  353.     /* garbage collect */
  354.     gc();
  355.  
  356.     /* return null */
  357.     return (NULL);
  358. }
  359.  
  360. /* fexpand - xlisp function to force memory expansion */
  361. static struct node *fexpand(args)
  362.   struct node *args;
  363. {
  364.     struct node *val;
  365.     int n,i;
  366.  
  367.     /* get the new number to allocate */
  368.     if (args == NULL)
  369.     n = 1;
  370.     else
  371.     n = xlevmatch(INT,&args)->n_int;
  372.  
  373.     /* make sure there aren't any more arguments */
  374.     xllastarg(args);
  375.  
  376.     /* allocate more segments */
  377.     for (i = 0; i < n; i++)
  378.     if (!addseg())
  379.         break;
  380.  
  381.     /* return the number of segments added */
  382.     val = newnode(INT);
  383.     val->n_int = i;
  384.     return (val);
  385. }
  386.  
  387. /* falloc - xlisp function to set the number of nodes to allocate */
  388. static struct node *falloc(args)
  389.   struct node *args;
  390. {
  391.     struct node *val;
  392.     int n,oldn;
  393.  
  394.     /* get the new number to allocate */
  395.     n = xlevmatch(INT,&args)->n_int;
  396.  
  397.     /* make sure there aren't any more arguments */
  398.     xllastarg(args);
  399.  
  400.     /* set the new number of nodes to allocate */
  401.     oldn = anodes;
  402.     anodes = n;
  403.  
  404.     /* return the old number */
  405.     val = newnode(INT);
  406.     val->n_int = oldn;
  407.     return (val);
  408. }
  409.  
  410. /* fmem - xlisp function to print memory statistics */
  411. static struct node *fmem(args)
  412.   struct node *args;
  413. {
  414.     /* make sure there aren't any arguments */
  415.     xllastarg(args);
  416.  
  417.     /* print the statistics */
  418.     stats();
  419.  
  420.     /* return null */
  421.     return (NULL);
  422. }
  423.  
  424. /* xldmeminit - initialize the dynamic memory module */
  425. xldmeminit()
  426. {
  427.     /* setup the default number of nodes to allocate */
  428.     anodes = NNODES;
  429.     nnodes = nsegs = nfree = gccalls = 0;
  430.  
  431.     /* define some xlisp functions */
  432.     xlsubr("gc",fgc);
  433.     xlsubr("expand",fexpand);
  434.     xlsubr("alloc",falloc);
  435.     xlsubr("mem",fmem);
  436. }
  437.