home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 8 / FreshFishVol8-CD1.bin / new / util / edit / jade / src / symbols.c < prev    next >
C/C++ Source or Header  |  1994-10-04  |  30KB  |  1,194 lines
  1. /* symbols.c -- Lisp symbol handling
  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. #include "regexp/regexp.h"
  23.  
  24. #include <string.h>
  25. #include <ctype.h>
  26. #include <stdlib.h>
  27.  
  28. /* The special value which signifies the end of a hash-bucket chain.
  29.    It can be any Lisp object which isn't a symbol.  */
  30. #define OB_NIL null_string
  31.  
  32. _PR void symbol_sweep(void);
  33. _PR int symbol_cmp(VALUE, VALUE);
  34. _PR void symbol_princ(VALUE, VALUE);
  35. _PR void symbol_print(VALUE, VALUE);
  36. _PR VALUE add_subr(XSubr *);
  37. _PR VALUE add_const_num(VALUE, long);
  38. _PR void intern_static(VALUE *, VALUE);
  39. _PR VALUE bind_symbol(VALUE, VALUE, VALUE);
  40. _PR void unbind_symbols(VALUE);
  41. _PR int symbols_init(void);
  42. _PR void symbols_kill(void);
  43.  
  44. /* Main storage of symbols.  */
  45. _PR VALUE obarray;
  46. VALUE obarray;
  47.  
  48. _PR VALUE sym_nil, sym_t;
  49. VALUE sym_nil, sym_t;
  50.  
  51. _PR VALUE sym_variable_documentation;
  52. VALUE sym_variable_documentation;
  53.  
  54. /* This value is stored in the cells of a symbol to denote a void object. */
  55. _PR VALUE void_value;
  56. static LispObject void_object = { V_Void };
  57. VALUE void_value = &void_object;
  58.  
  59. static SymbolBlk *symbol_block_chain;
  60. static Symbol *symbol_freelist;
  61. _PR int allocated_symbols, used_symbols;
  62. int allocated_symbols, used_symbols;
  63.  
  64. _PR VALUE cmd_make_symbol(VALUE);
  65. DEFUN("make-symbol", cmd_make_symbol, subr_make_symbol, (VALUE name), V_Subr1, DOC_make_symbol) /*
  66. ::doc:make_symbol::
  67. make-symbol NAME
  68.  
  69. Returns a new, uninterned, symbol with print-name NAME. It's value and
  70. function definition are both void and it has a nil property-list.
  71. ::end:: */
  72. {
  73.     VALUE sym;
  74.     DECLARE1(name, STRINGP);
  75.     if(!symbol_freelist)
  76.     {
  77.     SymbolBlk *sb = mycalloc(sizeof(SymbolBlk));
  78.     if(sb)
  79.     {
  80.         int i;
  81.         allocated_symbols += SYMBOLBLK_SIZE;
  82.         sb->sb_Next = symbol_block_chain;
  83.         symbol_block_chain = sb;
  84.         for(i = 0; i < (SYMBOLBLK_SIZE - 1); i++)
  85.         sb->sb_Symbols[i].sym_Next = VAL(&sb->sb_Symbols[i + 1]);
  86.         sb->sb_Symbols[i].sym_Next = VAL(symbol_freelist);
  87.         symbol_freelist = sb->sb_Symbols;
  88.     }
  89.     }
  90.     if((sym = VAL(symbol_freelist)))
  91.     {
  92.     symbol_freelist = VSYM(VSYM(sym)->sym_Next);
  93.     VSYM(sym)->sym_Next = NULL;
  94.     VSYM(sym)->sym_Type = V_Symbol;
  95.     VSYM(sym)->sym_Flags = 0;
  96.     VSYM(sym)->sym_Name = name;
  97.     VSYM(sym)->sym_Value = void_value;
  98.     VSYM(sym)->sym_Function = void_value;
  99.     VSYM(sym)->sym_PropList = sym_nil;
  100.     used_symbols++;
  101.     data_after_gc += sizeof(Symbol);
  102.     }
  103.     return(sym);
  104. }
  105.  
  106. void
  107. symbol_sweep(void)
  108. {
  109.     SymbolBlk *sb = symbol_block_chain;
  110.     symbol_freelist = NULL;
  111.     used_symbols = 0;
  112.     while(sb)
  113.     {
  114.     int i;
  115.     SymbolBlk *nxt = sb->sb_Next;
  116.     for(i = 0; i < SYMBOLBLK_SIZE; i++)
  117.     {
  118.         if(!GC_MARKEDP(VAL(&sb->sb_Symbols[i])))
  119.         {
  120.         sb->sb_Symbols[i].sym_Next = VAL(symbol_freelist);
  121.         symbol_freelist = &sb->sb_Symbols[i];
  122.         }
  123.         else
  124.         {
  125.         GC_CLR(VAL(&sb->sb_Symbols[i]));
  126.         used_symbols++;
  127.         }
  128.     }
  129.     sb = nxt;
  130.     }
  131. }
  132.  
  133. int
  134. symbol_cmp(VALUE v1, VALUE v2)
  135. {
  136.     if(VTYPE(v1) == VTYPE(v2))
  137.     return(!(VSYM(v1) == VSYM(v2)));
  138.     return(1);
  139. }
  140.  
  141. void
  142. symbol_princ(VALUE strm, VALUE obj)
  143. {
  144.     stream_puts(strm, VSTR(VSYM(obj)->sym_Name), -1, TRUE);
  145. }
  146.  
  147. void
  148. symbol_print(VALUE strm, VALUE obj)
  149. {
  150.     u_char *s = VSTR(VSYM(obj)->sym_Name);
  151.     u_char c;
  152.     while((c = *s++))
  153.     {
  154.     switch(c)
  155.     {
  156.     case ' ':
  157.     case '\t':
  158.     case '\n':
  159.     case '\f':
  160.     case '(':
  161.     case ')':
  162.     case '[':
  163.     case ']':
  164.     case '\'':
  165.     case '"':
  166.     case ';':
  167.     case '\\':
  168.     case '|':
  169.         stream_putc(strm, (int)'\\');
  170.         break;
  171.     default:
  172.         if(iscntrl(c))
  173.         stream_putc(strm, (int)'\\');
  174.         break;
  175.     }
  176.     stream_putc(strm, (int)c);
  177.     }
  178. }
  179.  
  180. VALUE
  181. add_subr(XSubr *subr)
  182. {
  183.     VALUE sym = cmd_intern(subr->subr_Name, obarray);
  184.     if(sym)
  185.     {
  186.     if(subr->subr_Type == V_Var)
  187.     {
  188.         VSYM(sym)->sym_Value = VAL(subr);
  189.         VSYM(sym)->sym_PropList = cmd_cons(sym_variable_documentation, cmd_cons(make_number(subr->subr_DocIndex), VSYM(sym)->sym_PropList));
  190.     }
  191.     else
  192.         VSYM(sym)->sym_Function = VAL(subr);
  193.     }
  194.     return(sym);
  195. }
  196.  
  197. VALUE
  198. add_const_num(VALUE name, long num)
  199. {
  200.     VALUE sym = cmd_intern(name, obarray);
  201.     if(sym)
  202.     {
  203.     VSYM(sym)->sym_Value = make_number(num);
  204.     VSYM(sym)->sym_Flags |= SF_CONSTANT;
  205.     }
  206.     return(sym);
  207. }
  208.  
  209. void
  210. intern_static(VALUE *symp, VALUE name)
  211. {
  212.     if((*symp = cmd_intern(name, sym_nil)))
  213.     mark_static(symp);
  214.     else
  215.     abort();
  216. }
  217.  
  218. static INLINE u_long
  219. hash(u_char *str)
  220. {
  221.     register u_long value = 0;
  222.     while(*str)
  223.     value = (value * 33) + *str++;
  224.     return(value);
  225. }
  226.  
  227. _PR VALUE cmd_make_obarray(VALUE);
  228. DEFUN("make-obarray", cmd_make_obarray, subr_make_obarray, (VALUE size), V_Subr1, DOC_make_obarray) /*
  229. ::doc:make_obarray::
  230. make-obarray SIZE
  231.  
  232. Creates a new structure for storing symbols in. This is basically a vector
  233. with a few slight differences (all elements initialised to a special value).
  234. ::end:: */
  235. {
  236.     DECLARE1(size, NUMBERP);
  237.     return(cmd_make_vector(size, OB_NIL));
  238. }
  239.  
  240. _PR VALUE cmd_find_symbol(VALUE, VALUE);
  241. DEFUN("find-symbol", cmd_find_symbol, subr_find_symbol, (VALUE name, VALUE ob), V_Subr2, DOC_find_symbol) /*
  242. ::doc:find_symbol::
  243. find-symbol NAME [OBARRAY]
  244.  
  245. Returns the symbol with print-name NAME, found by searching OBARRAY (or
  246. the default `obarray' if nil), or nil if no such symbol exists.
  247. ::end:: */
  248. {
  249.     int vsize;
  250.     DECLARE1(name, STRINGP);
  251.     if(!VECTORP(ob))
  252.     ob = obarray;
  253.     if((vsize = VVECT(ob)->vc_Size) == 0)
  254.     return(sym_nil);
  255.     ob = VVECT(ob)->vc_Array[hash(VSTR(name)) % vsize];
  256.     while(SYMBOLP(ob))
  257.     {
  258.     if(!strcmp(VSTR(name), VSTR(VSYM(ob)->sym_Name)))
  259.         return(ob);
  260.     ob = VSYM(ob)->sym_Next;
  261.     }
  262.     return(sym_nil);
  263. }
  264.  
  265. _PR VALUE cmd_intern_symbol(VALUE, VALUE);
  266. DEFUN("intern-symbol", cmd_intern_symbol, subr_intern_symbol, (VALUE sym, VALUE ob), V_Subr2, DOC_intern_symbol) /*
  267. ::doc:intern_symbol::
  268. intern-symbol SYMBOL [OBARRAY]
  269.  
  270. Stores SYMBOL in OBARRAY (or the default). If SYMBOL has already been interned
  271. somewhere an error is signalled.
  272. ::end:: */
  273. {
  274.     int vsize, hashid;
  275.     DECLARE1(sym, SYMBOLP);
  276.     if(VSYM(sym)->sym_Next != NULL)
  277.     {
  278.     cmd_signal(sym_error, list_2(MKSTR("Symbol is already interned"), sym));
  279.     return(NULL);
  280.     }
  281.     if(!VECTORP(ob))
  282.     ob = obarray;
  283.     if((vsize = VVECT(ob)->vc_Size) == 0)
  284.     return(NULL);
  285.     hashid = hash(VSTR(VSYM(sym)->sym_Name)) % vsize;
  286.     VSYM(sym)->sym_Next = VVECT(ob)->vc_Array[hashid];
  287.     VVECT(ob)->vc_Array[hashid] = sym;
  288.     return(sym);
  289. }
  290.  
  291. _PR VALUE cmd_intern(VALUE, VALUE);
  292. DEFUN("intern", cmd_intern, subr_intern, (VALUE name, VALUE ob), V_Subr2, DOC_intern) /*
  293. ::doc:intern::
  294. intern NAME [OBARRAY]
  295.  
  296. If a symbol with print-name exists in OBARRAY (or the default) return it.
  297. Else use `(make-symbol NAME)' to create a new symbol, intern that into the
  298. OBARRAY, then return it.
  299. ::end:: */
  300. {
  301.     VALUE sym;
  302.     DECLARE1(name, STRINGP);
  303.     if(!(sym = cmd_find_symbol(name, ob))
  304.        || (NILP(sym) && strcmp(VSTR(name), "nil")))
  305.     {
  306.     sym = cmd_make_symbol(name);
  307.     if(sym)
  308.         return(cmd_intern_symbol(sym, ob));
  309.     }
  310.     return(sym);
  311. }
  312.  
  313. _PR VALUE cmd_unintern(VALUE, VALUE);
  314. DEFUN("unintern", cmd_unintern, subr_unintern, (VALUE sym, VALUE ob), V_Subr2, DOC_unintern) /*
  315. ::doc:unintern::
  316. unintern SYMBOL [OBARRAY]
  317.  
  318. Removes SYMBOL from OBARRAY (or the default). Use this with caution.
  319. ::end:: */
  320. {
  321.     VALUE list;
  322.     int vsize, hashid;
  323.     DECLARE1(sym, SYMBOLP);
  324.     if(!VECTORP(ob))
  325.     ob = obarray;
  326.     if((vsize = VVECT(ob)->vc_Size) == 0)
  327.     return(NULL);
  328.     hashid = hash(VSTR(VSYM(sym)->sym_Name)) % vsize;
  329.     list = VVECT(ob)->vc_Array[hashid];