home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 5 / FreshFish_July-August1994.bin / bbs / util / jade-3.0.lha / Jade / src / symbols.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-04-19  |  26.1 KB  |  1,050 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. _PR void symbol_sweep(void);
  29. _PR int symbol_cmp(VALUE, VALUE);
  30. _PR void symbol_princ(VALUE, VALUE);
  31. _PR void symbol_print(VALUE, VALUE);
  32. _PR VALUE addsubr(VALUE);
  33. _PR VALUE addconstnum(VALUE, long);
  34. _PR void internstatic(VALUE *, VALUE);
  35. _PR VALUE bindsymbol(VALUE, VALUE, VALUE);
  36. _PR void unbindsymbols(VALUE);
  37. _PR int symbols_init(void);
  38. _PR void symbols_kill(void);
  39.  
  40. /*
  41.  * Main storage of symbols
  42.  */
  43. _PR VALUE ObArray;
  44. VALUE ObArray;
  45.  
  46. _PR VALUE sym_nil, sym_t;
  47. VALUE sym_nil, sym_t;
  48.  
  49. _PR VALUE sym_variable_documentation;
  50. VALUE sym_variable_documentation;
  51.  
  52. static SymbolBlk *SymbolBlkChain;
  53. static Symbol *SymbolFreeList;
  54. _PR int AllocatedSymbols, UsedSymbols;
  55. int AllocatedSymbols, UsedSymbols;
  56.  
  57. _PR VALUE cmd_make_symbol(VALUE);
  58. DEFUN("make-symbol", cmd_make_symbol, subr_make_symbol, (VALUE name), V_Subr1, DOC_make_symbol) /*
  59. ::doc:make_symbol::
  60. (make-symbol NAME)
  61. Returns a new, uninterned, symbol with print-name NAME. It's value and
  62. function definition are both void and it has a nil property-list.
  63. ::end:: */
  64. {
  65.     VALUE sym;
  66.     DECLARE1(name, STRINGP);
  67.     if(!SymbolFreeList)
  68.     {
  69.     SymbolBlk *sb = mycalloc(sizeof(SymbolBlk));
  70.     if(sb)
  71.     {
  72.         int i;
  73.         AllocatedSymbols += SYMBOLBLK_SIZE;
  74.         sb->sb_Next = SymbolBlkChain;
  75.         SymbolBlkChain = sb;
  76.         for(i = 0; i < (SYMBOLBLK_SIZE - 1); i++)
  77.         sb->sb_Symbols[i].sym_Next = &sb->sb_Symbols[i + 1];
  78.         sb->sb_Symbols[i].sym_Next = SymbolFreeList;
  79.         SymbolFreeList = sb->sb_Symbols;
  80.     }
  81.     }
  82.     if((sym = SymbolFreeList))
  83.     {
  84.     SymbolFreeList = VSYM(sym)->sym_Next;
  85.     VSYM(sym)->sym_Next = NULL;
  86.     VSYM(sym)->sym_Type = V_Symbol;
  87.     VSYM(sym)->sym_Flags = 0;
  88.     VSYM(sym)->sym_Name = name;
  89.     VSYM(sym)->sym_Value = NULL;
  90.     VSYM(sym)->sym_Function = NULL;
  91.     VSYM(sym)->sym_PropList = sym_nil;
  92.     UsedSymbols++;
  93.     DataAfterGC += sizeof(Symbol);
  94.     }
  95.     return(sym);
  96. }
  97. void
  98. symbol_sweep(void)
  99. {
  100.     SymbolBlk *sb = SymbolBlkChain;
  101.     SymbolFreeList = NULL;
  102.     UsedSymbols = 0;
  103.     while(sb)
  104.     {
  105.     int i;
  106.     SymbolBlk *nxt = sb->sb_Next;
  107.     for(i = 0; i < SYMBOLBLK_SIZE; i++)
  108.     {
  109.         if(!GC_MARKEDP(&sb->sb_Symbols[i]))
  110.         {
  111.         sb->sb_Symbols[i].sym_Next = SymbolFreeList;
  112.         SymbolFreeList = &sb->sb_Symbols[i];
  113.         }
  114.         else
  115.         {
  116.         GC_CLR(&sb->sb_Symbols[i]);
  117.         UsedSymbols++;
  118.         }
  119.     }
  120.     sb = nxt;
  121.     }
  122. }
  123. int
  124. symbol_cmp(VALUE v1, VALUE v2)
  125. {
  126.     if(VTYPE(v1) == VTYPE(v2))
  127.     return(!(VSYM(v1) == VSYM(v2)));
  128.     return(1);
  129. }
  130. void
  131. symbol_princ(VALUE strm, VALUE obj)
  132. {
  133.     streamputs(strm, VSTR(VSYM(obj)->sym_Name), TRUE);
  134. }
  135. void
  136. symbol_print(VALUE strm, VALUE obj)
  137. {
  138.     u_char *s = VSTR(VSYM(obj)->sym_Name);
  139.     u_char c;
  140.     while((c = *s++))
  141.     {
  142.     switch(c)
  143.     {
  144.     case ' ':
  145.     case '\t':
  146.     case '\n':
  147.     case '\f':
  148.     case '(':
  149.     case ')':
  150.     case '[':
  151.     case ']':
  152.     case '\'':
  153.     case '"':
  154.     case ';':
  155.     case '\\':
  156.     case '|':
  157.         streamputc(strm, (int)'\\');
  158.         break;
  159.     default:
  160.         if(iscntrl(c))
  161.         streamputc(strm, (int)'\\');
  162.         break;
  163.     }
  164.     streamputc(strm, (int)c);
  165.     }
  166. }
  167.  
  168. VALUE
  169. addsubr(VALUE subr)
  170. {
  171.     VALUE sym = cmd_intern(VSUBR(subr)->subr_Name, ObArray);
  172.     if(sym)
  173.     {
  174.     if(VSUBR(subr)->subr_Type == V_Var)
  175.     {
  176.         VSYM(sym)->sym_Value = subr;
  177.         VSYM(sym)->sym_PropList = cmd_cons(sym_variable_documentation, cmd_cons(newnumber(VSUBR(subr)->subr_DocIndex), VSYM(sym)->sym_PropList));
  178.     }
  179.     else
  180.         VSYM(sym)->sym_Function = subr;
  181.     }
  182.     return(sym);
  183. }
  184. VALUE
  185. addconstnum(VALUE name, long num)
  186. {
  187.     VALUE sym = cmd_intern(name, ObArray);
  188.     if(sym)
  189.     {
  190.     VSYM(sym)->sym_Value = newnumber(num);
  191.     VSYM(sym)->sym_Flags |= SF_CONSTANT;
  192.     }
  193.     return(sym);
  194. }
  195. void
  196. internstatic(VALUE *symp, VALUE name)
  197. {
  198.     if((*symp = cmd_intern(name, sym_nil)))
  199.     markstatic(symp);
  200.     else
  201.     abort();
  202. }
  203.  
  204. static INLINE u_long
  205. hash(u_char *str)
  206. {
  207.     u_long value = 0;
  208.     while(*str)
  209.     value = (value * 33) + *str++;
  210.     return(value);
  211. }
  212.  
  213. _PR VALUE cmd_make_obarray(VALUE);
  214. DEFUN("make-obarray", cmd_make_obarray, subr_make_obarray, (VALUE size), V_Subr1, DOC_make_obarray) /*
  215. ::doc:make_obarray::
  216. (make-obarray SIZE)
  217. Creates a new structure for storing symbols in. This is basically a vector
  218. with a few slight differences (all pointers initialised to NULL).
  219. ::end:: */
  220. {
  221.     DECLARE1(size, NUMBERP);
  222.     return(newvector(VNUM(size)));
  223. }
  224.  
  225. _PR VALUE cmd_find_symbol(VALUE, VALUE);
  226. DEFUN("find-symbol", cmd_find_symbol, subr_find_symbol, (VALUE name, VALUE ob), V_Subr2, DOC_find_symbol) /*
  227. ::doc:find_symbol::
  228. (find-symbol NAME [OBARRAY])
  229. Returns the symbol with print-name NAME, found by searching OBARRAY (or
  230. the default `obarray' if nil), or nil if no such symbol exists.
  231. ::end:: */
  232. {
  233.     int vsize;
  234.     DECLARE1(name, STRINGP);
  235.     if(!VECTORP(ob))
  236.     ob = ObArray;
  237.     if((vsize = VVECT(ob)->vc_Size) == 0)
  238.     return(sym_nil);
  239.     ob = VVECT(ob)->vc_Array[hash(VSTR(name)) % vsize];
  240.     while(ob && SYMBOLP(ob))
  241.     {
  242.     if(!strcmp(VSTR(name), VSTR(VSYM(ob)->sym_Name)))
  243.         return(ob);
  244.     ob = VSYM(ob)->sym_Next;
  245.     }
  246.     return(sym_nil);
  247. }
  248.  
  249. _PR VALUE cmd_intern_symbol(VALUE, VALUE);
  250. DEFUN("intern-symbol", cmd_intern_symbol, subr_intern_symbol, (VALUE sym, VALUE ob), V_Subr2, DOC_intern_symbol) /*
  251. ::doc:intern_symbol::
  252. (intern-symbol SYMBOL [OBARRAY])
  253. Stores SYMBOL in OBARRAY (or the default). If SYMBOL has already been interned
  254. somewhere an error is signalled.
  255. ::end:: */
  256. {
  257.     int vsize, hashid;
  258.     DECLARE1(sym, SYMBOLP);
  259.     if(VSYM(sym)->sym_Flags & SF_INTERNED)
  260.     {
  261.     cmd_signal(sym_error, list_2(MKSTR("Symbol is already interned"), sym));
  262.     return(NULL);
  263.     }
  264.     if(!VECTORP(ob))
  265.     ob = ObArray;
  266.     if((vsize = VVECT(ob)->vc_Size) == 0)
  267.     return(NULL);
  268.     hashid = hash(VSTR(VSYM(sym)->sym_Name)) % vsize;
  269.     VSYM(sym)->sym_Next = VVECT(ob)->vc_Array[hashid];
  270.     VVECT(ob)->vc_Array[hashid] = sym;
  271.     VSYM(sym)->sym_Flags |= SF_INTERNED;
  272.     return(sym);
  273. }
  274.  
  275. _PR VALUE cmd_intern(VALUE, VALUE);
  276. DEFUN("intern", cmd_intern, subr_intern, (VALUE name, VALUE ob), V_Subr2, DOC_intern) /*
  277. ::doc:intern::
  278. (intern NAME [OBARRAY])
  279. If a symbol with print-name exists in OBARRAY (or the default) return it.
  280. Else use `(make-symbol NAME)' to create a new symbol, intern that into the
  281. OBARRAY, then return it.
  282. ::end:: */
  283. {
  284.     VALUE sym;
  285.     DECLARE1(name, STRINGP);
  286.     if(!(sym = cmd_find_symbol(name, ob))
  287.        || (NILP(sym) && strcmp(VSTR(name), "nil")))
  288.     {
  289.     sym = cmd_make_symbol(name);
  290.     if(sym)
  291.         return(cmd_intern_symbol(sym, ob));
  292.     }
  293.     return(sym);
  294. }
  295.  
  296. _PR VALUE cmd_unintern(VALUE, VALUE);
  297. DEFUN("unintern", cmd_unintern, subr_unintern, (VALUE sym, VALUE ob), V_Subr2, DOC_unintern) /*
  298. ::doc:unintern::
  299. (unintern SYMBOL [OBARRAY])
  300. Removes SYMBOL from OBARRAY (or the default). Use this with caution.
  301. ::end:: */
  302. {
  303.     Symbol *list;
  304.     int vsize, hashid;
  305.     DECLARE1(sym, SYMBOLP);
  306.     if(!VECTORP(ob))
  307.     ob = ObArray;
  308.     if((vsize = VVECT(ob)->vc_Size) == 0)
  309.     return(NULL);
  310.     hashid = hash(VSTR(VSYM(sym)->sym_Name)) % vsize;
  311.     list = VVECT(ob)->vc_Array[hashid];
  312.     VVECT(ob)->vc_Array[hashid] = NULL;
  313.     while(list)
  314.     {
  315.     Symbol *nxt = list->sym_Next;
  316.     if(list != sym)
  317.     {
  318.         list->sym_Next = VVECT(ob)->vc_Array[hashid];
  319.         VVECT(ob)->vc_Array[hashid] = list;
  320.     }
  321.     list = nxt;
  322.     }
  323.     /* This is probably unnecessary. */
  324.     VSYM(sym)->sym_Next = NULL;
  325.     VSYM(sym)->sym_Flags &= ~SF_INTERNED;
  326.     return(sym);
  327. }
  328.  
  329. /*
  330.  * This give a symbol a new value, saving the old one onto the front of
  331.  * the list `oldList'. `oldList' is structured like,
  332.  * ((symbol . oldvalue) ...)
  333.  * returns the new version of `oldList'
  334.  */
  335. VALUE
  336. bindsymbol(VALUE oldList, VALUE symbol, VALUE newVal)
  337. {
  338.     /* Oops, this doesn't work with buffer or window local symbols (or at
  339.        least, it doesn't work how you expect, it always binds to the default
  340.        value!). This needs fixing.  */
  341.     VALUE newbl = cmd_cons(cmd_cons(symbol, sym_nil), oldList);
  342.     if(newbl)
  343.     {
  344.     if(VSYM(symbol)->sym_Value && VTYPEP(VSYM(symbol)->sym_Value, V_Var))
  345.     {
  346.         /* Special code for binding V_Var variables */
  347.         VCDR(VCAR(newbl)) = VVARFUN(VSYM(symbol)->sym_Value)(NULL);
  348.         VVARFUN(VSYM(symbol)->sym_Value)(newVal);
  349.     }
  350.     else
  351.     {
  352.         VCDR(VCAR(newbl)) = VSYM(symbol)->sym_Value;
  353.         VSYM(symbol)->sym_Value = newVal;
  354.     }
  355.     }
  356.     return(newbl);
  357. }
  358.  
  359. /*
  360.  * Undoes what the above function does.
  361.  */
  362. void
  363. unbindsymbols(VALUE oldList)
  364. {
  365.     while(CONSP(oldList))
  366.     {
  367.     VALUE car = VCAR(oldList);
  368.     VALUE sym = VCAR(car);
  369.     if(VSYM(sym)->sym_Value && VTYPEP(VSYM(sym)->sym_Value, V_Var))
  370.         /* Unbind a V_Var variable */
  371.         VVARFUN(VSYM(sym)->sym_Value)(VCDR(car));
  372.     else
  373.         VSYM(sym)->sym_Value = VCDR(car);
  374.     oldList = VCDR(oldList);
  375.     }
  376. }
  377.  
  378. _PR VALUE cmd_symbol_value(VALUE);
  379. DEFUN("symbol-value", cmd_symbol_value, subr_symbol_value, (VALUE sym), V_Subr1, DOC_symbol_value) /*
  380. ::doc:symbol_value::
  381. (symbol-value SYMBOL)
  382. Returns the value of SYMBOL, if SYMBOL is flagged as having buffer-local
  383. values look for one of those first.
  384. ::end:: */
  385. {
  386.     VALUE val;
  387.     DECLARE1(sym, SYMBOLP);
  388.     if((VSYM(sym)->sym_Flags & SF_BUFFER_LOCAL)
  389.        && (val = cmd_assq(sym, CurrVW->vw_Tx->tx_LocalVariables))
  390.        && CONSP(val))
  391.     {
  392.     val = VCDR(val);
  393.     }
  394.     else if((VSYM(sym)->sym_Flags & SF_WIN_LOCAL)
  395.         && (val = cmd_assq(sym, CurrVW->vw_LocalVariables))
  396.         && CONSP(val))
  397.     {
  398.     val = VCDR(val);
  399.     }
  400.     else
  401.     val = VSYM(sym)->sym_Value;
  402.     if(val && (VTYPE(val) == V_Var))
  403.     val = VVARFUN(val)(NULL);
  404.     return(val);
  405. }
  406.  
  407. _PR VALUE cmd_set(VALUE, VALUE);
  408. DEFUN("set", cmd_set, subr_set, (VALUE sym, VALUE val), V_Subr2, DOC_set) /*
  409. ::doc:set::
  410. (set SYMBOL VALUE)
  411. Sets the value of SYMBOL to VALUE, if SYMBOL is flagged as having buffer-
  412. local values then set that value. Returns VALUE.
  413. ::end:: */
  414. {
  415.     DECLARE1(sym, SYMBOLP);
  416.     if(VSYM(sym)->sym_Flags & SF_CONSTANT)
  417.     return(cmd_signal(sym_setting_constant, LIST_1(sym)));
  418.     if(VSYM(sym)->sym_Flags & SF_BUFFER_LOCAL)
  419.     {
  420.     TX *tx = CurrVW->vw_Tx;
  421.     VALUE tmp;
  422.     if((tmp = cmd_assq(sym, tx->tx_LocalVariables)) && CONSP(tmp))
  423.         VCDR(tmp) = val;
  424.     else
  425.         tx->tx_LocalVariables = cmd_cons(cmd_cons(sym, val), tx->tx_LocalVariables);
  426.     return(val);
  427.     }
  428.     else if(VSYM(sym)->sym_Flags & SF_WIN_LOCAL)
  429.     {
  430.     VALUE tmp;
  431.     if((tmp = cmd_assq(sym, CurrVW->vw_LocalVariables)) && CONSP(tmp))
  432.         VCDR(tmp) = val;
  433.     else
  434.         CurrVW->vw_LocalVariables = cmd_cons(cmd_cons(sym, val), CurrVW->vw_LocalVariables);
  435.     return(val);
  436.     }
  437.     if(VSYM(sym)->sym_Value && (VTYPE(VSYM(sym)->sym_Value) == V_Var))
  438.     VVARFUN(VSYM(sym)->sym_Value)(val);
  439.     else
  440.     VSYM(sym)->sym_Value = val;
  441.     return(val);
  442. }
  443.  
  444. _PR VALUE cmd_setplist(VALUE, VALUE);
  445. DEFUN("setplist", cmd_setplist, subr_setplist, (VALUE sym, VALUE prop), V_Subr2, DOC_setplist) /*
  446. ::doc:setplist::
  447. (setplist SYMBOL PROP-LIST)
  448. Sets the property list of SYMBOL to PROP-LIST, returns PROP-LIST.
  449. ::end:: */
  450. {
  451.     DECLARE1(sym, SYMBOLP);
  452.     VSYM(sym)->sym_PropList = prop;
  453.     return(prop);
  454. }
  455.  
  456. _PR VALUE cmd_symbol_name(VALUE);
  457. DEFUN("symbol-name", cmd_symbol_name, subr_symbol_name, (VALUE sym), V_Subr1, DOC_symbol_name) /*
  458. ::doc:symbol_name::
  459. (symbol-name SYMBOL)
  460. Returns the print-name of SYMBOL.
  461. ::end:: */
  462. {
  463.     DECLARE1(sym, SYMBOLP);
  464.     return(VSYM(sym)->sym_Name);
  465. }
  466.  
  467. _PR VALUE cmd_symbol_function(VALUE);
  468. DEFUN("symbol-function", cmd_symbol_function, subr_symbol_function, (VALUE sym), V_Subr1, DOC_symbol_function) /*
  469. ::doc:symbol_function::
  470. (symbol-function SYMBOL)
  471. Returns the function value of SYMBOL.
  472. ::end:: */
  473. {
  474.     DECLARE1(sym, SYMBOLP);
  475.     return(VSYM(sym)->sym_Function);
  476. }
  477.  
  478. _PR VALUE cmd_fboundp(VALUE);
  479. DEFUN("fboundp", cmd_fboundp, subr_fboundp, (VALUE sym), V_Subr1, DOC_fboundp) /*
  480. ::doc:fboundp::
  481. (fboundp SYMBOL)
  482. Returns t if the function-slot of SYMBOL has a value.
  483. ::end:: */
  484. {
  485.     DECLARE1(sym, SYMBOLP);
  486.     if(cmd_symbol_function(sym))
  487.     return(sym_t);
  488.     return(sym_nil);
  489. }
  490.  
  491. _PR VALUE cmd_boundp(VALUE);
  492. DEFUN("boundp", cmd_boundp, subr_boundp, (VALUE sym), V_Subr1, DOC_boundp) /*
  493. ::doc:boundp::
  494. (boundp SYMBOL)
  495. Returns t if SYMBOL has a value as a variable.
  496. ::end:: */
  497. {
  498.     if(cmd_symbol_value(sym))
  499.     return(sym_t);
  500.     return(sym_nil);
  501. }
  502.  
  503. _PR VALUE cmd_symbol_plist(VALUE);
  504. DEFUN("symbol-plist", cmd_symbol_plist, subr_symbol_plist, (VALUE sym), V_Subr1, DOC_symbol_plist) /*
  505. ::doc:symbol_plist::
  506. (symbol-plist SYMBOL)
  507. Returns the property-list of SYMBOL.
  508. ::end:: */
  509. {
  510.     DECLARE1(sym, SYMBOLP);
  511.     return(VSYM(sym)->sym_PropList);
  512. }
  513.  
  514. _PR VALUE cmd_gensym(void);
  515. DEFUN("gensym", cmd_gensym, subr_gensym, (void), V_Subr0, DOC_gensym) /*
  516. ::doc:gensym::
  517. (gensym)
  518. Returns a new (non-interned) symbol with a unique print name.
  519. ::end:: */
  520. {
  521.     static int counter;
  522.     char buf[20];
  523.     counter++;
  524.     sprintf(buf, "G%04d", counter);
  525.     return(cmd_make_symbol(valstrdup(buf)));
  526. }
  527.  
  528. _PR VALUE cmd_symbolp(VALUE);
  529. DEFUN("symbolp", cmd_symbolp, subr_symbolp, (VALUE sym), V_Subr1, DOC_symbolp) /*
  530. ::doc:symbolp::
  531. (symbolp ARG)
  532. Returns t if ARG is a symbol.
  533. ::end:: */
  534. {
  535.     if(SYMBOLP(sym))
  536.     return(sym_t);
  537.     return(sym_nil);
  538. }
  539.  
  540. _PR VALUE cmd_setq(VALUE);
  541. DEFUN("setq", cmd_setq, subr_setq, (VALUE args), V_SF, DOC_setq) /*
  542. ::doc:setq::
  543. (setq { SYMBOL FORM }...) <SPECIAL-FORM>
  544. Sets the value of each SYMBOL to the value of its corresponding FORM
  545. evaluated, returns the value of the last evaluation. ie,
  546.   (setq x 1 y (symbol-name 'nil))
  547.    => "nil"
  548.   x
  549.    => 1
  550.   y
  551.    => "nil"
  552. ::end:: */
  553. {
  554.     VALUE res = sym_nil;
  555.     GCVAL gcv_args;
  556.     PUSHGC(gcv_args, args);
  557.     while(CONSP(args) && CONSP(VCDR(args)) && SYMBOLP(VCAR(args)))
  558.     {
  559.     if(!(res = cmd_eval(VCAR(VCDR(args)))))
  560.         goto end;
  561.     if(!cmd_set(VCAR(args), res))
  562.     {
  563.         res = NULL;
  564.         goto end;
  565.     }
  566.     args = VCDR(VCDR(args));
  567.     }
  568. end:
  569.     POPGC;
  570.     return(res);
  571. }
  572.  
  573. _PR VALUE cmd_fset(VALUE, VALUE);
  574. DEFUN("fset", cmd_fset, subr_fset, (VALUE sym, VALUE val), V_Subr2, DOC_fset) /*
  575. ::doc:fset::
  576. (fset SYMBOL VALUE)
  577. Sets the function value of SYMBOL to VALUE, returns VALUE.
  578. ::end:: */
  579. {
  580.     DECLARE1(sym, SYMBOLP);
  581.     VSYM(sym)->sym_Function = val;
  582.     return(val);
  583. }
  584.  
  585. _PR VALUE cmd_makunbound(VALUE);
  586. DEFUN("makunbound", cmd_makunbound, subr_makunbound, (VALUE sym), V_Subr1, DOC_makunbound) /*
  587. ::doc:makunbound::
  588. (makunbound SYMBOL)
  589. Make SYMBOL have no value as a variable.
  590. ::end:: */
  591. {
  592.     DECLARE1(sym, SYMBOLP);
  593.     VSYM(sym)->sym_Value = NULL;
  594.     return(sym);
  595. }
  596.  
  597. _PR VALUE cmd_fmakunbound(VALUE);
  598. DEFUN("fmakunbound", cmd_fmakunbound, subr_fmakunbound, (VALUE sym), V_Subr1, DOC_fmakunbound) /*
  599. ::doc:fmakunbound::
  600. (fmakunbound SYMBOL)
  601. Make the function slot of SYMBOL have no value.
  602. ::end:: */
  603. {
  604.     DECLARE1(sym, SYMBOLP);
  605.     VSYM(sym)->sym_Function = NULL;
  606.     return(sym);
  607. }
  608.  
  609. _PR VALUE cmd_let(VALUE);
  610. DEFUN("let", cmd_let, subr_let, (VALUE args), V_SF, DOC_let) /*
  611. ::doc:let::
  612. (let (SYMBOL-BINDINGS...) BODY...) <SPECIAL-FORM>
  613. Binds temporary values to symbols while BODY is being evaluated.
  614. Each SYMBOL-BINDING is either a symbol, in which case that symbol is bound to
  615. nil, or a list. The symbol at the head of this list is bound to the progn'ed
  616. value of the forms making up the tail. ie,
  617.   (let
  618.       ((foo 1 2 3)
  619.        bar)
  620.     (cons foo bar))
  621.    => (3 . nil)
  622.  
  623. All values of the new bindings are evaluated before any symbols are bound.
  624. ::end:: */
  625. {
  626.     VALUE tmp, *store, oldvals, res = NULL;
  627.     int numsyms = 0;
  628.     if(!CONSP(args))
  629.     return(NULL);
  630.     oldvals = sym_nil;
  631.     for(tmp = VCAR(args); CONSP(tmp); numsyms++)
  632.     tmp = VCDR(tmp);
  633.     if(numsyms == 0)
  634.     return(cmd_progn(VCDR(args)));
  635.     else if((store = mystralloc(sizeof(VALUE) * numsyms)))
  636.     {
  637.     int i;
  638.     GCVAL gcv_args;
  639.     GCVALN gcv_store;
  640.     PUSHGC(gcv_args, args);
  641.     PUSHGCN(gcv_store, store, 0);
  642.     i = 0;
  643.     tmp = VCAR(args);
  644.     while(CONSP(tmp))
  645.     {
  646.         if(CONSP(VCAR(tmp)))
  647.         {
  648.         if(!(store[i] = cmd_progn(VCDR(VCAR(tmp)))))
  649.         {
  650.             POPGCN; POPGC;
  651.             goto end;
  652.         }
  653.         }
  654.         else
  655.         store[i] = sym_nil;
  656.         tmp = VCDR(tmp);
  657.         i++;
  658.         gcv_store.gcv_N = i;
  659.     }
  660.     POPGCN;
  661.     POPGC;
  662.     i = 0;
  663.     tmp = VCAR(args);
  664.     while(CONSP(tmp))
  665.     {
  666.         VALUE sym;
  667.         switch(VTYPE(VCAR(tmp)))
  668.         {
  669.         case V_Symbol:
  670.         sym = VCAR(tmp);
  671.         break;
  672.         case V_Cons:
  673.         sym = VCAR(VCAR(tmp));
  674.         if(SYMBOLP(sym))
  675.             break;
  676.         /* FALL THROUGH */
  677.         default:
  678.         cmd_signal(sym_error, LIST_1(MKSTR("No symbol to bind to in let")));
  679.         goto end;
  680.         }
  681.         if(!(oldvals = bindsymbol(oldvals, sym, store[i])))
  682.         goto end;
  683.         tmp = VCDR(tmp);
  684.         i++;
  685.     }
  686.     PUSHGC(gcv_args, oldvals);
  687.     res = cmd_progn(VCDR(args));
  688.     POPGC;
  689. end:
  690.     mystrfree(store);
  691.     unbindsymbols(oldvals);
  692.     return(res);
  693.     }
  694.     return(NULL);
  695. }
  696. _PR VALUE cmd_letstar(VALUE);
  697. DEFUN("let*", cmd_letstar, subr_letstar, (VALUE args), V_SF, DOC_letstar) /*
  698. ::doc:letstar::
  699. (let* (SYMBOL-BINDINGS...) BODY...) <SPECIAL-FORM>
  700. Binds temporary values to symbols while BODY is being evaluated.
  701. Each SYMBOL-BINDING is either a symbol, in which case that symbol is bound to
  702. nil, or a list. The symbol at the head of this list is bound to the progn'ed
  703. value of the forms making up the tail. ie,
  704.   (let*
  705.       ((foo 1 2 3)
  706.        bar)
  707.     (cons foo bar))
  708.    => (3 . nil)
  709.  
  710. The value of each binding is evaluated just before that symbol is bound,
  711. this means that,
  712.   (setq x 'foo)
  713.   (let*
  714.       ((x 10)
  715.        (y x))
  716.     (cons x y))
  717.    => (10 . 10)
  718. ::end:: */
  719. {
  720.     VALUE binds, res = NULL;
  721.     VALUE oldvals = sym_nil;
  722.     GCVAL gcv_args, gcv_oldvals;
  723.     if(!CONSP(args))
  724.     return(NULL);
  725.     binds = VCAR(args);
  726.     PUSHGC(gcv_args, args);
  727.     PUSHGC(gcv_oldvals, oldvals);
  728.     while(CONSP(binds))
  729.     {
  730.     if(CONSP(VCAR(binds)))
  731.     {
  732.         if(SYMBOLP(VCAR(VCAR(binds))))
  733.         {
  734.         VALUE val;
  735.         if(!(val = cmd_progn(VCDR(VCAR(binds)))))
  736.             goto error;
  737.         if(!(oldvals = bindsymbol(oldvals, VCAR(VCAR(binds)), val)))
  738.             goto error;
  739.         }
  740.     }
  741.     else
  742.     {
  743.         if(!(oldvals = bindsymbol(oldvals, VCAR(binds), sym_nil)))
  744.         goto error;
  745.     }
  746.     binds = VCDR(binds);
  747.     }
  748.     res = cmd_progn(VCDR(args));
  749. error:
  750.     POPGC; POPGC;
  751.     unbindsymbols(oldvals);
  752.     return(res);
  753. }
  754.  
  755. _PR VALUE cmd_get(VALUE, VALUE);
  756. DEFUN("get", cmd_get, subr_get, (VALUE sym, VALUE prop), V_Subr2, DOC_get) /*
  757. ::doc:get::
  758. (get SYMBOL PROPERTY)
  759. Returns the value of SYMBOL's property PROPERTY. See `put'.
  760. ::end:: */
  761. {
  762.     VALUE plist;
  763.     DECLARE1(sym, SYMBOLP);
  764.     plist = VSYM(sym)->sym_PropList;
  765.     while(CONSP(plist) && CONSP(VCDR(plist)))
  766.     {
  767.     if(VCAR(plist) == prop)
  768.         return(VCAR(VCDR(plist)));
  769.     plist = VCDR(VCDR(plist));
  770.     }
  771.     return(sym_nil);
  772. }
  773.  
  774. _PR VALUE cmd_put(VALUE, VALUE, VALUE);
  775. DEFUN("put", cmd_put, subr_put, (VALUE sym, VALUE prop, VALUE val), V_Subr3, DOC_put) /*
  776. ::doc:put::
  777. (put SYMBOL PROPERTY VALUE)
  778. Sets the value of SYMBOL's property PROPERTY to VALUE, this value can be
  779. retrieved with the `get' function.
  780. ::end:: */
  781. {
  782.     VALUE plist;
  783.     DECLARE1(sym, SYMBOLP);
  784.     plist = VSYM(sym)->sym_PropList;
  785.     while(CONSP(plist) && CONSP(VCDR(plist)))
  786.     {
  787.     if(VCAR(plist) == prop)
  788.     {
  789.         VCAR(VCDR(plist)) = val;
  790.         return(val);
  791.     }
  792.     plist = VCDR(VCDR(plist));
  793.     }
  794.     plist = cmd_cons(prop, cmd_cons(val, VSYM(sym)->sym_PropList));
  795.     if(plist)
  796.     {
  797.     VSYM(sym)->sym_PropList = plist;
  798.     return(val);
  799.     }
  800.     return(NULL);
  801. }
  802.  
  803. _PR VALUE cmd_buffer_variables(VALUE);
  804. DEFUN("buffer-variables", cmd_buffer_variables, subr_buffer_variables, (VALUE tx), V_Subr1, DOC_buffer_variables) /*
  805. ::doc:buffer_variables::
  806. (buffer-variables [BUFFER])
  807. Returns a list of (SYMBOL . VALUE) bindings which take effect when the
  808. current buffer is BUFFER.
  809. ::end:: */
  810. {
  811.     if(!BUFFERP(tx))
  812.     tx = CurrVW->vw_Tx;
  813.     return(VTX(tx)->tx_LocalVariables);
  814. }
  815.  
  816. _PR VALUE cmd_window_variables(VALUE);
  817. DEFUN("window-variables", cmd_window_variables, subr_window_variables, (VALUE vw), V_Subr1, DOC_window_variables) /*
  818. ::doc:window_variables::
  819. (window-variables [WINDOW])
  820. Returns a list of (SYMBOL . VALUE) bindings which take effect when the
  821. current window is WINDOW.
  822. ::end:: */
  823. {
  824.     if(!WINDOWP(vw))
  825.     vw = CurrVW;
  826.     return(VWIN(vw)->vw_LocalVariables);
  827. }
  828.  
  829. _PR VALUE cmd_apropos(VALUE, VALUE, VALUE);
  830. DEFUN("apropos", cmd_apropos, subr_apropos, (VALUE re, VALUE pred, VALUE ob), V_Subr3, DOC_apropos) /*
  831. ::doc:apropos::
  832. (apropos REGEXP [PREDICATE] [OBARRAY])
  833. Returns a list of symbols from OBARRAY (or the default) whose print-name
  834. matches the regular-expression REGEXP. If PREDICATE is given and non-nil,
  835. each symbol which matches is applied to the function PREDICATE, if the value
  836. is non-nil it is considered a match.
  837. ::end:: */
  838. {
  839.     regexp *prog;
  840.     DECLARE1(re, STRINGP);
  841.     if(!VECTORP(ob))
  842.     ob = ObArray;
  843.     prog = regcomp(VSTR(re));
  844.     if(prog)
  845.     {
  846.     VALUE last = sym_nil;
  847.     int i;
  848.     GCVAL gcv_last, gcv_ob, gcv_pred;
  849.     PUSHGC(gcv_last, last);
  850.     PUSHGC(gcv_ob, ob);
  851.     PUSHGC(gcv_pred, pred);
  852.     for(i = 0; i < VVECT(ob)->vc_Size; i++)
  853.     {
  854.         Symbol *chain = VVECT(ob)->vc_Array[i];
  855.         while(chain)
  856.         {
  857.         if(regexec(prog, VSTR(chain->sym_Name)))
  858.         {
  859.             if(pred && !NILP(pred))
  860.             {
  861.             VALUE tmp;
  862.             if(!(tmp = funcall(pred, LIST_1(chain))) || NILP(tmp))
  863.                 goto next;
  864.             }
  865.             last = cmd_cons(chain, last);
  866.         }
  867. next:
  868.         chain = chain->sym_Next;
  869.         }
  870.     }
  871.     POPGC; POPGC; POPGC;
  872.     free(prog);
  873.     return(last);
  874.     }
  875.     return(NULL);
  876. }
  877.  
  878. _PR VALUE cmd_set_buffer_variable(VALUE sym, VALUE stat);
  879. DEFUN("set-buffer-variable", cmd_set_buffer_variable, subr_set_buffer_variable, (VALUE sym, VALUE stat), V_Subr2, DOC_set_buffer_variable) /*
  880. ::doc:set_buffer_variable::
  881. (set-buffer-variable SYMBOL)
  882. Flags that SYMBOL might have a value local to each buffer.
  883. ::end:: */
  884. {
  885.     DECLARE1(sym, SYMBOLP);
  886.     if(NILP(stat))
  887.     VSYM(sym)->sym_Flags |= SF_BUFFER_LOCAL;
  888.     else
  889.     VSYM(sym)->sym_Flags &= ~SF_BUFFER_LOCAL;
  890.     return(sym);
  891. }
  892. _PR VALUE cmd_buffer_variable_p(VALUE sym);
  893. DEFUN("buffer-variable-p", cmd_buffer_variable_p, subr_buffer_variable_p, (VALUE sym), V_Subr1, DOC_buffer_variable_p) /*
  894. ::doc:buffer_variable_p::
  895. (buffer-variable-p SYMBOL)
  896. Returns t if `set-buffer-variable' has been called on this symbol.
  897. ::end:: */
  898. {
  899.     DECLARE1(sym, SYMBOLP);
  900.     if(VSYM(sym)->sym_Flags & SF_BUFFER_LOCAL)
  901.     return(sym_t);
  902.     return(sym_nil);
  903. }
  904.  
  905. _PR VALUE cmd_set_window_variable(VALUE sym, VALUE stat);
  906. DEFUN("set-window-variable", cmd_set_window_variable, subr_set_window_variable, (VALUE sym, VALUE stat), V_Subr2, DOC_set_window_variable) /*
  907. ::doc:set_window_variable::
  908. (set-window-variable SYMBOL)
  909. Flags that SYMBOL might have a value local to each window.
  910. ::end:: */
  911. {
  912.     DECLARE1(sym, SYMBOLP);
  913.     if(NILP(stat))
  914.     VSYM(sym)->sym_Flags |= SF_WIN_LOCAL;
  915.     else
  916.     VSYM(sym)->sym_Flags &= ~SF_WIN_LOCAL;
  917.     return(sym);
  918. }
  919. _PR VALUE cmd_window_variable_p(VALUE sym);
  920. DEFUN("window-variable-p", cmd_window_variable_p, subr_window_variable_p, (VALUE sym), V_Subr1, DOC_window_variable_p) /*
  921. ::doc:window_variable_p::
  922. (window-variable-p SYMBOL)
  923. Returns t if `set-window-variable' has been called on this symbol.
  924. ::end:: */
  925. {
  926.     DECLARE1(sym, SYMBOLP);
  927.     if(VSYM(sym)->sym_Flags & SF_WIN_LOCAL)
  928.     return(sym_t);
  929.     return(sym_nil);
  930. }
  931.  
  932. _PR VALUE cmd_set_const_variable(VALUE sym, VALUE stat);
  933. DEFUN("set-const-variable", cmd_set_const_variable, subr_set_const_variable, (VALUE sym, VALUE stat), V_Subr2, DOC_set_const_variable) /*
  934. ::doc:set_const_variable::
  935. (set-const-variable SYMBOL)
  936. Flags that the value of SYMBOL may not be changed.
  937. ::end:: */
  938. {
  939.     DECLARE1(sym, SYMBOLP);
  940.     if(NILP(stat))
  941.     VSYM(sym)->sym_Flags |= SF_CONSTANT;
  942.     else
  943.     VSYM(sym)->sym_Flags &= ~SF_CONSTANT;
  944.     return(sym);
  945. }
  946. _PR VALUE cmd_const_variable_p(VALUE sym);
  947. DEFUN("const-variable-p", cmd_const_variable_p, subr_const_variable_p, (VALUE sym), V_Subr1, DOC_const_variable_p) /*
  948. ::doc:const_variable_p::
  949. (const-variable-p SYMBOL)
  950. Return t is `set-const-variable' has been called on SYMBOL.
  951. ::end:: */
  952. {
  953.     DECLARE1(sym, SYMBOLP);
  954.     if(VSYM(sym)->sym_Flags & SF_CONSTANT)
  955.     return(sym_t);
  956.     return(sym_nil);
  957. }
  958.  
  959. _PR VALUE cmd_trace(VALUE sym);
  960. DEFUN("trace", cmd_trace, subr_trace, (VALUE sym), V_Subr1, DOC_trace) /*
  961. ::doc:trace::
  962. (trace SYMBOL)
  963. Flag that whenever SYMBOL is evaluated (as a variable or a function) the
  964. debugger is entered.
  965. ::end:: */
  966. {
  967.     DECLARE1(sym, SYMBOLP);
  968.     VSYM(sym)->sym_Flags |= SF_DEBUG;
  969.     return(sym);
  970. }
  971. _PR VALUE cmd_untrace(VALUE sym);
  972. DEFUN("untrace", cmd_untrace, subr_untrace, (VALUE sym), V_Subr1, DOC_untrace) /*
  973. ::doc:untrace::
  974. (untrace SYMBOL)
  975. Cancel the effect of (trace SYMBOL).
  976. ::end:: */
  977. {
  978.     DECLARE1(sym, SYMBOLP);
  979.     VSYM(sym)->sym_Flags &= ~SF_DEBUG;
  980.     return(sym);
  981. }
  982.  
  983. int
  984. symbols_init(void)
  985. {
  986.     ObArray = newvector(OBSIZE);
  987.     if(ObArray)
  988.     {
  989.     markstatic(&ObArray);
  990.  
  991.     /* fiddly details of initialising the first symbol */
  992.     sym_nil = cmd_intern(MKSTR("nil"), ObArray);
  993.     markstatic(&sym_nil);
  994.     VSYM(sym_nil)->sym_Value = sym_nil;
  995.     VSYM(sym_nil)->sym_PropList = sym_nil;
  996.  
  997.     INTERN(sym_t, "t");
  998.     VSYM(sym_t)->sym_Value = sym_t;
  999.     INTERN(sym_variable_documentation, "variable-documentation");
  1000.     ADD_SUBR(subr_make_symbol);
  1001.     ADD_SUBR(subr_make_obarray);
  1002.     ADD_SUBR(subr_find_symbol);
  1003.     ADD_SUBR(subr_intern_symbol);
  1004.     ADD_SUBR(subr_intern);
  1005.     ADD_SUBR(subr_unintern);
  1006.     ADD_SUBR(subr_symbol_value);
  1007.     ADD_SUBR(subr_set);
  1008.     ADD_SUBR(subr_setplist);
  1009.     ADD_SUBR(subr_symbol_name);
  1010.     ADD_SUBR(subr_symbol_function);
  1011.     ADD_SUBR(subr_fboundp);
  1012.     ADD_SUBR(subr_boundp);
  1013.     ADD_SUBR(subr_symbol_plist);
  1014.     ADD_SUBR(subr_gensym);
  1015.     ADD_SUBR(subr_symbolp);
  1016.     ADD_SUBR(subr_setq);
  1017.     ADD_SUBR(subr_fset);
  1018.     ADD_SUBR(subr_makunbound);
  1019.     ADD_SUBR(subr_fmakunbound);
  1020.     ADD_SUBR(subr_let);
  1021.     ADD_SUBR(subr_letstar);
  1022.     ADD_SUBR(subr_get);
  1023.     ADD_SUBR(subr_put);
  1024.     ADD_SUBR(subr_buffer_variables);
  1025.     ADD_SUBR(subr_window_variables);
  1026.     ADD_SUBR(subr_apropos);
  1027.     ADD_SUBR(subr_set_buffer_variable);
  1028.     ADD_SUBR(subr_buffer_variable_p);
  1029.     ADD_SUBR(subr_set_window_variable);
  1030.     ADD_SUBR(subr_window_variable_p);
  1031.     ADD_SUBR(subr_set_const_variable);
  1032.     ADD_SUBR(subr_const_variable_p);
  1033.     ADD_SUBR(subr_trace);
  1034.     ADD_SUBR(subr_untrace);
  1035.     return(TRUE);
  1036.     }
  1037.     return(FALSE);
  1038. }
  1039. void
  1040. symbols_kill(void)
  1041. {
  1042.     SymbolBlk *sb = SymbolBlkChain;
  1043.     while(sb)
  1044.     {
  1045.     SymbolBlk *nxt = sb->sb_Next;
  1046.     myfree(sb);
  1047.     sb = nxt;
  1048.     }
  1049. }
  1050.