home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / 32XLISP.ZIP / XLDMEM.C < prev    next >
Text File  |  1991-04-30  |  15KB  |  695 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. /* node flags */
  9. #define MARK    1
  10. #define LEFT    2
  11.  
  12. /* macro to compute the size of a segment */
  13. #define segsize(n) (sizeof(SEGMENT)+((n)-1)*sizeof(struct node))
  14.  
  15. /* external variables */
  16. extern LVAL obarray,s_gcflag,s_gchook,s_unbound,true;
  17. extern LVAL xlenv,xlfenv,xldenv;
  18. extern char buf[];
  19.  
  20. /* variables local to xldmem.c and xlimage.c */
  21. SEGMENT *segs,*lastseg,*fixseg,*charseg;
  22. int anodes,nsegs,gccalls;
  23. long nnodes,nfree,total;
  24. LVAL fnodes;
  25.  
  26. /* external procedures */
  27. extern char *malloc();
  28. extern char *calloc();
  29.  
  30. /* forward declarations */
  31. FORWARD LVAL newnode();
  32. FORWARD unsigned char *stralloc();
  33. FORWARD SEGMENT *newsegment();
  34.  
  35. /* cons - construct a new cons node */
  36. LVAL cons(x,y)
  37.   LVAL x,y;
  38. {
  39.     LVAL nnode;
  40.  
  41.     /* get a free node */
  42.     if ((nnode = fnodes) == NIL) {
  43.     xlstkcheck(2);
  44.     xlprotect(x);
  45.     xlprotect(y);
  46.     findmem();
  47.     if ((nnode = fnodes) == NIL)
  48.         xlabort("insufficient node space");
  49.     xlpop();
  50.     xlpop();
  51.     }
  52.  
  53.     /* unlink the node from the free list */
  54.     fnodes = cdr(nnode);
  55.     --nfree;
  56.  
  57.     /* initialize the new node */
  58.     nnode->n_type = CONS;
  59.     rplaca(nnode,x);
  60.     rplacd(nnode,y);
  61.  
  62.     /* return the new node */
  63.     return (nnode);
  64. }
  65.  
  66. /* cvstring - convert a string to a string node */
  67. LVAL cvstring(str)
  68.   char *str;
  69. {
  70.     LVAL val;
  71.     xlsave1(val);
  72.     val = newnode(STRING);
  73.     val->n_strlen = strlen(str) + 1;
  74.     val->n_string = stralloc(getslength(val));
  75.     strcpy(getstring(val),str);
  76.     xlpop();
  77.     return (val);
  78. }
  79.  
  80. /* newstring - allocate and initialize a new string */
  81. LVAL newstring(size)
  82.   int size;
  83. {
  84.     LVAL val;
  85.     xlsave1(val);
  86.     val = newnode(STRING);
  87.     val->n_strlen = size;
  88.     val->n_string = stralloc(getslength(val));
  89.     strcpy(getstring(val),"");
  90.     xlpop();
  91.     return (val);
  92. }
  93.  
  94. /* cvsymbol - convert a string to a symbol */
  95. LVAL cvsymbol(pname)
  96.   char *pname;
  97. {
  98.     LVAL val;
  99.     xlsave1(val);
  100.     val = newvector(SYMSIZE);
  101.     val->n_type = SYMBOL;
  102.     setvalue(val,s_unbound);
  103.     setfunction(val,s_unbound);
  104.     setpname(val,cvstring(pname));
  105.     xlpop();
  106.     return (val);
  107. }
  108.  
  109. /* cvsubr - convert a function to a subr or fsubr */
  110. LVAL cvsubr(fcn,type,offset)
  111.   LVAL (*fcn)(); int type,offset;
  112. {
  113.     LVAL val;
  114.     val = newnode(type);
  115.     val->n_subr = fcn;
  116.     val->n_offset = offset;
  117.     return (val);
  118. }
  119.  
  120. /* cvfile - convert a file pointer to a stream */
  121. LVAL cvfile(fp)
  122.   FILE *fp;
  123. {
  124.     LVAL val;
  125.     val = newnode(STREAM);
  126.     setfile(val,fp);
  127.     setsavech(val,'\0');
  128.     return (val);
  129. }
  130.  
  131. /* cvfixnum - convert an integer to a fixnum node */
  132. LVAL cvfixnum(n)
  133.   FIXTYPE n;
  134. {
  135.     LVAL val;
  136.     if (n >= SFIXMIN && n <= SFIXMAX)
  137.     return (&fixseg->sg_nodes[(int)n-SFIXMIN]);
  138.     val = newnode(FIXNUM);
  139.     val->n_fixnum = n;
  140.     return (val);
  141. }
  142.  
  143. /* cvflonum - convert a floating point number to a flonum node */
  144. LVAL cvflonum(n)
  145.   FLOTYPE n;
  146. {
  147.     LVAL val;
  148.     val = newnode(FLONUM);
  149.     val->n_flonum = n;
  150.     return (val);
  151. }
  152.  
  153. /* cvchar - convert an integer to a character node */
  154. LVAL cvchar(n)
  155.   int n;
  156. {
  157.     if (n >= CHARMIN && n <= CHARMAX)
  158.     return (&charseg->sg_nodes[n-CHARMIN]);
  159.     xlerror("character code out of range",cvfixnum((FIXTYPE)n));
  160. }
  161.  
  162. /* newustream - create a new unnamed stream */
  163. LVAL newustream()
  164. {
  165.     LVAL val;
  166.     val = newnode(USTREAM);
  167.     sethead(val,NIL);
  168.     settail(val,NIL);
  169.     return (val);
  170. }
  171.  
  172. /* newobject - allocate and initialize a new object */
  173. LVAL newobject(cls,size)
  174.   LVAL cls; int size;
  175. {
  176.     LVAL val;
  177.     val = newvector(size+1);
  178.     val->n_type = OBJECT;
  179.     setelement(val,0,cls);
  180.     return (val);
  181. }
  182.  
  183. /* newclosure - allocate and initialize a new closure */
  184. LVAL newclosure(name,type,env,fenv)
  185.   LVAL name,type,env,fenv;
  186. {
  187.     LVAL val;
  188.     val = newvector(CLOSIZE);
  189.     val->n_type = CLOSURE;
  190.     setname(val,name);
  191.     settype(val,type);
  192.     setenv(val,env);
  193.     setfenv(val,fenv);
  194.     return (val);
  195. }
  196.  
  197. /* newstruct - allocate and initialize a new structure node */
  198. LVAL newstruct(type,size)
  199.   LVAL type; int size;
  200. {
  201.     LVAL val;
  202.     val = newvector(size+1);
  203.     val->n_type = STRUCT;
  204.     setelement(val,0,type);
  205.     return (val);
  206. }
  207.  
  208. /* newvector - allocate and initialize a new vector node */
  209. LVAL newvector(size)
  210.   int size;
  211. {
  212.     LVAL vect;
  213.     int bsize;
  214.     xlsave1(vect);
  215.     vect = newnode(VECTOR);
  216.     vect->n_vsize = 0;
  217.     if (bsize = size * sizeof(LVAL)) {
  218.     if ((vect->n_vdata = (LVAL *)calloc(1,bsize)) == NULL) {
  219.         findmem();
  220.         if ((vect->n_vdata = (LVAL *)calloc(1,bsize)) == NULL)
  221.         xlfail("insufficient vector space");
  222.     }
  223.     vect->n_vsize = size;
  224.     total += (long) bsize;
  225.     }
  226.     xlpop();
  227.     return (vect);
  228. }
  229.  
  230. /* newnode - allocate a new node */
  231. LOCAL LVAL newnode(type)
  232.   int type;
  233. {
  234.     LVAL nnode;
  235.  
  236.     /* get a free node */
  237.     if ((nnode = fnodes) == NIL) {
  238.     findmem();
  239.     if ((nnode = fnodes) == NIL)
  240.         xlabort("insufficient node space");
  241.     }
  242.  
  243.     /* unlink the node from the free list */
  244.     fnodes = cdr(nnode);
  245.     nfree -= 1L;
  246.  
  247.     /* initialize the new node */
  248.     nnode->n_type = type;
  249.     rplacd(nnode,NIL);
  250.  
  251.     /* return the new node */
  252.     return (nnode);
  253. }
  254.  
  255. /* stralloc - allocate memory for a string adding a byte for the terminator */
  256. LOCAL unsigned char *stralloc(size)
  257.   int size;
  258. {
  259.     unsigned char *sptr;
  260.  
  261.     /* allocate memory for the string copy */
  262.     if ((sptr = (unsigned char *)malloc(size)) == NULL) {
  263.     gc();  
  264.     if ((sptr = (unsigned char *)malloc(size)) == NULL)
  265.         xlfail("insufficient string space");
  266.     }
  267.     total += (long)size;
  268.  
  269.     /* return the new string memory */
  270.     return (sptr);
  271. }
  272.  
  273. /* findmem - find more memory by collecting then expanding */
  274. LOCAL findmem()
  275. {
  276.     gc();
  277.     if (nfree < (long)anodes)
  278.     addseg();
  279. }
  280.  
  281. /* gc - garbage collect (only called here and in xlimage.c) */
  282. gc()
  283. {
  284.     register LVAL **p,*ap,tmp;
  285.     char buf[STRMAX+1];
  286.     LVAL *newfp,fun;
  287.  
  288.     /* print the start of the gc message */
  289.     if (s_gcflag && getvalue(s_gcflag)) {
  290.     sprintf(buf,"[ gc: total %ld, ",nnodes);
  291.     stdputstr(buf);
  292.     }
  293.  
  294.     /* mark the obarray, the argument list and the current environment */
  295.     if (obarray)
  296.     mark(obarray);
  297.     if (xlenv)
  298.     mark(xlenv);
  299.     if (xlfenv)
  300.     mark(xlfenv);
  301.     if (xldenv)
  302.     mark(xldenv);
  303.  
  304.     /* mark the evaluation stack */
  305.     for (p = xlstack; p < xlstktop; ++p)
  306.     if (tmp = **p)
  307.         mark(tmp);
  308.  
  309.     /* mark the argument stack */
  310.     for (ap = xlargstkbase; ap < xlsp; ++ap)
  311.     if (tmp = *ap)
  312.         mark(tmp);
  313.  
  314.     /* sweep memory collecting all unmarked nodes */
  315.     sweep();
  316.  
  317.     /* count the gc call */
  318.     ++gccalls;
  319.  
  320.     /* call the *gc-hook* if necessary */
  321.     if (s_gchook && (fun = getvalue(s_gchook))) {
  322.     newfp = xlsp;
  323.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  324.     pusharg(fun);
  325.     pusharg(cvfixnum((FIXTYPE)2));
  326.     pusharg(cvfixnum((FIXTYPE)nnodes));
  327.     pusharg(cvfixnum((FIXTYPE)nfree));
  328.     xlfp = newfp;
  329.     xlapply(2);
  330.     }
  331.  
  332.     /* print the end of the gc message */
  333.     if (s_gcflag && getvalue(s_gcflag)) {
  334.     sprintf(buf,"%ld free ]\n",nfree);
  335.     stdputstr(buf);
  336.     }
  337. }
  338.  
  339. /* mark - mark all accessible nodes */
  340. LOCAL mark(ptr)
  341.   LVAL ptr;
  342. {
  343.     register LVAL this,prev,tmp;
  344.     int type,i,n;
  345.  
  346.     /* initialize */
  347.     prev = NIL;
  348.     this = ptr;
  349.  
  350.     /* mark this list */
  351.     for (;;) {
  352.  
  353.     /* descend as far as we can */
  354.     while (!(this->n_flags & MARK))
  355.  
  356.         /* check cons and unnamed stream nodes */
  357.         if ((type = ntype(this)) == CONS || type == USTREAM) {
  358.         if (tmp = car(this)) {
  359.             this->n_flags |= MARK|LEFT;
  360.             rplaca(this,prev);
  361.         }
  362.         else if (tmp = cdr(this)) {
  363.             this->n_flags |= MARK;
  364.             rplacd(this,prev);
  365.         }
  366.         else {                /* both sides nil */
  367.             this->n_flags |= MARK;
  368.             break;
  369.         }
  370.         prev = this;            /* step down the branch */
  371.         this = tmp;
  372.         }
  373.  
  374.         /* mark other node types */
  375.         else {
  376.         this->n_flags |= MARK;
  377.         switch (type) {
  378.         case SYMBOL:
  379.         case OBJECT:
  380.         case VECTOR:
  381.         case CLOSURE:
  382.         case STRUCT:
  383.             for (i = 0, n = getsize(this); --n >= 0; ++i)
  384.             if (tmp = getelement(this,i))
  385.                 mark(tmp);
  386.             break;
  387.         }
  388.         break;
  389.         }
  390.  
  391.     /* backup to a point where we can continue descending */
  392.     for (;;)
  393.  
  394.         /* make sure there is a previous node */
  395.         if (prev) {
  396.         if (prev->n_flags & LEFT) {    /* came from left side */
  397.             prev->n_flags &= ~LEFT;
  398.             tmp = car(prev);
  399.             rplaca(prev,this);
  400.             if (this = cdr(prev)) {
  401.             rplacd(prev,tmp);            
  402.             break;
  403.             }
  404.         }
  405.         else {                /* came from right side */
  406.             tmp = cdr(prev);
  407.             rplacd(prev,this);
  408.         }
  409.         this = prev;            /* step back up the branch */
  410.         prev = tmp;
  411.         }
  412.  
  413.         /* no previous node, must be done */
  414.         else
  415.         return;
  416.     }
  417. }
  418.  
  419. /* sweep - sweep all unmarked nodes and add them to the free list */
  420. LOCAL sweep()
  421. {
  422.     SEGMENT *seg;
  423.     LVAL p;
  424.     int n;
  425.  
  426.     /* empty the free list */
  427.     fnodes = NIL;
  428.     nfree = 0L;
  429.  
  430.     /* add all unmarked nodes */
  431.     for (seg = segs; seg; seg = seg->sg_next) {
  432.     if (seg == fixseg)     /* don't sweep the fixnum segment */
  433.         continue;
  434.     else if (seg == charseg) /* don't sweep the character segment */
  435.         continue;
  436.     p = &seg->sg_nodes[0];
  437.     for (n = seg->sg_size; --n >= 0; ++p)
  438.         if (!(p->n_flags & MARK)) {
  439.         switch (ntype(p)) {
  440.         case STRING:
  441.             if (getstring(p) != NULL) {
  442.                 total -= (long)getslength(p);
  443.                 free(getstring(p));
  444.             }
  445.             break;
  446.         case STREAM:
  447.             if (getfile(p))
  448.                 osclose(getfile(p));
  449.             break;
  450.         case SYMBOL:
  451.         case OBJECT:
  452.         case VECTOR:
  453.         case CLOSURE:
  454.         case STRUCT:
  455.             if (p->n_vsize) {
  456.                 total -= (long) (p->n_vsize * sizeof(LVAL));
  457.                 free(p->n_vdata);
  458.             }
  459.             break;
  460.         }
  461.         p->n_type = FREE;
  462.         rplaca(p,NIL);
  463.         rplacd(p,fnodes);
  464.         fnodes = p;
  465.         nfree += 1L;
  466.         }
  467.         else
  468.         p->n_flags &= ~MARK;
  469.     }
  470. }
  471.  
  472. /* addseg - add a segment to the available memory */
  473. LOCAL int addseg()
  474. {
  475.     SEGMENT *newseg;
  476.     LVAL p;
  477.     int n;
  478.  
  479.     /* allocate the new segment */
  480.     if (anodes == 0 || (newseg = newsegment(anodes)) == NULL)
  481.     return (FALSE);
  482.  
  483.     /* add each new node to the free list */
  484.     p = &newseg->sg_nodes[0];
  485.     for (n = anodes; --n >= 0; ++p) {
  486.     rplacd(p,fnodes);
  487.     fnodes = p;
  488.     }
  489.  
  490.     /* return successfully */
  491.     return (TRUE);
  492. }
  493.  
  494. /* newsegment - create a new segment (only called here and in xlimage.c) */
  495. SEGMENT *newsegment(n)
  496.   int n;
  497. {
  498.     SEGMENT *newseg;
  499.  
  500.     /* allocate the new segment */
  501.     if ((newseg = (SEGMENT *)calloc(1,segsize(n))) == NULL)
  502.     return (NULL);
  503.  
  504.     /* initialize the new segment */
  505.     newseg->sg_size = n;
  506.     newseg->sg_next = NULL;
  507.     if (segs)
  508.     lastseg->sg_next = newseg;
  509.     else
  510.     segs = newseg;
  511.     lastseg = newseg;
  512.  
  513.     /* update the statistics */
  514.     total += (long)segsize(n);
  515.     nnodes += (long)n;
  516.     nfree += (long)n;
  517.     ++nsegs;
  518.  
  519.     /* return the new segment */
  520.     return (newseg);
  521. }
  522.  
  523. /* stats - print memory statistics */
  524. LOCAL stats()
  525. {
  526.     sprintf(buf,"Nodes:       %ld\n",nnodes); stdputstr(buf);
  527.     sprintf(buf,"Free nodes:  %ld\n",nfree);  stdputstr(buf);
  528.     sprintf(buf,"Segments:    %d\n",nsegs);   stdputstr(buf);
  529.     sprintf(buf,"Allocate:    %d\n",anodes);  stdputstr(buf);
  530.     sprintf(buf,"Total:       %ld\n",total);  stdputstr(buf);
  531.     sprintf(buf,"Collections: %d\n",gccalls); stdputstr(buf);
  532. }
  533.  
  534. /* xgc - xlisp function to force garbage collection */
  535. LVAL xgc()
  536. {
  537.     /* make sure there aren't any arguments */
  538.     xllastarg();
  539.  
  540.     /* garbage collect */
  541.     gc();
  542.  
  543.     /* return nil */
  544.     return (NIL);
  545. }
  546.  
  547. /* xexpand - xlisp function to force memory expansion */
  548. LVAL xexpand()
  549. {
  550.     LVAL num;
  551.     int n,i;
  552.  
  553.     /* get the new number to allocate */
  554.     if (moreargs()) {
  555.     num = xlgafixnum();
  556.     n = getfixnum(num);
  557.     }
  558.     else
  559.     n = 1;
  560.     xllastarg();
  561.  
  562.     /* allocate more segments */
  563.     for (i = 0; i < n; i++)
  564.     if (!addseg())
  565.         break;
  566.  
  567.     /* return the number of segments added */
  568.     return (cvfixnum((FIXTYPE)i));
  569. }
  570.  
  571. /* xalloc - xlisp function to set the number of nodes to allocate */
  572. LVAL xalloc()
  573. {
  574.     int n,oldn;
  575.     LVAL num;
  576.  
  577.     /* get the new number to allocate */
  578.     num = xlgafixnum();
  579.     n = getfixnum(num);
  580.  
  581.     /* make sure there aren't any more arguments */
  582.     xllastarg();
  583.  
  584.     /* set the new number of nodes to allocate */
  585.     oldn = anodes;
  586.     anodes = n;
  587.  
  588.     /* return the old number */
  589.     return (cvfixnum((FIXTYPE)oldn));
  590. }
  591.  
  592. /* xmem - xlisp function to print memory statistics */
  593. LVAL xmem()
  594. {
  595.     /* allow one argument for compatiblity with common lisp */
  596.     if (moreargs()) xlgetarg();
  597.     xllastarg();
  598.  
  599.     /* print the statistics */
  600.     stats();
  601.  
  602.     /* return nil */
  603.     return (NIL);
  604. }
  605.  
  606. #ifdef SAVERESTORE
  607. /* xsave - save the memory image */
  608. LVAL xsave()
  609. {
  610.     unsigned char *name;
  611.  
  612.     /* get the file name, verbose flag and print flag */
  613.     name = getstring(xlgetfname());
  614.     xllastarg();
  615.  
  616.     /* save the memory image */
  617.     return (xlisave(name) ? true : NIL);
  618. }
  619.  
  620. /* xrestore - restore a saved memory image */
  621. LVAL xrestore()
  622. {
  623.     extern jmp_buf top_level;
  624.     unsigned char *name;
  625.  
  626.     /* get the file name, verbose flag and print flag */
  627.     name = getstring(xlgetfname());
  628.     xllastarg();
  629.  
  630.     /* restore the saved memory image */
  631.     if (!xlirestore(name))
  632.     return (NIL);
  633.  
  634.     /* return directly to the top level */
  635.     stdputstr("[ returning to the top level ]\n");
  636.     longjmp(top_level,1);
  637. }
  638. #endif
  639.  
  640. /* xlminit - initialize the dynamic memory module */
  641. xlminit()
  642. {
  643.     LVAL p;
  644.     int i;
  645.  
  646.     /* initialize our internal variables */
  647.     segs = lastseg = NULL;
  648.     nnodes = nfree = total = 0L;
  649.     nsegs = gccalls = 0;
  650.     anodes = NNODES;
  651.     fnodes = NIL;
  652.  
  653.     /* allocate the fixnum segment */
  654.     if ((fixseg = newsegment(SFIXSIZE)) == NULL)
  655.     xlfatal("insufficient memory");
  656.  
  657.     /* initialize the fixnum segment */
  658.     p = &fixseg->sg_nodes[0];
  659.     for (i = SFIXMIN; i <= SFIXMAX; ++i) {
  660.     p->n_type = FIXNUM;
  661.     p->n_fixnum = i;
  662.     ++p;
  663.     }
  664.  
  665.     /* allocate the character segment */
  666.     if ((charseg = newsegment(CHARSIZE)) == NULL)
  667.     xlfatal("insufficient memory");
  668.  
  669.     /* initialize the character segment */
  670.     p = &charseg->sg_nodes[0];
  671.     for (i = CHARMIN; i <= CHARMAX; ++i) {
  672.     p->n_type = CHAR;
  673.     p->n_chcode = i;
  674.     ++p;
  675.     }
  676.  
  677.     /* initialize structures that are marked by the collector */
  678.     obarray = xlenv = xlfenv = xldenv = NIL;
  679.     s_gcflag = s_gchook = NIL;
  680.  
  681.     /* allocate the evaluation stack */
  682.     if ((xlstkbase = (LVAL **)malloc(EDEPTH * sizeof(LVAL *))) == NULL)
  683.     xlfatal("insufficient memory");
  684.     xlstack = xlstktop = xlstkbase + EDEPTH;
  685.  
  686.     /* allocate the argument stack */
  687.     if ((xlargstkbase = (LVAL *)malloc(ADEPTH * sizeof(LVAL))) == NULL)
  688.     xlfatal("insufficient memory");
  689.     xlargstktop = xlargstkbase + ADEPTH;
  690.     xlfp = xlsp = xlargstkbase;
  691.     *xlsp++ = NIL;
  692. }
  693.  
  694. 
  695.