home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS - Coast to Coast / simteldosarchivecoasttocoast2.iso / ddjmag / ddj9209.zip / CLISP.ASC next >
Text File  |  1992-08-10  |  7KB  |  20 lines
  1. _AN IMPROVED LISP-STYLE LIBRARY FOR C_
  2. by Douglas Chubb
  3.  
  4.  
  5. [LISTING ONE]
  6.  
  7. /* 
  8.    File MEMORY.C, part of C-LISP Library written by Douglas Chubb, 1991-92.
  9.    Memory management using pointers and two marking bits as part of Object "type" 
  10.    declaration.  
  11. */
  12.  
  13. /** Memory Allocation and Deallocation Functions **/
  14. /* Include Files */
  15. #include <stdio.h>
  16. #include <stdlib.h>
  17. #include "lisp-header.h"
  18. #include "int-lisp-syms.h"
  19. /** Variables **//* memory_pointer_list -- pointer to linked list of memory storage blocks */Pointer memory_pointer_list = NULL;/* temp_pointer_list -- pointer to linked list of temporally allocated blocks */Pointer temp_pointer_list = NULL;/** Functions **/void initialize_garbage_collector (void)  {      memory_pointer_list = NULL;      temp_pointer_list = NULL;  }  /* push_memory_pointer -- push pointer to block on 'memory_pointer_list' */void push_memory_pointer (Pointer p)  {      * (Pointer *) p = memory_pointer_list;      memory_pointer_list = p;  }/* pop_memory_pointer -- pop pointer to block from 'memory_pointer_list' */Pointer pop_memory_pointer (void)  {      Pointer p;      p = memory_pointer_list;      if (p != NULL)        {            memory_pointer_list = * (Pointer *) p;            return (p);        }      else          error ("pop_memory_pointer: 'memory_pointer_list' is empty");   }/* push_temp_pointer -- push pointer to block on 'memory_pointer_list' */void push_temp_pointer (Pointer p)  {      * (Pointer *) p = temp_pointer_list;      temp_pointer_list = p;  }/* pop_temp_pointer -- pop pointer to block from 'temp_pointer_list' */Pointer pop_temp_pointer (void)  {      Pointer p;      p = temp_pointer_list;      if (p != NULL)        {            temp_pointer_list = * (Pointer *) p;            return (p);        }      else          error ("pop_temp_pointer: 'temp_pointer_list' is empty");   }/* collect_garbage -- 'safe_free' all malloc'ed data */void collect_garbage (void)  {      Pointer p, pp;      if(memory_pointer_list == NULL)             error ("collect_garbage: memory_pointer_list empty'");    else      {           temp_pointer_list = NULL;                 while (memory_pointer_list != NULL)              {                  p = pop_memory_pointer();                  pp = (char *) p + sizeof (Pointer);                  safe_free (pp);              }                   while(temp_pointer_list != NULL)                push_memory_pointer(pop_temp_pointer());              /* fill marked_block stack  */      }   }/* "C" 'free' with first byte of block set to zero */void safe_free (void *p)  {      if(type((char *) p) <= 7)         {             * (char *) p = (char) 0;       /* free block, including header, for link in memory_pointer_list */             free ((char *) p - sizeof (Pointer));          }       else        /* maybe store data temporarily on 'temp_pointer_list'  */            push_temp_pointer((char *) p - sizeof (Pointer));  }/* safe_malloc -- Unix 'malloc' wrapped inside test for sufficient memory */Pointer safe_malloc (size_t size)  {      Pointer memory;      static long num_calls = 0;      /* allocate block, including header for link in 'memory_pointer_list' */      memory = malloc (size + sizeof (Pointer));      num_calls++;      /*   total_space += size;   */      if (memory != NULL)        {            push_memory_pointer (memory);              /* return beginning of user data block */          return ((char *) memory + sizeof (Pointer));        }      else          error ("safe_malloc: out of memory"      " (number malloc calls = %ld) \n ",  num_calls);  }/* mark_object -- recursively marks object "type" negative to save object                   iff object is either "unmarked" or, if "marked", object has                  not been changed by 'put_prop' or 'remprop' functions. */void mark_object (Object obj)  {      if (obj == NULL ||         (type(obj) > 7 && (type(obj) & '\040') == 0))               return;                                 /* 'obj' marked, but NOT changed => return */        else        {            type(obj) = ntype(obj);            mark2_object(obj);            type(obj) = '\100' | ntype(obj);  /* remove "changed = 040" tag */        }  }/* mark2_object -- recursively marks the object "type" negative  */void mark2_object (Object obj)  {      if (obj == NULL)          return;       else          switch (ntype(obj))            {                case SYMBOL:                    if(type(obj) > 7 && (type(obj) & '\040') == 0)                         return;                      else                      {                          type(obj) = '\100' | ntype(obj);                          if(get_prop(obj, "pn") == NULL)                            symbol_plist(obj) =                                 first_put(list(make_string("pn"),                                                          make_string(symbol(obj)->print_name),                             T_EOF), symbol_plist(obj));                                                mark2_object(symbol_plist(obj));                        mark2_object(symbol(obj)->value);                      }                    break;                case STRING:                case INTEGER:                case FUNCTION:                    break;                case PAIR:                    type(obj) = type(obj) | '\100';  /* mark type negative */                    mark2_object (first(obj));                    mark2_object (but_first(obj));                    break;                default:                    error ("\nmark2_object: not standard object: %d", type(obj));                    break;            }          type(obj) = type(obj) | '\100';  /* mark type negative */  }/* unmark_object -- recursively marks Object-type positve to free Object */void unmark_object (Object obj)  {      if (obj == NULL || type(obj) <= 7)          return;      else          switch (ntype(obj))            {                case SYMBOL:                    if(type(obj) == ntype(obj))                        return;                    else                      {                          type(obj) = ntype(obj);                            unmark_object(symbol_plist(obj));                        unmark_object(symbol(obj)->value);                        symbol(obj)->print_name =                         string(get_prop(obj, "pn"));                      }                    break;                case STRING:                case INTEGER:                case FUNCTION:                    break;                case PAIR:                    type(obj) = ntype(obj);  /* remove protect bit */                    unmark_object (first(obj));                    unmark_object (but_first(obj));                    break;                default:                    error ("unmark_object: not standard object");                    break;            }          type(obj) = ntype(obj);  /* remove protect bit */   }  ng(symbol(obj)->print_name),                             T_EOF), symbol_plist(obj));                                                mark2_object(symbol_plist(obj));                        mark2_object(symbol(obj)->value);                      }                    break;                case STRING:                case INTEGER:                case FUNCTION:                    break;                case PAIR:                    type(obj) = type(obj) | '\100';  /* mark type negative */                    mark2_object (first(obj));  ~}P#589n)B]^p=ab3UVWij6SWZ[\(MQ{j :LS!chijk5X\"#$l 8JQ|[`ab
  20.