1 /* symbol.c
2 *
3 * $Id$
4 *
5 * Copyright 1990, 1991, 1992, 1993, 1994, 1995, Oliver Laumann, Berlin
6 * Copyright 2002, 2003 Sam Hocevar <sam@hocevar.net>, Paris
7 *
8 * This software was derived from Elk 1.2, which was Copyright 1987, 1988,
9 * 1989, Nixdorf Computer AG and TELES GmbH, Berlin (Elk 1.2 has been written
10 * by Oliver Laumann for TELES Telematic Services, Berlin, in a joint project
11 * between TELES and Nixdorf Microprocessor Engineering, Berlin).
12 *
13 * Oliver Laumann, TELES GmbH, Nixdorf Computer AG and Sam Hocevar, as co-
14 * owners or individual owners of copyright in this software, grant to any
15 * person or company a worldwide, royalty free, license to
16 *
17 * i) copy this software,
18 * ii) prepare derivative works based on this software,
19 * iii) distribute copies of this software or derivative works,
20 * iv) perform this software, or
21 * v) display this software,
22 *
23 * provided that this notice is not removed and that neither Oliver Laumann
24 * nor Teles nor Nixdorf are deemed to have made any representations as to
25 * the suitability of this software for any purpose nor are held responsible
26 * for any defects of this software.
27 *
28 * THERE IS ABSOLUTELY NO WARRANTY FOR THIS SOFTWARE.
29 */
30
31 #include "config.h"
32
33 #include <ctype.h>
34 #include <string.h>
35
36 #include "kernel.h"
37
38 int Hash (char const *, unsigned int);
39
40 Object Obarray;
41
42 Object Null,
43 True,
44 False,
45 False2,
46 Unbound,
47 Special,
48 Void,
49 Newline,
50 Eof,
51 Unspecified,
52 Zero,
53 One;
54
Init_Symbol()55 void Init_Symbol () {
56 SET(Null, T_Null, 0);
57 SET(True, T_Boolean, 1);
58 SET(False, T_Boolean, 0);
59 False2 = False;
60 SET(Unbound, T_Unbound, 0);
61 SET(Special, T_Special, 0);
62 SET(Eof, T_End_Of_File, 0);
63 SET(Unspecified, T_Unspecified, 0);
64 Newline = Make_Char ('\n');
65 Zero = Make_Integer (0);
66 One = Make_Integer (1);
67 Obarray = Make_Vector (OBARRAY_SIZE, Null);
68 Global_GC_Link (Obarray);
69 Define_Symbol (&Void, "");
70 }
71
Make_Symbol(Object name)72 Object Make_Symbol (Object name) {
73 Object sym;
74 register struct S_Symbol *sp;
75 GC_Node;
76
77 GC_Link (name);
78 sym = Alloc_Object (sizeof (struct S_Symbol), T_Symbol, 0);
79 sp = SYMBOL(sym);
80 sp->name = name;
81 sp->value = Unbound;
82 sp->plist = Null;
83 GC_Unlink;
84 return sym;
85 }
86
P_Symbolp(Object x)87 Object P_Symbolp (Object x) {
88 return TYPE(x) == T_Symbol ? True : False;
89 }
90
P_Symbol_To_String(Object x)91 Object P_Symbol_To_String (Object x) {
92 Check_Type (x, T_Symbol);
93 return SYMBOL(x)->name;
94 }
95
Obarray_Lookup(register char const * str,register unsigned int len)96 Object Obarray_Lookup (register char const *str, register unsigned int len) {
97 register int h;
98 register struct S_String *s;
99 register struct S_Symbol *sym;
100 Object p;
101
102 h = Hash (str, len) % OBARRAY_SIZE;
103 for (p = VECTOR(Obarray)->data[h]; !Nullp (p); p = sym->next) {
104 sym = SYMBOL(p);
105 s = STRING(sym->name);
106 if (s->size == len && memcmp (s->data, str, len) == 0)
107 return p;
108 }
109 return Make_Integer (h);
110 }
111
CI_Intern(char const * str)112 Object CI_Intern (char const *str) {
113 Object s, *p, sym, ostr;
114 register unsigned int len;
115 register char const *src;
116 char *dst;
117 char buf[128];
118 Alloca_Begin;
119
120 len = strlen (str);
121 if (len > sizeof (buf)) {
122 Alloca (dst, char*, len);
123 } else
124 dst = buf;
125 src = str;
126 str = dst;
127 for ( ; *src; src++, dst++)
128 *dst = isupper (*src) ? tolower (*src) : *src;
129 s = Obarray_Lookup (str, len);
130 if (TYPE(s) != T_Fixnum) {
131 Alloca_End;
132 return s;
133 }
134 ostr = Make_Const_String (str, len);
135 sym = Make_Symbol (ostr);
136 p = &VECTOR(Obarray)->data[FIXNUM(s)];
137 SYMBOL(sym)->next = *p;
138 Alloca_End;
139 *p = sym;
140 return sym;
141 }
142
Intern(char const * str)143 Object Intern (char const *str) {
144 Object s, *p, sym, ostr;
145 register unsigned int len;
146
147 if (Case_Insensitive)
148 return CI_Intern (str);
149 len = strlen (str);
150 s = Obarray_Lookup (str, len);
151 if (TYPE(s) != T_Fixnum)
152 return s;
153 ostr = Make_Const_String (str, len);
154 sym = Make_Symbol (ostr);
155 p = &VECTOR(Obarray)->data[FIXNUM(s)];
156 SYMBOL(sym)->next = *p;
157 *p = sym;
158 return sym;
159 }
160
P_String_To_Symbol(Object str)161 Object P_String_To_Symbol (Object str) {
162 Object s, *p, sym;
163
164 Check_Type (str, T_String);
165 s = Obarray_Lookup (STRING(str)->data, STRING(str)->size);
166 if (TYPE(s) != T_Fixnum)
167 return s;
168 str = Make_String (STRING(str)->data, STRING(str)->size);
169 sym = Make_Symbol (str);
170 p = &VECTOR(Obarray)->data[FIXNUM(s)];
171 SYMBOL(sym)->next = *p;
172 *p = sym;
173 return sym;
174 }
175
P_Oblist()176 Object P_Oblist () {
177 register int i;
178 Object p, list, bucket;
179 GC_Node2;
180
181 p = list = Null;
182 GC_Link2 (p, list);
183 for (i = 0; i < OBARRAY_SIZE; i++) {
184 bucket = Null;
185 for (p = VECTOR(Obarray)->data[i]; !Nullp (p); p = SYMBOL(p)->next)
186 bucket = Cons (p, bucket);
187 if (!Nullp (bucket))
188 list = Cons (bucket, list);
189 }
190 GC_Unlink;
191 return list;
192 }
193
P_Put(int argc,Object * argv)194 Object P_Put (int argc, Object *argv) {
195 Object sym, key, last, tail, prop;
196 GC_Node3;
197
198 sym = argv[0];
199 key = argv[1];
200 Check_Type (sym, T_Symbol);
201 Check_Type (key, T_Symbol);
202 last = Null;
203 for (tail = SYMBOL(sym)->plist; !Nullp (tail); tail = Cdr (tail)) {
204 prop = Car (tail);
205 if (EQ(Car (prop), key)) {
206 if (argc == 3)
207 Cdr (prop) = argv[2];
208 else if (Nullp (last))
209 SYMBOL(sym)->plist = Cdr (tail);
210 else
211 Cdr (last) = Cdr (tail);
212 return key;
213 }
214 last = tail;
215 }
216 if (argc == 2)
217 return False;
218 GC_Link3 (sym, last, key);
219 tail = Cons (key, argv[2]);
220 tail = Cons (tail, Null);
221 if (Nullp (last))
222 SYMBOL(sym)->plist = tail;
223 else
224 Cdr (last) = tail;
225 GC_Unlink;
226 return key;
227 }
228
P_Get(Object sym,Object key)229 Object P_Get (Object sym, Object key) {
230 Object prop;
231
232 Check_Type (sym, T_Symbol);
233 Check_Type (key, T_Symbol);
234 prop = Assq (key, SYMBOL(sym)->plist);
235 if (!Truep (prop))
236 return False;
237 /*
238 * Do we want to signal an error or return #f?
239 *
240 * Primitive_Error ("~s has no such property: ~s", sym, key);
241 */
242 return Cdr (prop);
243 }
244
P_Symbol_Plist(Object sym)245 Object P_Symbol_Plist (Object sym) {
246 Check_Type (sym, T_Symbol);
247 return Copy_List (SYMBOL(sym)->plist);
248 }
249
Hash(char const * str,unsigned int len)250 int Hash (char const *str, unsigned int len) {
251 register int h;
252 register char const *p, *ep;
253
254 h = 5 * len;
255 if (len > 5)
256 len = 5;
257 for (p = str, ep = p+len; p < ep; ++p)
258 h = (h << 2) ^ *p;
259 return h & 017777777777;
260 }
261
Define_Symbol(Object * sym,char const * name)262 void Define_Symbol (Object *sym, char const *name) {
263 *sym = Intern (name);
264 Func_Global_GC_Link (sym);
265 }
266
Define_Variable(Object * var,char const * name,Object init)267 void Define_Variable (Object *var, char const *name, Object init) {
268 Object frame, sym;
269 GC_Node;
270
271 GC_Link (init);
272 sym = Intern (name);
273 SYMBOL(sym)->value = init;
274 frame = Add_Binding (Car (The_Environment), sym, init);
275 *var = Car (frame);
276 Car (The_Environment) = frame;
277 Func_Global_GC_Link (var);
278 GC_Unlink;
279 }
280
Var_Get(Object var)281 Object Var_Get (Object var) {
282 return Cdr (var);
283 }
284
Var_Set(Object var,Object val)285 void Var_Set (Object var, Object val) {
286 Cdr (var) = val;
287 SYMBOL (Car (var))->value = val;
288 }
289
Var_Is_True(Object var)290 int Var_Is_True (Object var) {
291 var = Var_Get (var);
292 return Truep (var);
293 }
294
Symbols_To_Bits(Object x,int mflag,SYMDESCR * stab)295 unsigned long int Symbols_To_Bits (Object x, int mflag, SYMDESCR *stab) {
296 register SYMDESCR *syms;
297 register unsigned long int mask = 0;
298 Object l, s;
299 register char *p;
300 register int n;
301
302 if (!mflag) Check_Type (x, T_Symbol);
303 for (l = x; !Nullp (l); l = Cdr (l)) {
304 if (mflag) {
305 Check_Type (l, T_Pair);
306 x = Car (l);
307 }
308 Check_Type (x, T_Symbol);
309 s = SYMBOL(x)->name;
310 p = STRING(s)->data;
311 n = STRING(s)->size;
312 for (syms = stab; syms->name; syms++)
313 if (n && strncmp (syms->name, p, n) == 0) break;
314 if (syms->name == 0)
315 Primitive_Error ("invalid argument: ~s", x);
316 mask |= syms->val;
317 if (!mflag) break;
318 }
319 return mask;
320 }
321
Bits_To_Symbols(unsigned long int x,int mflag,SYMDESCR * stab)322 Object Bits_To_Symbols (unsigned long int x, int mflag, SYMDESCR *stab) {
323 register SYMDESCR *syms;
324 Object list, tail, cell;
325 GC_Node2;
326
327 if (mflag) {
328 GC_Link2 (list, tail);
329 for (list = tail = Null, syms = stab; syms->name; syms++)
330 if ((x & syms->val) && syms->val != ~0U) {
331 Object z;
332
333 z = Intern (syms->name);
334 cell = Cons (z, Null);
335 if (Nullp (list))
336 list = cell;
337 else
338 P_Set_Cdr (tail, cell);
339 tail = cell;
340 }
341 GC_Unlink;
342 return list;
343 }
344 for (syms = stab; syms->name; syms++)
345 if (syms->val == x)
346 return Intern (syms->name);
347 return Null;
348 }
349