home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 5 / FreshFish_July-August1994.bin / bbs / util / jade-3.0.lha / Jade / src / values.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-04-19  |  21.7 KB  |  998 lines
  1. /* values.c -- Handling of Lisp data (includes garbage collection)
  2.    Copyright (C) 1993, 1994 John Harper <jsh@ukc.ac.uk>
  3.  
  4. This file is part of Jade.
  5.  
  6. Jade is free software; you can redistribute it and/or modify it
  7. under the terms of the GNU General Public License as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. Jade is distributed in the hope that it will be useful, but
  12. WITHOUT ANY WARRANTY; without even the implied warranty of
  13. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. GNU General Public License for more details.
  15.  
  16. You should have received a copy of the GNU General Public License
  17. along with Jade; see the file COPYING.  If not, write to
  18. the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19.  
  20. #include "jade.h"
  21. #include "jade_protos.h"
  22.  
  23. #include <string.h>
  24. #include <assert.h>
  25.  
  26. #ifdef HAVE_UNIX
  27. #include <signal.h>
  28. #endif
  29.  
  30. /* #define GC_MONITOR_STK */
  31.  
  32. #define STATIC_SMALL_NUMBERS 256
  33.  
  34. _PR int valuecmp(VALUE, VALUE);
  35. _PR void princval(VALUE, VALUE);
  36. _PR void printval(VALUE, VALUE);
  37. _PR int nil_cmp(VALUE, VALUE);
  38. _PR String *valstralloc(int);
  39. _PR String *valstrdupn(const u_char *, int);
  40. _PR String *valstrdup(const u_char *);
  41. _PR int string_cmp(VALUE, VALUE);
  42. _PR Number *newnumber(long);
  43. _PR int number_cmp(VALUE, VALUE);
  44. _PR int ptr_cmp(VALUE, VALUE);
  45. _PR void cons_free(VALUE);
  46. _PR int cons_cmp(VALUE, VALUE);
  47. _PR VALUE list_1(VALUE);
  48. _PR VALUE list_2(VALUE, VALUE);
  49. _PR VALUE list_3(VALUE, VALUE, VALUE);
  50. _PR VALUE list_4(VALUE, VALUE, VALUE, VALUE);
  51. _PR VALUE list_5(VALUE, VALUE, VALUE, VALUE, VALUE);
  52. _PR Vector *newvector(int);
  53. _PR LPos *newlpos(POS *);
  54. _PR LPos *newlpos2(long, long);
  55. _PR int lpos_cmp(VALUE, VALUE);
  56. _PR void lpos_prin(VALUE, VALUE);
  57. _PR int vector_cmp(VALUE, VALUE);
  58.  
  59. _PR void markstatic(VALUE *);
  60. _PR void markvalue(VALUE);
  61.  
  62. _PR void values_init (void);
  63. _PR void values_init2(void);
  64. _PR void values_kill (void);
  65.  
  66. ValClass ValueClasses[] = {
  67.     { string_cmp, string_princ, string_print, MKSTR("string") },
  68.     { string_cmp, string_princ, string_print, MKSTR("string") },
  69.     { number_cmp, lisp_prin, lisp_prin, MKSTR("number") },
  70.     { cons_cmp, lisp_prin, lisp_prin, MKSTR("cons") },
  71.     { vector_cmp, lisp_prin, lisp_prin, MKSTR("vector") },
  72.     { symbol_cmp, symbol_princ, symbol_print, MKSTR("symbol") },
  73.     { mark_cmp, mark_prin, mark_prin, MKSTR("mark") },
  74.     { lpos_cmp, lpos_prin, lpos_prin, MKSTR("pos") },
  75.     { ptr_cmp, keymap_prin, keymap_prin, MKSTR("keytab") },
  76.     { ptr_cmp, keymap_prin, keymap_prin, MKSTR("keylist") },
  77.     { ptr_cmp, lisp_prin, lisp_prin, MKSTR("var") },
  78.     { ptr_cmp, lisp_prin, lisp_prin, MKSTR("subr-0") },
  79.     { ptr_cmp, lisp_prin, lisp_prin, MKSTR("subr-1") },
  80.     { ptr_cmp, lisp_prin, lisp_prin, MKSTR("subr-2") },
  81.     { ptr_cmp, lisp_prin, lisp_prin, MKSTR("subr-3") },
  82.     { ptr_cmp, lisp_prin, lisp_prin, MKSTR("subr-4") },
  83.     { ptr_cmp, lisp_prin, lisp_prin, MKSTR("subr-5") },
  84.     { ptr_cmp, lisp_prin, lisp_prin, MKSTR("subr-n") },
  85.     { ptr_cmp, lisp_prin, lisp_prin, MKSTR("special-form") },
  86.     { ptr_cmp, buffer_prin, buffer_prin, MKSTR("buffer") },
  87.     { ptr_cmp, window_prin, window_prin, MKSTR("window") },
  88.     { file_cmp, file_prin, file_prin, MKSTR("file") },
  89. #ifdef HAVE_UNIX
  90.     { ptr_cmp, proc_prin, proc_prin, MKSTR("process") },
  91. #else
  92.     { nil_cmp, lisp_prin, lisp_prin, MKSTR("process") },
  93. #endif
  94. };
  95.  
  96. int
  97. valuecmp(VALUE v1, VALUE v2)
  98. {
  99.     if(v1 && v2)
  100.     return(VALUECMP(v1, v2));
  101.     return(1);
  102. }
  103. void
  104. princval(VALUE strm, VALUE val)
  105. {
  106.     if(val)
  107.     PRINCVAL(strm, val);
  108. }
  109. void
  110. printval(VALUE strm, VALUE val)
  111. {
  112.     if(val)
  113.     PRINTVAL(strm, val);
  114. }
  115.  
  116. int
  117. nil_cmp(VALUE val1, VALUE val2)
  118. {
  119.     if(VTYPE(val1) == VTYPE(val2))
  120.     return(0);
  121.     return(1);
  122. }
  123.  
  124. static STRMEM LispStrMem;
  125. _PR String *NullString;
  126. String *NullString = MKSTR("");
  127. String *
  128. valstralloc(int slen)
  129. {
  130.     String *str;
  131.     slen = STR_SIZE(slen);
  132.     str = sm_alloc(&LispStrMem, slen);
  133.     if(str)
  134.     {
  135.     str->str_Type = V_String;
  136.     DataAfterGC += slen;
  137.     return(str);
  138.     }
  139.     return(NULL);
  140. }
  141. String *
  142. valstrdupn(const u_char *src, int slen)
  143. {
  144.     String *dst = valstralloc(slen + 1);
  145.     if(dst)
  146.     {
  147.     memcpy(dst->str_Data, src, slen);
  148.     dst->str_Data[slen] = 0;
  149.     }
  150.     return(dst);
  151. }
  152. String *
  153. valstrdup(const u_char * src)
  154. {
  155.     return(valstrdupn(src, strlen(src)));
  156. }
  157. int
  158. string_cmp(VALUE v1, VALUE v2)
  159. {
  160.     if(STRINGP(v1) && STRINGP(v2))
  161.     return(strcmp(VSTR(v1), VSTR(v2)));
  162.     return(1);
  163. }
  164. static void
  165. string_sweep(void)
  166. {
  167.     int bucket;
  168.     MEMCHUNK *mlc;
  169.     for(bucket = 0; bucket < NUMBUCKETS; bucket++)
  170.     {
  171.     MEMCHUNK **freelist = &LispStrMem.sm_MemBuckets[bucket].mbu_FreeList;
  172.     MEMBLOCK *mbl = (MEMBLOCK *)LispStrMem.sm_MemBuckets[bucket].mbu_MemBlocks.mlh_Head;
  173.     MEMBLOCK *nxt;
  174.     int chnksiz = MCHNK_SIZE((bucket + 1) * GRAIN);
  175.     int numchnks = LispStrMem.sm_ChunksPerBlock[bucket];
  176.     *freelist = NULL;
  177.     while((nxt = (MEMBLOCK *)mbl->mbl_Node.mln_Succ))
  178.     {
  179.         MEMCHUNK *mc = mbl->mbl_Chunks;
  180.         int j;
  181.         for(j = 0; j < numchnks; j++)
  182.         {
  183.         if(mc->mc_BlkType != MBT_FREE)
  184.         {
  185.             if(mc->mc_Mem.mem[0] & GC_MARK_BIT)
  186.             mc->mc_Mem.mem[0] = V_String;
  187.             else
  188.             {
  189.             mc->mc_BlkType = MBT_FREE;
  190.             mc->mc_Mem.nextfree = *freelist;
  191.             *freelist = mc;
  192.             }
  193.         }
  194.         mc = (MEMCHUNK *)((char *)mc + chnksiz);
  195.         }
  196.         mbl = nxt;
  197.     }
  198.     }
  199.     mlc = LispStrMem.sm_MallocChain;
  200.     LispStrMem.sm_MallocChain = NULL;
  201.     while(mlc)
  202.     {
  203.     MEMCHUNK *nxtmlc = mlc->mc_Header.next;
  204.     if(mlc->mc_Mem.mem[0] == V_String)
  205.         myfree(mlc);
  206.     else
  207.     {
  208.         mlc->mc_Mem.mem[0] = V_String;
  209.         mlc->mc_Header.next = LispStrMem.sm_MallocChain;
  210.         LispStrMem.sm_MallocChain = mlc;
  211.     }
  212.     mlc = nxtmlc;
  213.     }
  214. }
  215.  
  216. static NumberBlk *NumberBlkChain;
  217. static Number *NumberFreeList;
  218. static int AllocatedNumbers, UsedNumbers;
  219.  
  220. #ifdef STATIC_SMALL_NUMBERS
  221. static Number SmallNumbers[STATIC_SMALL_NUMBERS];
  222. #endif
  223.  
  224. Number *
  225. newnumber(long n)
  226. {
  227.     Number *num;
  228. #ifdef STATIC_SMALL_NUMBERS
  229.     if((n < STATIC_SMALL_NUMBERS) && (n >= 0))
  230.     return(&SmallNumbers[n]);
  231. #endif
  232.     if(!(num = NumberFreeList))
  233.     {
  234.     NumberBlk *nb = mymalloc(sizeof(NumberBlk));
  235.     if(nb)
  236.     {
  237.         int i;
  238.         AllocatedNumbers += NUMBERBLK_SIZE;
  239.         nb->nb_Next = NumberBlkChain;
  240.         NumberBlkChain = nb;
  241.         for(i = 0; i < (NUMBERBLK_SIZE - 1); i++)
  242.         nb->nb_Numbers[i].num_Data.next = &nb->nb_Numbers[i + 1];
  243.         nb->nb_Numbers[i].num_Data.next = NumberFreeList;
  244.         NumberFreeList = nb->nb_Numbers;
  245.     }
  246.     num = NumberFreeList;
  247.     }
  248.     NumberFreeList = num->num_Data.next;
  249.     num->num_Type = V_Number;
  250.     num->num_Data.number = n;
  251.     UsedNumbers++;
  252.     DataAfterGC += sizeof(Number);
  253.     return(num);
  254. }
  255. static void
  256. number_sweep(void)
  257. {
  258.     NumberBlk *nb = NumberBlkChain;
  259.     int i;
  260.     NumberFreeList = NULL;
  261.     UsedNumbers = 0;
  262.     while(nb)
  263.     {
  264.     NumberBlk *nxt = nb->nb_Next;
  265.     for(i = 0; i < NUMBERBLK_SIZE; i++)
  266.     {
  267.         if(!GC_MARKEDP(&nb->nb_Numbers[i]))
  268.         {
  269.         nb->nb_Numbers[i].num_Data.next = NumberFreeList;
  270.         NumberFreeList = &nb->nb_Numbers[i];
  271.         }
  272.         else
  273.         {
  274.         GC_CLR(&nb->nb_Numbers[i]);
  275.         UsedNumbers++;
  276.         }
  277.     }
  278.     nb = nxt;
  279.     }
  280. #ifdef STATIC_SMALL_NUMBERS
  281.     for(i = 0; i < STATIC_SMALL_NUMBERS; i++)
  282.     GC_CLR(&SmallNumbers[i]);
  283. #endif
  284. }
  285. int
  286. number_cmp(VALUE v1, VALUE v2)
  287. {
  288.     if(VTYPE(v1) == VTYPE(v2))
  289.     return(VNUM(v1) - VNUM(v2));
  290.     return(1);
  291. }
  292.  
  293. int
  294. ptr_cmp(VALUE v1, VALUE v2)
  295. {
  296.     if(VTYPE(v1) == VTYPE(v2))
  297.     return(!(VPTR(v1) == VPTR(v2)));
  298.     return(1);
  299. }
  300.  
  301. static ConsBlk *ConsBlkChain;
  302. static Cons *ConsFreeList;
  303. static int AllocatedCons, UsedCons;
  304.  
  305. _PR VALUE cmd_cons(VALUE, VALUE);
  306. DEFUN("cons", cmd_cons, subr_cons, (VALUE car, VALUE cdr), V_Subr2, DOC_cons) /*
  307. ::doc:cons::
  308. (cons CAR-VALUE CDR-VALUE)
  309. Returns a new cons-cell with car CAR-VALUE and cdr CDR-VALUE.
  310. ::end:: */
  311. {
  312.     Cons *cn = ConsFreeList;
  313.     if(!cn)
  314.     {
  315.     ConsBlk *cb = mycalloc(sizeof(ConsBlk));
  316.     if(cb)
  317.     {
  318.         int i;
  319.         AllocatedCons += CONSBLK_SIZE;
  320.         cb->cb_Next = ConsBlkChain;
  321.         ConsBlkChain = cb;
  322.         for(i = 0; i < (CONSBLK_SIZE - 1); i++)
  323.         cb->cb_Cons[i].cn_Cdr = &cb->cb_Cons[i + 1];
  324.         cb->cb_Cons[i].cn_Cdr = NULL;
  325.         ConsFreeList = cb->cb_Cons;
  326.     }
  327.     cn = ConsFreeList;
  328.     }
  329.     ConsFreeList = cn->cn_Cdr;
  330.     cn->cn_Type = V_Cons;
  331.     cn->cn_Car = car;
  332.     cn->cn_Cdr = cdr;
  333.     UsedCons++;
  334.     DataAfterGC += sizeof(Cons);
  335.     return(cn);
  336. }
  337. void
  338. cons_free(VALUE cn)
  339. {
  340.     VCDR(cn) = ConsFreeList;
  341.     ConsFreeList = cn;
  342.     UsedCons--;
  343. }
  344.  
  345. static void
  346. cons_sweep(void)
  347. {
  348.     ConsBlk *cb = ConsBlkChain;
  349.     ConsBlkChain = NULL;
  350.     ConsFreeList = NULL;
  351.     UsedCons = 0;
  352.     while(cb)
  353.     {
  354.     ConsBlk *nxt = cb->cb_Next;
  355.     Cons *newfree = NULL, *newfreetail = NULL, *this;
  356.     int i, newused = 0;
  357.     for(i = 0, this = cb->cb_Cons; i < CONSBLK_SIZE; i++, this++)
  358.     {
  359.         if(!GC_MARKEDP(this))
  360.         {
  361.         if(!newfreetail)
  362.             newfreetail = this;
  363.         this->cn_Cdr = newfree;
  364.         newfree = this;
  365.         }
  366.         else
  367.         {
  368.         GC_CLR(this);
  369.         newused++;
  370.         }
  371.     }
  372.     if(newused == 0)
  373.     {
  374.         /* Whole ConsBlk unused, lets get rid of it.  */
  375.         myfree(cb);
  376.         AllocatedCons -= CONSBLK_SIZE;
  377.     }
  378.     else
  379.     {
  380.         if(newfreetail)
  381.         {
  382.         /* Link this mini-freelist onto the main one.  */
  383.         newfreetail->cn_Cdr = ConsFreeList;
  384.         ConsFreeList = newfree;
  385.         UsedCons += newused;
  386.         }
  387.         /* Have to rebuild the ConsBlk chain as well.  */
  388.         cb->cb_Next = ConsBlkChain;
  389.         ConsBlkChain = cb;
  390.     }
  391.     cb = nxt;
  392.     }
  393. }
  394. int
  395. cons_cmp(VALUE v1, VALUE v2)
  396. {
  397.     int rc = 1;
  398.     if(VTYPE(v1) == VTYPE(v2))
  399.     {
  400.     rc = VALUECMP(VCAR(v1), VCAR(v2));
  401.     if(!rc)
  402.         rc = valuecmp(VCDR(v1), VCDR(v2));
  403.     }
  404.     return(rc);
  405. }
  406.  
  407. VALUE
  408. list_1(VALUE v1)
  409. {
  410.     return(LIST_1(v1));
  411. }
  412. VALUE
  413. list_2(VALUE v1, VALUE v2)
  414. {
  415.     return(LIST_2(v1, v2));
  416. }
  417. VALUE
  418. list_3(VALUE v1, VALUE v2, VALUE v3)
  419. {
  420.     return(LIST_3(v1, v2, v3));
  421. }
  422. VALUE
  423. list_4(VALUE v1, VALUE v2, VALUE v3, VALUE v4)
  424. {
  425.     return(LIST_4(v1, v2, v3, v4));
  426. }
  427. VALUE
  428. list_5(VALUE v1, VALUE v2, VALUE v3, VALUE v4, VALUE v5)
  429. {
  430.     return(LIST_5(v1, v2, v3, v4, v5));
  431. }
  432.  
  433. static Vector *VectorChain;
  434. static int UsedVectorSlots;
  435. Vector *
  436. newvector(int size)
  437. {
  438.     int len = VECT_SIZE(size);
  439.     Vector *v = mycalloc(len);
  440.     if(v)
  441.     {
  442.     v->vc_Type = V_Vector;
  443.     v->vc_Next = VectorChain;
  444.     VectorChain = v;
  445.     v->vc_Size = size;
  446.     UsedVectorSlots += size;
  447.     DataAfterGC += len;
  448.     }
  449.     return(v);
  450. }
  451. static void
  452. vector_sweep(void)
  453. {
  454.     Vector *this = VectorChain;
  455.     VectorChain = NULL;
  456.     UsedVectorSlots = 0;
  457.     while(this)
  458.     {
  459.     Vector *nxt = this->vc_Next;
  460.     if(!GC_MARKEDP(this))
  461.         myfree(this);
  462.     else
  463.     {
  464.         this->vc_Next = VectorChain;
  465.         VectorChain = this;
  466.         UsedVectorSlots += this->vc_Size;
  467.         GC_CLR(this);
  468.     }
  469.     this = nxt;
  470.     }
  471. }
  472. int
  473. vector_cmp(VALUE v1, VALUE v2)
  474. {
  475.     int rc = 1;
  476.     if((VTYPE(v1) == VTYPE(v2)) && (VVECT(v1)->vc_Size == VVECT(v2)->vc_Size))
  477.     {
  478.     int i;
  479.     for(i = rc = 0; (i < VVECT(v1)->vc_Size) && (!rc); i++)
  480.         rc = valuecmp(&VVECT(v1)->vc_Array[i], &VVECT(v2)->vc_Array[i]);
  481.     }
  482.     return(rc);
  483. }
  484.  
  485. static LPosBlk *LPosBlkChain;
  486. static LPos *LPosFreeList;
  487. static int UsedLPos, AllocatedLPos;
  488. LPos *
  489. newlpos(POS *pos)
  490. {
  491.     LPos *lp = LPosFreeList;
  492.     if(!lp)
  493.     {
  494.     LPosBlk *lb = mycalloc(sizeof(LPosBlk));
  495.     if(lb)
  496.     {
  497.         int i;
  498.         AllocatedLPos += LPOSBLK_SIZE;
  499.         lb->lb_Next = LPosBlkChain;
  500.         LPosBlkChain = lb;
  501.         for(i = 0; i < (LPOSBLK_SIZE - 1); i++)
  502.         lb->lb_Pos[i].lp_Next = &lb->lb_Pos[i + 1];
  503.         lb->lb_Pos[i].lp_Next = LPosFreeList;
  504.         LPosFreeList = lb->lb_Pos;
  505.     }
  506.     lp = LPosFreeList;
  507.     }
  508.     LPosFreeList = lp->lp_Next;
  509.     lp->lp_Data.type = V_Pos;
  510.     if(pos)
  511.     lp->lp_Data.pos = *pos;
  512.     UsedLPos++;
  513.     DataAfterGC += sizeof(LPos);
  514.     return(lp);
  515. }
  516. LPos *
  517. newlpos2(long x, long y)
  518. {
  519.     POS tmp;
  520.     tmp.pos_Col = x;
  521.     tmp.pos_Line = y;
  522.     return(newlpos(&tmp));
  523. }
  524. _PR VALUE cmd_pos(VALUE, VALUE);
  525. DEFUN("pos", cmd_pos, subr_pos, (VALUE x, VALUE y), V_Subr2, DOC_pos) /*
  526. ::doc:pos::
  527. (pos X Y)
  528. Returns a new position object with coordinates (X , Y).
  529. ::end:: */
  530. {
  531.     POS tmp;
  532.     if(NUMBERP(x))
  533.     tmp.pos_Col = VNUM(x) - 1;
  534.     else
  535.     tmp.pos_Col = CurrVW->vw_CursorPos.pos_Col;
  536.     if(NUMBERP(y))
  537.     tmp.pos_Line = VNUM(y) - 1;
  538.     else
  539.     tmp.pos_Line = CurrVW->vw_CursorPos.pos_Line;
  540.     return(newlpos(&tmp));
  541. }
  542. _PR VALUE cmd_dup_pos(VALUE pos);
  543. DEFUN("dup-pos", cmd_dup_pos, subr_dup_pos, (VALUE pos), V_Subr1, DOC_dup_pos) /*
  544. ::doc:dup_pos::
  545. (dup-pos POS)
  546. Returns a new copy of POS.
  547. ::end:: */
  548. {
  549.     DECLARE1(pos, POSP);
  550.     return(newlpos(&VPOS(pos)));
  551. }
  552. void
  553. lpos_prin(VALUE strm, VALUE obj)
  554. {
  555.     u_char tbuf[32];
  556.     sprintf(tbuf, "#<pos %ld %ld>", VPOS(obj).pos_Col + 1, VPOS(obj).pos_Line + 1);
  557.     streamputs(strm, tbuf, FALSE);
  558. }
  559. static void
  560. lpos_sweep(void)
  561. {
  562.     LPosBlk *lb = LPosBlkChain;
  563.     LPosFreeList = NULL;
  564.     UsedLPos = 0;
  565.     while(lb)
  566.     {
  567.     int i;
  568.     LPosBlk *nxt = lb->lb_Next;
  569.     for(i = 0; i < LPOSBLK_SIZE; i++)
  570.     {
  571.         if(!GC_MARKEDP(&lb->lb_Pos[i]))
  572.         {
  573.         lb->lb_Pos[i].lp_Next = LPosFreeList;
  574.         LPosFreeList = &lb->lb_Pos[i];
  575.         }
  576.         else
  577.         {
  578.         GC_CLR(&lb->lb_Pos[i]);
  579.         UsedLPos++;
  580.         }
  581.     }
  582.     lb = nxt;
  583.     }
  584. }
  585. int
  586. lpos_cmp(VALUE v1, VALUE v2)
  587. {
  588.     int rc = 1;
  589.     if(VTYPE(v2) == VTYPE(v1))
  590.     {
  591.     if(!(rc = VPOS(v1).pos_Line - VPOS(v2).pos_Line))
  592.         rc = VPOS(v1).pos_Col - VPOS(v2).pos_Col;
  593.     }
  594.     return(rc);
  595. }
  596.  
  597. /*
  598.  * Garbage Collection is here
  599.  */
  600. #define NUM_STATIC_OBJS 128
  601. static VALUE *StaticMarks[NUM_STATIC_OBJS];
  602. static int NextStatic;
  603. _PR GCVAL *GCVStack;
  604. _PR GCVALN *GCVNStack;
  605. GCVAL *GCVStack;
  606. GCVALN *GCVNStack;
  607. /*
  608.  * DataAfterGC = bytes of storage used since last gc
  609.  * DataBeforeGC = value that DataAfterGC should be before gc'ing
  610.  * IdleDataBeforeGC = value that DAGC should be before gc'ing in idle time
  611.  * GCinhibit = protects against against gc in critical section when TRUE
  612.  */
  613. _PR int DataAfterGC, DataBeforeGC, IdleDataBeforeGC, GCinhibit;
  614. int DataAfterGC, DataBeforeGC = 100000, IdleDataBeforeGC = 20000, GCinhibit;
  615.  
  616. #ifdef GC_MONITOR_STK
  617. static int *StkHighTide;
  618. #endif
  619.  
  620. void
  621. markstatic(VALUE *obj)
  622. {
  623.     assert(NextStatic < NUM_STATIC_OBJS);
  624.     StaticMarks[NextStatic++] = obj;
  625. }
  626.  
  627. /* Mark a single Lisp object.
  628.    This attempts to eliminate as much tail-recursion as possible (by
  629.    changing the VAL and jumping back to the `again' label).  */
  630. void
  631. markvalue(register VALUE val)
  632. {
  633. #ifdef GC_MONITOR_STK
  634.     int dummy;
  635.     /* Assumes that the stack grows downwards (towards 0)    */
  636.     if(&dummy < StkHighTide)
  637.     StkHighTide = &dummy;
  638. #endif
  639. #if 0
  640.     /* This is done in the macro MARKVAL(), it saves an unnecessary function
  641.        call.  */
  642.     if((val == NULL) || GC_MARKEDP(val))
  643.     return;
  644. #endif
  645. #ifdef MINSTACK
  646.     /* This is a real problem. I can't safely stop marking since this means
  647.        that some lisp data won't have been marked and therefore the sweep
  648.        will screw up. But if I just keep on merrily recursing I risk
  649.        blowing the stack.  */
  650.     if(STK_SIZE <= GC_MINSTACK)
  651.     {
  652.     STK_WARN("garbage-collect(major problem!)");
  653.     /* Perhaps I should longjmp() back to the start of the gc, then quit
  654.        totally?  */
  655.     return;
  656.     }
  657. #endif
  658.  
  659. again:
  660.     switch(VTYPE(val))
  661.     {
  662.     case V_Cons:
  663.     /* Attempts to walk though whole lists at a time (since Lisp
  664.        lists mainly link from the cdr).  */
  665.     GC_SET(val);
  666.     if(NILP(VCDR(val)))
  667.     {
  668.         /* End of a list. We can safely mark the car non-recursively.  */
  669.         val = VCAR(val);
  670.     }
  671.     else
  672.     {
  673.         MARKVAL(VCAR(val));
  674.         val = VCDR(val);
  675.     }
  676.     if(val && !GC_MARKEDP(val))
  677.         goto again;
  678.     break;
  679.  
  680.     case V_Vector:
  681.     {
  682.         register int i;
  683.         GC_SET(val);
  684.         for(i = 0; i < VVECT(val)->vc_Size; i++)
  685.         MARKVAL(VVECT(val)->vc_Array[i]);
  686.     }
  687.     break;
  688.  
  689.     case V_Symbol:
  690.     GC_SET(val);
  691.     MARKVAL(VSYM(val)->sym_Name);
  692.     MARKVAL(VSYM(val)->sym_Value);
  693.     MARKVAL(VSYM(val)->sym_Function);
  694.     MARKVAL(VSYM(val)->sym_PropList);
  695.     val = VSYM(val)->sym_Next;
  696.     if(val && !GC_MARKEDP(val))
  697.         goto again;
  698.     break;
  699.  
  700.     case V_Keytab:
  701.     {
  702.         register int i;
  703.         GC_SET(val);
  704.         for(i = 0; i < 128; i++)
  705.         {
  706.         register Key *ky = VKEYTAB(val)->kt_Keys[i];
  707.         while(ky)
  708.         {
  709.             MARKVAL(ky->ky_Form);
  710.             ky = ky->ky_Link.next;
  711.         }
  712.         }
  713.     }
  714.     break;
  715.  
  716.     case V_Keylist:
  717.     {
  718.         register Key *nxtky, *ky = (Key *)VKEYLIST(val)->kl_List.mlh_Head;
  719.         GC_SET(val);
  720.         while((nxtky = (Key *)ky->ky_Link.node.mln_Succ))
  721.         {
  722.         MARKVAL(ky->ky_Form);
  723.         ky = nxtky;
  724.         }
  725.     }
  726.     break;
  727.  
  728.     case V_Buffer:
  729.     GC_SET(val);
  730.     MARKVAL(VTX(val)->tx_FileName);
  731.     MARKVAL(VTX(val)->tx_BufferName);
  732.     MARKVAL(VTX(val)->tx_ModeName);
  733.     val = VTX(val)->tx_LocalVariables;
  734.     if(!GC_MARKEDP(val) && !NILP(val))
  735.         goto again;
  736.     break;
  737.  
  738.     case V_Window:
  739.     GC_SET(val);
  740.     MARKVAL(VWIN(val)->vw_Tx);
  741.     MARKVAL(VWIN(val)->vw_FontName);
  742. #ifdef HAVE_AMIGA
  743.     MARKVAL(VWIN(val)->vw_WindowSys.ws_ScreenName);
  744. #endif
  745.     val = VWIN(val)->vw_LocalVariables;
  746.     if(!GC_MARKEDP(val) && !NILP(val))
  747.         goto again;
  748.     break;
  749.  
  750.     case V_File:
  751.     GC_SET(val);
  752.     MARKVAL(VFILE(val)->lf_Name);
  753.     break;
  754.  
  755.     case V_Process:
  756.     GC_SET(val);
  757. #ifdef HAVE_UNIX
  758.     proc_mark(val);
  759. #endif
  760.     break;
  761.  
  762.     case V_Mark:
  763.     GC_SET(val);
  764.     if(!VMARK(val)->mk_Resident)
  765.     {
  766.         /* TXs don't get marked here. They should still be able to
  767.            be gc'd if there's marks pointing to them. The marks will
  768.            just get made non-resident.  */
  769.         MARKVAL(VMARK(val)->mk_File.name);
  770.     }
  771.     MARKVAL(VMARK(val)->mk_Pos);
  772.     break;
  773.  
  774.     case V_String:
  775.     case V_Number:
  776.     case V_Pos:
  777.     GC_SET(val);
  778.     break;
  779.  
  780.     case V_StaticString:
  781.     case V_Var:
  782.     case V_Subr0:
  783.     case V_Subr1:
  784.     case V_Subr2:
  785.     case V_Subr3:
  786.     case V_Subr4:
  787.     case V_Subr5:
  788.     case V_SubrN:
  789.     case V_SF:
  790.     }
  791. }
  792.  
  793. _PR VALUE var_garbage_threshold(VALUE val);
  794. DEFUN("garbage-threshold", var_garbage_threshold, subr_garbage_threshold, (VALUE val), V_Var, DOC_garbage_threshold) /*
  795. ::doc:garbage_threshold::
  796. The number of bytes of storage which must be used before a garbage-
  797. collection is triggered.
  798. ::end:: */
  799. {
  800.     if(val)
  801.     {
  802.     if(NUMBERP(val))
  803.         DataBeforeGC = VNUM(val);
  804.     return(NULL);
  805.     }
  806.     return(newnumber(DataBeforeGC));
  807. }
  808.  
  809. _PR VALUE var_idle_garbage_threshold(VALUE val);
  810. DEFUN("idle-garbage-threshold", var_idle_garbage_threshold, subr_idle_garbage_threshold, (VALUE val), V_Var, DOC_idle_garbage_threshold) /*
  811. ::doc:idle_garbage_threshold::
  812. The number of bytes of storage which must be used before a garbage-
  813. collection is triggered when the editor is idle.
  814. ::end:: */
  815. {
  816.     if(val)
  817.     {
  818.     if(NUMBERP(val))
  819.         IdleDataBeforeGC = VNUM(val);
  820.     return(NULL);
  821.     }
  822.     return(newnumber(IdleDataBeforeGC));
  823. }
  824.  
  825. _PR VALUE cmd_garbage_collect(VALUE noStats);
  826. DEFUN("garbage-collect", cmd_garbage_collect, subr_garbage_collect, (VALUE noStats), V_Subr1, DOC_garbage_collect) /*
  827. ::doc:garbage_collect::
  828. (garbage-collect)
  829. Scans all allocated storage for unusable data, and puts it onto the free-
  830. list. This is done automatically when the amount of storage used since the
  831. last garbage-collection is greater than `garbage-threshold'.
  832. ::end:: */
  833. {
  834.     int i;
  835.     GCVAL *gcv;
  836.     GCVALN *gcvn;
  837.     VW *vw;
  838.     struct LispCall *lc;
  839.  
  840. #ifdef GC_MONITOR_STK
  841.     int dummy;
  842.     StkHighTide = &dummy;
  843. #endif
  844.  
  845.     if(GCinhibit)
  846.     return(sym_nil);
  847.  
  848. #ifdef HAVE_UNIX
  849.     /* Make sure nothing plays with process structs while gc'ing  */
  850.     protect_procs();
  851. #endif
  852.  
  853.     streamputs(sym_t, "Garbage collecting...", FALSE);
  854.     setvwtitle(CurrVW);
  855. #ifdef HAVE_X11
  856.     XFlush(XDisplay);
  857. #endif
  858.  
  859.     /* mark static objects */
  860.     for(i = 0; i < NextStatic; i++)
  861.     MARKVAL(*StaticMarks[i]);
  862.     /* mark stack based objects protected from GC */
  863.     for(gcv = GCVStack; gcv; gcv = gcv->gcv_Next)
  864.     MARKVAL(*gcv->gcv_Value);
  865.     for(gcvn = GCVNStack; gcvn; gcvn = gcvn->gcv_Next)
  866.     {
  867.     for(i = 0; i < gcvn->gcv_N; i++)
  868.         MARKVAL(gcvn->gcv_First[i]);
  869.     }
  870.  
  871.     /* Don't want any open windows mysteriously vanishing so,  */
  872.     vw = ViewChain;
  873.     while(vw)
  874.     {
  875.     if(vw->vw_Window)
  876.         MARKVAL(vw);
  877.     vw = vw->vw_Next;
  878.     }
  879.  
  880. #ifdef AMIGA
  881.     /* Mark the strings in the menu strip.  */
  882.     ami_mark_menus();
  883. #endif
  884.  
  885.     /* have to mark the Lisp backtrace.  */
  886.     lc = LispCallStack;
  887.     while(lc)
  888.     {
  889.     MARKVAL(lc->lc_Fun);
  890.     MARKVAL(lc->lc_Args);
  891.     /* don't bother marking `lc_ArgsEvalledP' it's always `nil' or `t'  */
  892.     lc = lc->lc_Next;
  893.     }
  894.  
  895.     string_sweep();
  896.     number_sweep();
  897.     cons_sweep();
  898.     vector_sweep();
  899.     lpos_sweep();
  900.     symbol_sweep();
  901.     file_sweep();
  902.     buffer_sweep();
  903.     mark_sweep();
  904.     window_sweep();
  905.     keymap_sweep();
  906. #ifdef HAVE_UNIX
  907.     proc_sweep();
  908. #endif
  909.  
  910.     streamputs(sym_t, "done.", FALSE);
  911.     setvwtitle(CurrVW);
  912.     CurrVW->vw_Flags &= ~VWFF_REFRESH_STATUS;
  913. #ifdef HAVE_X11
  914.     XFlush(XDisplay);
  915. #endif
  916.  
  917. #ifdef HAVE_UNIX
  918.     /* put SIGCHLD back to normal */
  919.     unprotect_procs();
  920. #endif
  921.  
  922.     DataAfterGC = 0;
  923.  
  924. #ifdef GC_MONITOR_STK
  925.     fprintf(stderr, "gc: stack usage = %d\n",
  926.         ((int)&dummy) - (int)StkHighTide);
  927. #endif
  928.  
  929.     if(NILP(noStats))
  930.     {
  931.     return(list_5(
  932.       cmd_cons(newnumber(UsedCons), newnumber(AllocatedCons - UsedCons)),
  933.       cmd_cons(newnumber(UsedNumbers), newnumber(AllocatedNumbers - UsedNumbers - 1)),
  934.       cmd_cons(newnumber(UsedSymbols), newnumber(AllocatedSymbols - UsedSymbols)),
  935.       cmd_cons(newnumber(UsedLPos), newnumber(AllocatedLPos - UsedLPos)),
  936.       newnumber(UsedVectorSlots)));
  937.     }
  938.     return(sym_t);
  939. }
  940.  
  941. void
  942. values_init(void)
  943. {
  944. #ifdef STATIC_SMALL_NUMBERS
  945.     int i;
  946.     for(i = 0; i < STATIC_SMALL_NUMBERS; i++)
  947.     {
  948.     SmallNumbers[i].num_Type = V_Number;
  949.     SmallNumbers[i].num_Data.number = i;
  950.     }
  951. #endif
  952.     LispStrMem.sm_UseMallocChain = TRUE;
  953.     sm_init(&LispStrMem);
  954. }
  955. void
  956. values_init2(void)
  957. {
  958.     ADD_SUBR(subr_cons);
  959.     ADD_SUBR(subr_pos);
  960.     ADD_SUBR(subr_dup_pos);
  961.     ADD_SUBR(subr_garbage_threshold);
  962.     ADD_SUBR(subr_idle_garbage_threshold);
  963.     ADD_SUBR(subr_garbage_collect);
  964. }
  965. void
  966. values_kill(void)
  967. {
  968.     ConsBlk *cb = ConsBlkChain;
  969.     NumberBlk *nb = NumberBlkChain;
  970.     Vector *v = VectorChain;
  971.     LPosBlk *lb = LPosBlkChain;
  972.     while(cb)
  973.     {
  974.     ConsBlk *nxt = cb->cb_Next;
  975.     myfree(cb);
  976.     cb = nxt;
  977.     }
  978.     while(nb)
  979.     {
  980.     NumberBlk *nxt = nb->nb_Next;
  981.     myfree(nb);
  982.     nb = nxt;
  983.     }
  984.     while(v)
  985.     {
  986.     Vector *nxt = v->vc_Next;
  987.     myfree(v);
  988.     v = nxt;
  989.     }
  990.     while(lb)
  991.     {
  992.     LPosBlk *nxt = lb->lb_Next;
  993.     myfree(lb);
  994.     lb = nxt;
  995.     }
  996.     sm_kill(&LispStrMem);
  997. }
  998.