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