home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 254b.lha / AMXLISP_v2.0 / src / XLDMEM.C < prev    next >
C/C++ Source or Header  |  1989-05-09  |  15KB  |  681 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. /* newvector - allocate and initialize a new vector node */
  198. LVAL newvector(size)
  199.   int size;
  200. {
  201.     LVAL vect;
  202.     int bsize;
  203.     xlsave1(vect);
  204.     vect = newnode(VECTOR);
  205.     vect->n_vsize = 0;
  206.     if (bsize = size * sizeof(LVAL)) {
  207.     if ((vect->n_vdata = (LVAL *)calloc(1,bsize)) == NULL) {
  208.         findmem();
  209.         if ((vect->n_vdata = (LVAL *)calloc(1,bsize)) == NULL)
  210.         xlfail("insufficient vector space");
  211.     }
  212.     vect->n_vsize = size;
  213.     total += (long) bsize;
  214.     }
  215.     xlpop();
  216.     return (vect);
  217. }
  218.  
  219. /* newnode - allocate a new node */
  220. LOCAL LVAL newnode(type)
  221.   int type;
  222. {
  223.     LVAL nnode;
  224.  
  225.     /* get a free node */
  226.     if ((nnode = fnodes) == NIL) {
  227.     findmem();
  228.     if ((nnode = fnodes) == NIL)
  229.         xlabort("insufficient node space");
  230.     }
  231.  
  232.     /* unlink the node from the free list */
  233.     fnodes = cdr(nnode);
  234.     nfree -= 1L;
  235.  
  236.     /* initialize the new node */
  237.     nnode->n_type = type;
  238.     rplacd(nnode,NIL);
  239.  
  240.     /* return the new node */
  241.     return (nnode);
  242. }
  243.  
  244. /* stralloc - allocate memory for a string adding a byte for the terminator */
  245. LOCAL unsigned char *stralloc(size)
  246.   int size;
  247. {
  248.     unsigned char *sptr;
  249.  
  250.     /* allocate memory for the string copy */
  251.     if ((sptr = (unsigned char *)malloc(size)) == NULL) {
  252.     gc();  
  253.     if ((sptr = (unsigned char *)malloc(size)) == NULL)
  254.         xlfail("insufficient string space");
  255.     }
  256.     total += (long)size;
  257.  
  258.     /* return the new string memory */
  259.     return (sptr);
  260. }
  261.  
  262. /* findmem - find more memory by collecting then expanding */
  263. LOCAL findmem()
  264. {
  265.     gc();
  266.     if (nfree < (long)anodes)
  267.     addseg();
  268. }
  269.  
  270. /* gc - garbage collect (only called here and in xlimage.c) */
  271. gc()
  272. {
  273.     register LVAL **p,*ap,tmp;
  274.     char buf[STRMAX+1];
  275.     LVAL *newfp,fun;
  276.  
  277.     /* print the start of the gc message */
  278.     if (s_gcflag && getvalue(s_gcflag)) {
  279.     sprintf(buf,"[ gc: total %ld, ",nnodes);
  280.     stdputstr(buf);
  281.     }
  282.  
  283.     /* mark the obarray, the argument list and the current environment */
  284.     if (obarray)
  285.     mark(obarray);
  286.     if (xlenv)
  287.     mark(xlenv);
  288.     if (xlfenv)
  289.     mark(xlfenv);
  290.     if (xldenv)
  291.     mark(xldenv);
  292.  
  293.     /* mark the evaluation stack */
  294.     for (p = xlstack; p < xlstktop; ++p)
  295.     if (tmp = **p)
  296.         mark(tmp);
  297.  
  298.     /* mark the argument stack */
  299.     for (ap = xlargstkbase; ap < xlsp; ++ap)
  300.     if (tmp = *ap)
  301.         mark(tmp);
  302.  
  303.     /* sweep memory collecting all unmarked nodes */
  304.     sweep();
  305.  
  306.     /* count the gc call */
  307.     ++gccalls;
  308.  
  309.     /* call the *gc-hook* if necessary */
  310.     if (s_gchook && (fun = getvalue(s_gchook))) {
  311.     newfp = xlsp;
  312.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  313.     pusharg(fun);
  314.     pusharg(cvfixnum((FIXTYPE)2));
  315.     pusharg(cvfixnum((FIXTYPE)nnodes));
  316.     pusharg(cvfixnum((FIXTYPE)nfree));
  317.     xlfp = newfp;
  318.     xlapply(2);
  319.     }
  320.  
  321.     /* print the end of the gc message */
  322.     if (s_gcflag && getvalue(s_gcflag)) {
  323.     sprintf(buf,"%ld free ]\n",nfree);
  324.     stdputstr(buf);
  325.     }
  326. }
  327.  
  328. /* mark - mark all accessible nodes */
  329. LOCAL mark(ptr)
  330.   LVAL ptr;
  331. {
  332.     register LVAL this,prev,tmp;
  333.     int type,i,n;
  334.  
  335.     /* initialize */
  336.     prev = NIL;
  337.     this = ptr;
  338.  
  339.     /* mark this list */
  340.     for (;;) {
  341.  
  342.     /* descend as far as we can */
  343.     while (!(this->n_flags & MARK))
  344.  
  345.         /* check cons and symbol nodes */
  346.         if ((type = ntype(this)) == CONS) {
  347.         if (tmp = car(this)) {
  348.             this->n_flags |= MARK|LEFT;
  349.             rplaca(this,prev);
  350.         }
  351.         else if (tmp = cdr(this)) {
  352.             this->n_flags |= MARK;
  353.             rplacd(this,prev);
  354.         }
  355.         else {                /* both sides nil */
  356.             this->n_flags |= MARK;
  357.             break;
  358.         }
  359.         prev = this;            /* step down the branch */
  360.         this = tmp;
  361.         }
  362.  
  363.         /* mark other node types */
  364.         else {
  365.         this->n_flags |= MARK;
  366.         switch (type) {
  367.         case SYMBOL:
  368.         case OBJECT:
  369.         case VECTOR:
  370.         case CLOSURE:
  371.             for (i = 0, n = getsize(this); --n >= 0; ++i)
  372.             if (tmp = getelement(this,i))
  373.                 mark(tmp);
  374.             break;
  375.         }
  376.         break;
  377.         }
  378.  
  379.     /* backup to a point where we can continue descending */
  380.     for (;;)
  381.  
  382.         /* make sure there is a previous node */
  383.         if (prev) {
  384.         if (prev->n_flags & LEFT) {    /* came from left side */
  385.             prev->n_flags &= ~LEFT;
  386.             tmp = car(prev);
  387.             rplaca(prev,this);
  388.             if (this = cdr(prev)) {
  389.             rplacd(prev,tmp);            
  390.             break;
  391.             }
  392.         }
  393.         else {                /* came from right side */
  394.             tmp = cdr(prev);
  395.             rplacd(prev,this);
  396.         }
  397.         this = prev;            /* step back up the branch */
  398.         prev = tmp;
  399.         }
  400.  
  401.         /* no previous node, must be done */
  402.         else
  403.         return;
  404.     }
  405. }
  406.  
  407. /* sweep - sweep all unmarked nodes and add them to the free list */
  408. LOCAL sweep()
  409. {
  410.     SEGMENT *seg;
  411.     LVAL p;
  412.     int n;
  413.  
  414.     /* empty the free list */
  415.     fnodes = NIL;
  416.     nfree = 0L;
  417.  
  418.     /* add all unmarked nodes */
  419.     for (seg = segs; seg; seg = seg->sg_next) {
  420.     if (seg == fixseg)     /* don't sweep the fixnum segment */
  421.         continue;
  422.     else if (seg == charseg) /* don't sweep the character segment */
  423.         continue;
  424.     p = &seg->sg_nodes[0];
  425.     for (n = seg->sg_size; --n >= 0; ++p)
  426.         if (!(p->n_flags & MARK)) {
  427.         switch (ntype(p)) {
  428.         case STRING:
  429.             if (getstring(p) != NULL) {
  430.                 total -= (long)getslength(p);
  431.                 free(getstring(p));
  432.             }
  433.             break;
  434.         case STREAM:
  435.             if (getfile(p))
  436.                 osclose(getfile(p));
  437.             break;
  438.         case SYMBOL:
  439.         case OBJECT:
  440.         case VECTOR:
  441.         case CLOSURE:
  442.             if (p->n_vsize) {
  443.                 total -= (long) (p->n_vsize * sizeof(LVAL));
  444.                 free(p->n_vdata);
  445.             }
  446.             break;
  447.         }
  448.         p->n_type = FREE;
  449.         rplaca(p,NIL);
  450.         rplacd(p,fnodes);
  451.         fnodes = p;
  452.         nfree += 1L;
  453.         }
  454.         else
  455.         p->n_flags &= ~MARK;
  456.     }
  457. }
  458.  
  459. /* addseg - add a segment to the available memory */
  460. LOCAL int addseg()
  461. {
  462.     SEGMENT *newseg;
  463.     LVAL p;
  464.     int n;
  465.  
  466.     /* allocate the new segment */
  467.     if (anodes == 0 || (newseg = newsegment(anodes)) == NULL)
  468.     return (FALSE);
  469.  
  470.     /* add each new node to the free list */
  471.     p = &newseg->sg_nodes[0];
  472.     for (n = anodes; --n >= 0; ++p) {
  473.     rplacd(p,fnodes);
  474.     fnodes = p;
  475.     }
  476.  
  477.     /* return successfully */
  478.     return (TRUE);
  479. }
  480.  
  481. /* newsegment - create a new segment (only called here and in xlimage.c) */
  482. SEGMENT *newsegment(n)
  483.   int n;
  484. {
  485.     SEGMENT *newseg;
  486.  
  487.     /* allocate the new segment */
  488.     if ((newseg = (SEGMENT *)calloc(1,segsize(n))) == NULL)
  489.     return (NULL);
  490.  
  491.     /* initialize the new segment */
  492.     newseg->sg_size = n;
  493.     newseg->sg_next = NULL;
  494.     if (segs)
  495.     lastseg->sg_next = newseg;
  496.     else
  497.     segs = newseg;
  498.     lastseg = newseg;
  499.  
  500.     /* update the statistics */
  501.     total += (long)segsize(n);
  502.     nnodes += (long)n;
  503.     nfree += (long)n;
  504.     ++nsegs;
  505.  
  506.     /* return the new segment */
  507.     return (newseg);
  508. }
  509.  
  510. /* stats - print memory statistics */
  511. LOCAL stats()
  512. {
  513.     sprintf(buf,"Nodes:       %ld\n",nnodes); stdputstr(buf);
  514.     sprintf(buf,"Free nodes:  %ld\n",nfree);  stdputstr(buf);
  515.     sprintf(buf,"Segments:    %d\n",nsegs);   stdputstr(buf);
  516.     sprintf(buf,"Allocate:    %d\n",anodes);  stdputstr(buf);
  517.     sprintf(buf,"Total:       %ld\n",total);  stdputstr(buf);
  518.     sprintf(buf,"Collections: %d\n",gccalls); stdputstr(buf);
  519. }
  520.  
  521. /* xgc - xlisp function to force garbage collection */
  522. LVAL xgc()
  523. {
  524.     /* make sure there aren't any arguments */
  525.     xllastarg();
  526.  
  527.     /* garbage collect */
  528.     gc();
  529.  
  530.     /* return nil */
  531.     return (NIL);
  532. }
  533.  
  534. /* xexpand - xlisp function to force memory expansion */
  535. LVAL xexpand()
  536. {
  537.     LVAL num;
  538.     int n,i;
  539.  
  540.     /* get the new number to allocate */
  541.     if (moreargs()) {
  542.     num = xlgafixnum();
  543.     n = getfixnum(num);
  544.     }
  545.     else
  546.     n = 1;
  547.     xllastarg();
  548.  
  549.     /* allocate more segments */
  550.     for (i = 0; i < n; i++)
  551.     if (!addseg())
  552.         break;
  553.  
  554.     /* return the number of segments added */
  555.     return (cvfixnum((FIXTYPE)i));
  556. }
  557.  
  558. /* xalloc - xlisp function to set the number of nodes to allocate */
  559. LVAL xalloc()
  560. {
  561.     int n,oldn;
  562.     LVAL num;
  563.  
  564.     /* get the new number to allocate */
  565.     num = xlgafixnum();
  566.     n = getfixnum(num);
  567.  
  568.     /* make sure there aren't any more arguments */
  569.     xllastarg();
  570.  
  571.     /* set the new number of nodes to allocate */
  572.     oldn = anodes;
  573.     anodes = n;
  574.  
  575.     /* return the old number */
  576.     return (cvfixnum((FIXTYPE)oldn));
  577. }
  578.  
  579. /* xmem - xlisp function to print memory statistics */
  580. LVAL xmem()
  581. {
  582.     /* allow one argument for compatiblity with common lisp */
  583.     if (moreargs()) xlgetarg();
  584.     xllastarg();
  585.  
  586.     /* print the statistics */
  587.     stats();
  588.  
  589.     /* return nil */
  590.     return (NIL);
  591. }
  592.  
  593. #ifdef SAVERESTORE
  594. /* xsave - save the memory image */
  595. LVAL xsave()
  596. {
  597.     unsigned char *name;
  598.  
  599.     /* get the file name, verbose flag and print flag */
  600.     name = getstring(xlgetfname());
  601.     xllastarg();
  602.  
  603.     /* save the memory image */
  604.     return (xlisave(name) ? true : NIL);
  605. }
  606.  
  607. /* xrestore - restore a saved memory image */
  608. LVAL xrestore()
  609. {
  610.     extern jmp_buf top_level;
  611.     unsigned char *name;
  612.  
  613.     /* get the file name, verbose flag and print flag */
  614.     name = getstring(xlgetfname());
  615.     xllastarg();
  616.  
  617.     /* restore the saved memory image */
  618.     if (!xlirestore(name))
  619.     return (NIL);
  620.  
  621.     /* return directly to the top level */
  622.     stdputstr("[ returning to the top level ]\n");
  623.     longjmp(top_level,1);
  624. }
  625. #endif
  626.  
  627. /* xlminit - initialize the dynamic memory module */
  628. xlminit()
  629. {
  630.     LVAL p;
  631.     int i;
  632.  
  633.     /* initialize our internal variables */
  634.     segs = lastseg = NULL;
  635.     nnodes = nfree = total = 0L;
  636.     nsegs = gccalls = 0;
  637.     anodes = NNODES;
  638.     fnodes = NIL;
  639.  
  640.     /* allocate the fixnum segment */
  641.     if ((fixseg = newsegment(SFIXSIZE)) == NULL)
  642.     xlfatal("insufficient memory");
  643.  
  644.     /* initialize the fixnum segment */
  645.     p = &fixseg->sg_nodes[0];
  646.     for (i = SFIXMIN; i <= SFIXMAX; ++i) {
  647.     p->n_type = FIXNUM;
  648.     p->n_fixnum = i;
  649.     ++p;
  650.     }
  651.  
  652.     /* allocate the character segment */
  653.     if ((charseg = newsegment(CHARSIZE)) == NULL)
  654.     xlfatal("insufficient memory");
  655.  
  656.     /* initialize the character segment */
  657.     p = &charseg->sg_nodes[0];
  658.     for (i = CHARMIN; i <= CHARMAX; ++i) {
  659.     p->n_type = CHAR;
  660.     p->n_chcode = i;
  661.     ++p;
  662.     }
  663.  
  664.     /* initialize structures that are marked by the collector */
  665.     obarray = xlenv = xlfenv = xldenv = NIL;
  666.     s_gcflag = s_gchook = NIL;
  667.  
  668.     /* allocate the evaluation stack */
  669.     if ((xlstkbase = (LVAL **)malloc(EDEPTH * sizeof(LVAL *))) == NULL)
  670.     xlfatal("insufficient memory");
  671.     xlstack = xlstktop = xlstkbase + EDEPTH;
  672.  
  673.     /* allocate the argument stack */
  674.     if ((xlargstkbase = (LVAL *)malloc(ADEPTH * sizeof(LVAL))) == NULL)
  675.     xlfatal("insufficient memory");
  676.     xlargstktop = xlargstkbase + ADEPTH;
  677.     xlfp = xlsp = xlargstkbase;
  678.     *xlsp++ = NIL;
  679. }
  680.  
  681.