home *** CD-ROM | disk | FTP | other *** search
/ Stars of Shareware: Programmierung / SOURCE.mdf / programm / windows / c / xlisp21w / sources / xlsym.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-02-08  |  8.7 KB  |  383 lines
  1. /* xlsym - symbol handling routines */
  2. /*      Copyright (c) 1985, by David Michael Betz
  3.         All Rights Reserved
  4.         Permission is granted for unrestricted non-commercial use       */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern LVAL obarray,s_unbound;
  10. extern LVAL xlenv,xlfenv;
  11. extern LVAL true;       /* Bug fix TAA */
  12.  
  13. /* forward declarations */
  14. #ifdef ANSI
  15. LVAL XNEAR findprop(LVAL sym, LVAL prp);
  16. #else
  17. FORWARD LVAL findprop();
  18. #endif
  19.  
  20. /* xlenter - enter a symbol into the obarray */
  21. LVAL xlenter(name)
  22.   char *name;
  23. {
  24.     LVAL sym,array;
  25.     int i;
  26.  
  27.     /* check for symbol already in table */
  28.     array = getvalue(obarray);
  29.     i = hash(name,HSIZE);
  30.     for (sym = getelement(array,i); !null(sym); sym = cdr(sym))
  31.         if (STRCMP(name,getstring(getpname(car(sym)))) == 0)
  32.             return (car(sym));
  33.  
  34.     /* make a new symbol node and link it into the list */
  35.     xlsave1(sym);
  36.     sym = consd(getelement(array,i));
  37.     rplaca(sym,xlmakesym(name));
  38.     setelement(array,i,sym);
  39.     xlpop();
  40.  
  41.     /* return the new symbol */
  42.     return (car(sym));
  43. }
  44.  
  45. /* xlmakesym - make a new symbol node */
  46. LVAL xlmakesym(name)
  47.   char *name;
  48. {
  49.     LVAL sym;
  50.     sym = cvsymbol(name);
  51.     if (*name == ':') {
  52.         setvalue(sym,sym);
  53.         setsflags(sym, F_CONSTANT);
  54.     }
  55.     else setsflags(sym, F_NORMAL);
  56.  
  57.     return (sym);
  58. }
  59.  
  60. /* xlgetvalue - get the value of a symbol (with check) */
  61. LVAL xlgetvalue(sym)
  62.   LVAL sym;
  63. {
  64.     LVAL val;
  65.  
  66.     /* look for the value of the symbol */
  67.     while ((val = xlxgetvalue(sym)) == s_unbound)
  68.         xlunbound(sym);
  69.  
  70.     /* return the value */
  71.     return (val);
  72. }
  73.  
  74. /* xlxgetvalue - get the value of a symbol */
  75. LVAL xlxgetvalue(sym)
  76.   LVAL sym;
  77. {
  78.     register LVAL fp,ep;
  79.     LVAL val;
  80.  
  81.     /* check the environment list */
  82.     for (fp = xlenv; !null(fp); fp = cdr(fp))
  83.  
  84.         /* check for an instance variable */
  85.         if (!null(ep = car(fp)) && objectp(car(ep))) {
  86.             if (xlobgetvalue(ep,sym,&val))
  87.                 return (val);
  88.         }
  89.  
  90.         /* check an environment stack frame */
  91.         else {
  92.             for (; !null(ep); ep = cdr(ep))
  93.                 if (sym == car(car(ep)))
  94.                     return (cdr(car(ep)));
  95.         }
  96.  
  97.     /* return the global value */
  98.     return (getvalue(sym));
  99. }
  100.  
  101. /* xlsetvalue - set the value of a symbol */
  102. VOID xlsetvalue(sym,val)
  103.   LVAL sym,val;
  104. {
  105.     register LVAL fp,ep;
  106.  
  107.     if (constantp(sym)) {
  108.         xlnoassign(sym);
  109.         /* never returns */
  110.     }
  111.  
  112.     /* look for the symbol in the environment list */
  113.     for (fp = xlenv; !null(fp); fp = cdr(fp))
  114.  
  115.         /* check for an instance variable */
  116.         if (!null(ep = car(fp)) && objectp(car(ep))) {
  117.             if (xlobsetvalue(ep,sym,val))
  118.                 return;
  119.         }
  120.  
  121.         /* check an environment stack frame */
  122.         else {
  123.             for (; !null(ep); ep = cdr(ep))
  124.                 if (sym == car(car(ep))) {
  125.                     rplacd(car(ep),val);
  126.                     return;
  127.                 }
  128.         }
  129.  
  130.     /* store the global value */
  131.     setvalue(sym,val);
  132. }
  133.  
  134. /* xlgetfunction - get the functional value of a symbol (with check) */
  135. LVAL xlgetfunction(sym)
  136.   LVAL sym;
  137. {
  138.     LVAL val;
  139.  
  140.     /* look for the functional value of the symbol */
  141.     while ((val = xlxgetfunction(sym)) == s_unbound)
  142.         xlfunbound(sym);
  143.  
  144.     /* return the value */
  145.     return (val);
  146. }
  147.  
  148. /* xlxgetfunction - get the functional value of a symbol */
  149. LVAL xlxgetfunction(sym)
  150.   LVAL sym;
  151. {
  152.     register LVAL fp,ep;
  153.  
  154.     /* check the environment list */
  155.     for (fp = xlfenv; !null(fp); fp = cdr(fp))
  156.         for (ep = car(fp); !null(ep); ep = cdr(ep))
  157.             if (sym == car(car(ep)))
  158.                 return (cdr(car(ep)));
  159.  
  160.     /* return the global value */
  161.     return (getfunction(sym));
  162. }
  163.  
  164. /* xlsetfunction - set the functional value of a symbol */
  165. VOID xlsetfunction(sym,val)
  166.   LVAL sym,val;
  167. {
  168.     register LVAL fp,ep;
  169.  
  170.     /* look for the symbol in the environment list */
  171.     for (fp = xlfenv; !null(fp); fp = cdr(fp))
  172.         for (ep = car(fp); !null(ep); ep = cdr(ep))
  173.             if (sym == car(car(ep))) {
  174.                 rplacd(car(ep),val);
  175.                 return;
  176.             }
  177.  
  178.     /* store the global value */
  179.     setfunction(sym,val);
  180. }
  181.  
  182. /* xlgetprop - get the value of a property */
  183. LVAL xlgetprop(sym,prp)
  184.   LVAL sym,prp;
  185. {
  186.     LVAL p;
  187.     return (null(p = findprop(sym,prp)) ? NIL : car(p));
  188. }
  189.  
  190. /* xlputprop - put a property value onto the property list */
  191. VOID xlputprop(sym,val,prp)
  192.   LVAL sym,val,prp;
  193. {
  194.     LVAL pair;
  195.     if (!null(pair = findprop(sym,prp)))
  196.         rplaca(pair,val);
  197.     else
  198.         setplist(sym,cons(prp,cons(val,getplist(sym))));
  199. }
  200.  
  201. /* xlremprop - remove a property from a property list */
  202. VOID xlremprop(sym,prp)
  203.   LVAL sym,prp;
  204. {
  205.     LVAL last,p;
  206.     last = NIL;
  207.     for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(last)) {
  208.         if (car(p) == prp)
  209.             if (!null(last))
  210.                 rplacd(last,cdr(cdr(p)));
  211.             else
  212.                 setplist(sym,cdr(cdr(p)));
  213.         last = cdr(p);
  214.     }
  215. }
  216.  
  217. /* findprop - find a property pair */
  218. LOCAL LVAL XNEAR findprop(sym,prp)
  219.   LVAL sym,prp;
  220. {
  221.     LVAL p;
  222.     for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(cdr(p)))
  223.         if (car(p) == prp)
  224.             return (cdr(p));
  225.     return (NIL);
  226. }
  227.  
  228. /* hash - hash a symbol name string */
  229. int hash(str,len)
  230.   char XFAR *str;
  231.   int len;
  232. {
  233.     int i;
  234.     for (i = 0; *str; )
  235.         i = (i << 2) ^ *str++;
  236.     i %= len;
  237.     return (i < 0 ? -i : i);
  238. }
  239.  
  240. /* xlhash -- hash any xlisp object */
  241. /* TAA extension */
  242. int xlhash(obj,len)
  243.     LVAL obj;
  244.     int len;
  245. {
  246.     int i;
  247.     unsigned long tot;
  248.     union {FIXTYPE i; float j; unsigned FIXTYPE k;} swizzle;
  249.  
  250.     hashloop:   /* iterate on conses */
  251.     switch (ntype(obj)) {
  252.         case SYMBOL:
  253.             obj = getpname(obj);
  254.         case STRING:
  255.             return hash(getstring(obj),len);
  256.         case SUBR: case FSUBR:
  257.             return getoffset(obj) % len;
  258.         case FIXNUM:
  259.             swizzle.i = getfixnum(obj);
  260.             return (int) (swizzle.k % len);
  261.         case FLONUM:
  262.             swizzle.j = getflonum(obj);
  263.             return (int) (swizzle.k % len);
  264.         case CHAR:
  265.             return getchcode(obj) % len;
  266.         case CONS: case USTREAM:
  267.             obj = car(obj);     /* just base on CAR */
  268.             goto hashloop;
  269.         case STREAM:
  270.             return 0;   /* nothing we can do on this */
  271.         default:    /* all array types */
  272.             for (i = getsize(obj), tot = 0; i-- > 0;)
  273.                 tot += (unsigned)xlhash(getelement(obj,i),len);
  274.             return (int)(tot % len);
  275.     }
  276. }
  277.  
  278. /* unbind a variable/constant */
  279. LVAL xmakunbound()
  280. {
  281.     LVAL sym;
  282.  
  283.     sym = xlgasymbol();
  284.     xllastarg();
  285.  
  286.     if (constantp(sym))
  287.         xlerror("can't unbind constant", sym);
  288.  
  289.     setvalue(sym, s_unbound);
  290.     setsflags(sym, F_NORMAL);
  291.     return(sym);
  292. }
  293.  
  294.  
  295. /* define a constant -- useful in initialization */
  296.  
  297. VOID defconstant(sym, val)
  298.   LVAL sym, val;
  299. {
  300.     setvalue(sym, val);
  301.     setsflags(sym, F_CONSTANT | F_SPECIAL);
  302. }
  303.  
  304. /* DEFCONSTANT DEFPARAMETER and DEFVAR */
  305.  
  306. LVAL xdefconstant()
  307. {
  308.     LVAL sym, val;
  309.  
  310.     sym = xlgasymbol();
  311.     val = xlgetarg();
  312.     xllastarg();
  313.  
  314.     /* evaluate constant value */
  315.     val = xleval(val);
  316.  
  317.     if (null(sym)) xlfail("can't redefine NIL");
  318.  
  319.     if (specialp(sym)) {
  320.         if (constantp(sym)) {
  321.             if (!eql(getvalue(sym),val)) {
  322.                 errputstr("WARNING-- redefinition of constant ");
  323.                 errprint(sym);
  324.             }
  325.         }
  326.         else xlerror("can't make special variable into a constant", sym);
  327.     }
  328.  
  329.     defconstant(sym, val);
  330.  
  331.     return(sym);
  332. }
  333.  
  334.  
  335. LVAL xdefparameter()
  336. {
  337.     LVAL sym, val;
  338.  
  339.     sym = xlgasymbol();
  340.     val = xlgetarg();
  341.     xllastarg();
  342.  
  343.     if (constantp(sym)) xlnoassign(sym);
  344.  
  345.     setvalue(sym, xleval(val));
  346.     setsflags(sym, F_SPECIAL);
  347.     return(sym);
  348. }
  349.  
  350. LVAL xdefvar()
  351. {
  352.     LVAL sym, val=NIL;
  353.  
  354.     sym = xlgasymbol();
  355.     if (moreargs()) {
  356.         val = xlgetarg();
  357.         xllastarg();
  358.     }
  359.  
  360.     if (constantp(sym)) xlnoassign(sym);
  361.  
  362.     if (getvalue(sym) == s_unbound) setvalue(sym, xleval(val));
  363.     setsflags(sym, F_SPECIAL);
  364.     return(sym);
  365. }
  366.  
  367.  
  368. /* xlsinit - symbol initialization routine */
  369. VOID xlsinit()
  370. {
  371.     LVAL array,p;
  372.  
  373.     /* initialize the obarray */
  374.     obarray = xlmakesym("*OBARRAY*");
  375.     array = newvector(HSIZE);
  376.     setvalue(obarray,array);
  377.  
  378.     /* add the symbol *OBARRAY* to the obarray */
  379.     p = consa(obarray);
  380.     setelement(array,hash("*OBARRAY*",HSIZE),p);
  381.  
  382. }
  383.