ia64/xen-unstable

view tools/xfrd/sxpr.c @ 1820:3d4f8eb89670

bitkeeper revision 1.1106.1.2 (40faa780dekT3E5arFwcbQDu1MbX6g)

Cleaned up Xen's instruction emulator.
author kaf24@scramble.cl.cam.ac.uk
date Sun Jul 18 16:38:24 2004 +0000 (2004-07-18)
parents 0e23f01219c6
children
line source
1 /*
2 *
3 * This library is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU Lesser General Public License as
5 * published by the Free Software Foundation; either version 2.1 of the
6 * License, or (at your option) any later version. This library is
7 * distributed in the hope that it will be useful, but WITHOUT ANY
8 * WARRANTY; without even the implied warranty of MERCHANTABILITY or
9 * FITNESS FOR A PARTICULAR PURPOSE.
10 * See the GNU Lesser General Public License for more details.
11 *
12 * You should have received a copy of the GNU Lesser General Public License
13 * along with this library; if not, write to the Free Software Foundation,
14 * Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
15 */
17 #include <stdarg.h>
18 #include "sys_string.h"
19 #include "lexis.h"
20 #include "sys_net.h"
21 #include "hash_table.h"
22 #include "sxpr.h"
24 #include <errno.h>
25 #undef free
27 /** @file
28 * General representation of sxprs.
29 * Includes print, equal, and free functions for the sxpr types.
30 *
31 * Zero memory containing an Sxpr will have the value ONONE - this is intentional.
32 * When a function returning an sxpr cannot allocate memory we return ONOMEM.
33 *
34 */
36 static int atom_print(IOStream *io, Sxpr obj, unsigned flags);
37 static int atom_equal(Sxpr x, Sxpr y);
38 static void atom_free(Sxpr obj);
40 static int string_print(IOStream *io, Sxpr obj, unsigned flags);
41 static int string_equal(Sxpr x, Sxpr y);
42 static void string_free(Sxpr obj);
44 static int cons_print(IOStream *io, Sxpr obj, unsigned flags);
45 static int cons_equal(Sxpr x, Sxpr y);
46 static void cons_free(Sxpr obj);
48 static int null_print(IOStream *io, Sxpr obj, unsigned flags);
49 static int none_print(IOStream *io, Sxpr obj, unsigned flags);
50 static int int_print(IOStream *io, Sxpr obj, unsigned flags);
51 static int bool_print(IOStream *io, Sxpr obj, unsigned flags);
53 /** Type definitions. */
54 static SxprType types[1024] = {
55 [T_NONE] { type: T_NONE, name: "none", print: none_print },
56 [T_NULL] { type: T_NULL, name: "null", print: null_print },
57 [T_UINT] { type: T_UINT, name: "int", print: int_print, },
58 [T_BOOL] { type: T_BOOL, name: "bool", print: bool_print, },
59 [T_ATOM] { type: T_ATOM, name: "atom", print: atom_print,
60 pointer: TRUE,
61 free: atom_free,
62 equal: atom_equal,
63 },
64 [T_STRING] { type: T_STRING, name: "string", print: string_print,
65 pointer: TRUE,
66 free: string_free,
67 equal: string_equal,
68 },
69 [T_CONS] { type: T_CONS, name: "cons", print: cons_print,
70 pointer: TRUE,
71 free: cons_free,
72 equal: cons_equal,
73 },
74 };
76 /** Number of entries in the types array. */
77 static int type_sup = sizeof(types)/sizeof(types[0]);
79 /** Get the type definition for a given type code.
80 *
81 * @param ty type code
82 * @return type definition or null
83 */
84 SxprType *get_sxpr_type(int ty){
85 if(0 <= ty && ty < type_sup){
86 return types+ty;
87 }
88 return NULL;
89 }
91 /** The default print function.
92 *
93 * @param io stream to print to
94 * @param x sxpr to print
95 * @param flags print flags
96 * @return number of bytes written on success
97 */
98 int default_print(IOStream *io, Sxpr x, unsigned flags){
99 return IOStream_print(io, "#<%u %lu>\n", get_type(x), get_ul(x));
100 }
102 /** The default equal function.
103 * Uses eq().
104 *
105 * @param x sxpr to compare
106 * @param y sxpr to compare
107 * @return 1 if equal, 0 otherwise
108 */
109 int default_equal(Sxpr x, Sxpr y){
110 return eq(x, y);
111 }
113 /** General sxpr print function.
114 * Prints an sxpr on a stream using the print function for the sxpr type.
115 * Printing is controlled by flags from the PrintFlags enum.
116 * If PRINT_TYPE is in the flags the sxpr type is printed before the sxpr
117 * (for debugging).
118 *
119 * @param io stream to print to
120 * @param x sxpr to print
121 * @param flags print flags
122 * @return number of bytes written
123 */
124 int objprint(IOStream *io, Sxpr x, unsigned flags){
125 SxprType *def = get_sxpr_type(get_type(x));
126 ObjPrintFn *print_fn = (def && def->print ? def->print : default_print);
127 int k = 0;
128 if(!io) return k;
129 if(flags & PRINT_TYPE){
130 k += IOStream_print(io, "%s:", def->name);
131 }
132 k += print_fn(io, x, flags);
133 return k;
134 }
136 /** General sxpr free function.
137 * Frees an sxpr using the free function for its type.
138 * Free functions must recursively free any subsxprs.
139 * If no function is defined then the default is to
140 * free sxprs whose type has pointer true.
141 * Sxprs must not be used after freeing.
142 *
143 * @param x sxpr to free
144 */
145 void objfree(Sxpr x){
146 SxprType *def = get_sxpr_type(get_type(x));
148 if(def){
149 if(def->free){
150 def->free(x);
151 } else if (def->pointer){
152 hfree(x);
153 }
154 }
155 }
157 /** General sxpr equality function.
158 * Compares x and y using the equal function for x.
159 * Uses default_equal() if x has no equal function.
160 *
161 * @param x sxpr to compare
162 * @param y sxpr to compare
163 * @return 1 if equal, 0 otherwise
164 */
165 int objequal(Sxpr x, Sxpr y){
166 SxprType *def = get_sxpr_type(get_type(x));
167 ObjEqualFn *equal_fn = (def && def->equal ? def->equal : default_equal);
168 return equal_fn(x, y);
169 }
171 /** Search for a key in an alist.
172 * An alist is a list of conses, where the cars
173 * of the conses are the keys. Compares keys using equality.
174 *
175 * @param k key
176 * @param l alist to search
177 * @return first element of l with car k, or ONULL
178 */
179 Sxpr assoc(Sxpr k, Sxpr l){
180 for( ; CONSP(l) ; l = CDR(l)){
181 Sxpr x = CAR(l);
182 if(CONSP(x) && objequal(k, CAR(x))){
183 return x;
184 }
185 }
186 return ONULL;
187 }
189 /** Search for a key in an alist.
190 * An alist is a list of conses, where the cars
191 * of the conses are the keys. Compares keys using eq.
192 *
193 * @param k key
194 * @param l alist to search
195 * @return first element of l with car k, or ONULL
196 */
197 Sxpr assocq(Sxpr k, Sxpr l){
198 for( ; CONSP(l); l = CDR(l)){
199 Sxpr x = CAR(l);
200 if(CONSP(x) && eq(k, CAR(x))){
201 return x;
202 }
203 }
204 return ONULL;
205 }
207 /** Add a new key and value to an alist.
208 *
209 * @param k key
210 * @param l value
211 * @param l alist
212 * @return l with the new cell added to the front
213 */
214 Sxpr acons(Sxpr k, Sxpr v, Sxpr l){
215 Sxpr x, y;
216 x = cons_new(k, v);
217 if(NOMEMP(x)) return x;
218 y = cons_new(x, l);
219 if(NOMEMP(y)) cons_free_cells(x);
220 return y;
221 }
223 /** Test if a list contains an element.
224 * Uses sxpr equality.
225 *
226 * @param l list
227 * @param x element to look for
228 * @return a tail of l with x as car, or ONULL
229 */
230 Sxpr cons_member(Sxpr l, Sxpr x){
231 for( ; CONSP(l) && !eq(x, CAR(l)); l = CDR(l)){}
232 return l;
233 }
235 /** Test if a list contains an element satisfying a test.
236 * The test function is called with v and an element of the list.
237 *
238 * @param l list
239 * @param test_fn test function to use
240 * @param v value for first argument to the test
241 * @return a tail of l with car satisfying the test, or 0
242 */
243 Sxpr cons_member_if(Sxpr l, ObjEqualFn *test_fn, Sxpr v){
244 for( ; CONSP(l) && !test_fn(v, CAR(l)); l = CDR(l)){ }
245 return l;
246 }
248 /** Test if the elements of list 't' are a subset of the elements
249 * of list 's'. Element order is not significant.
250 *
251 * @param s element list to check subset of
252 * @param t element list to check if is a subset
253 * @return 1 if is a subset, 0 otherwise
254 */
255 int cons_subset(Sxpr s, Sxpr t){
256 for( ; CONSP(t); t = CDR(t)){
257 if(!CONSP(cons_member(s, CAR(t)))){
258 return 0;
259 }
260 }
261 return 1;
262 }
264 /** Test if two lists have equal sets of elements.
265 * Element order is not significant.
266 *
267 * @param s list to check
268 * @param t list to check
269 * @return 1 if equal, 0 otherwise
270 */
271 int cons_set_equal(Sxpr s, Sxpr t){
272 return cons_subset(s, t) && cons_subset(t, s);
273 }
275 #ifdef USE_GC
276 /*============================================================================*/
277 /* The functions inside this ifdef are only safe if GC is used.
278 * Otherwise they may leak memory.
279 */
281 /** Remove an element from a list (GC only).
282 * Uses sxpr equality and removes all instances, even
283 * if there are more than one.
284 *
285 * @param l list to remove elements from
286 * @param x element to remove
287 * @return modified input list
288 */
289 Sxpr cons_remove(Sxpr l, Sxpr x){
290 return cons_remove_if(l, eq, x);
291 }
293 /** Remove elements satisfying a test (GC only).
294 * The test function is called with v and an element of the set.
295 *
296 * @param l list to remove elements from
297 * @param test_fn function to use to decide if an element should be removed
298 * @return modified input list
299 */
300 Sxpr cons_remove_if(Sxpr l, ObjEqualFn *test_fn, Sxpr v){
301 Sxpr prev = ONULL, elt, next;
303 for(elt = l; CONSP(elt); elt = next){
304 next = CDR(elt);
305 if(test_fn(v, CAR(elt))){
306 if(NULLP(prev)){
307 l = next;
308 } else {
309 CDR(prev) = next;
310 }
311 }
312 }
313 return l;
314 }
316 /** Set the value for a key in an alist (GC only).
317 * If the key is present, changes the value, otherwise
318 * adds a new cell.
319 *
320 * @param k key
321 * @param v value
322 * @param l alist
323 * @return modified or extended list
324 */
325 Sxpr setf(Sxpr k, Sxpr v, Sxpr l){
326 Sxpr e = assoc(k, l);
327 if(NULLP(e)){
328 l = acons(k, v, l);
329 } else {
330 CAR(CDR(e)) = v;
331 }
332 return l;
333 }
334 /*============================================================================*/
335 #endif /* USE_GC */
337 /** Create a new atom with the given name.
338 *
339 * @param name the name
340 * @return new atom
341 */
342 Sxpr atom_new(char *name){
343 Sxpr n, obj = ONOMEM;
345 n = string_new(name);
346 if(NOMEMP(n)) goto exit;
347 obj = HALLOC(ObjAtom, T_ATOM);
348 if(NOMEMP(obj)) goto exit;
349 OBJ_ATOM(obj)->name = n;
350 exit:
351 return obj;
352 }
354 /** Free an atom.
355 *
356 * @param obj to free
357 */
358 void atom_free(Sxpr obj){
359 // Interned atoms are shared, so do not free.
360 if(OBJ_ATOM(obj)->interned) return;
361 objfree(OBJ_ATOM(obj)->name);
362 hfree(obj);
363 }
365 /** Print an atom. Prints the atom name.
366 *
367 * @param io stream to print to
368 * @param obj to print
369 * @param flags print flags
370 * @return number of bytes printed
371 */
372 int atom_print(IOStream *io, Sxpr obj, unsigned flags){
373 //return string_print(io, OBJ_ATOM(obj)->name, (flags | PRINT_RAW));
374 return string_print(io, OBJ_ATOM(obj)->name, flags);
375 }
377 /** Atom equality.
378 *
379 * @param x to compare
380 * @param y to compare
381 * @return 1 if equal, 0 otherwise
382 */
383 int atom_equal(Sxpr x, Sxpr y){
384 int ok;
385 ok = eq(x, y);
386 if(ok) goto exit;
387 ok = ATOMP(y) && string_equal(OBJ_ATOM(x)->name, OBJ_ATOM(y)->name);
388 if(ok) goto exit;
389 ok = STRINGP(y) && string_equal(OBJ_ATOM(x)->name, y);
390 exit:
391 return ok;
392 }
394 /** Get the name of an atom.
395 *
396 * @param obj atom
397 * @return name
398 */
399 char * atom_name(Sxpr obj){
400 return string_string(OBJ_ATOM(obj)->name);
401 }
403 /** Get the C string from a string sxpr.
404 *
405 * @param obj string sxpr
406 * @return string
407 */
408 char * string_string(Sxpr obj){
409 return OBJ_STRING(obj);
410 }
412 /** Get the length of a string.
413 *
414 * @param obj string
415 * @return length
416 */
417 int string_length(Sxpr obj){
418 return strlen(OBJ_STRING(obj));
419 }
421 /** Create a new string. The input string is copied,
422 * and must be null-terminated.
423 *
424 * @param s characters to put in the string
425 * @return new sxpr
426 */
427 Sxpr string_new(char *s){
428 int n = (s ? strlen(s) : 0);
429 Sxpr obj;
430 obj = halloc(n+1, T_STRING);
431 if(!NOMEMP(obj)){
432 char *str = OBJ_STRING(obj);
433 strncpy(str, s, n);
434 str[n] = '\0';
435 }
436 return obj;
437 }
439 /** Free a string.
440 *
441 * @param obj to free
442 */
443 void string_free(Sxpr obj){
444 hfree(obj);
445 }
447 /** Determine if a string needs escapes when printed
448 * using the given flags.
449 *
450 * @param str string to check
451 * @param flags print flags
452 * @return 1 if needs escapes, 0 otherwise
453 */
454 int needs_escapes(char *str, unsigned flags){
455 char *c;
456 int val = 0;
458 if(str){
459 for(c=str; *c; c++){
460 if(in_alpha_class(*c)) continue;
461 if(in_decimal_digit_class(*c)) continue;
462 if(in_class(*c, "/._+:@~-")) continue;
463 val = 1;
464 break;
465 }
466 }
467 //printf("\n> val=%d str=|%s|\n", val, str);
468 return val;
469 }
471 /** Print a string to a stream, with escapes if necessary.
472 *
473 * @param io stream to print to
474 * @param str string
475 * @param flags print flags
476 * @return number of bytes written
477 */
478 int _string_print(IOStream *io, char *str, unsigned flags){
479 int k = 0;
480 if((flags & PRINT_RAW) || !needs_escapes(str, flags)){
481 k += IOStream_print(io, str);
482 } else {
483 k += IOStream_print(io, "\"");
484 if(str){
485 char *s;
486 for(s = str; *s; s++){
487 if(*s < ' ' || *s >= 127 ){
488 switch(*s){
489 case '\a': k += IOStream_print(io, "\\a"); break;
490 case '\b': k += IOStream_print(io, "\\b"); break;
491 case '\f': k += IOStream_print(io, "\\f"); break;
492 case '\n': k += IOStream_print(io, "\\n"); break;
493 case '\r': k += IOStream_print(io, "\\r"); break;
494 case '\t': k += IOStream_print(io, "\\t"); break;
495 case '\v': k += IOStream_print(io, "\\v"); break;
496 default:
497 // Octal escape;
498 k += IOStream_print(io, "\\%o", *s);
499 break;
500 }
501 } else if(*s == c_double_quote ||
502 *s == c_single_quote ||
503 *s == c_escape){
504 k += IOStream_print(io, "\\%c", *s);
505 } else {
506 k+= IOStream_print(io, "%c", *s);
507 }
508 }
509 }
510 k += IOStream_print(io, "\"");
511 }
512 return k;
513 }
515 /** Print a string to a stream, with escapes if necessary.
516 *
517 * @param io stream to print to
518 * @param obj string
519 * @param flags print flags
520 * @return number of bytes written
521 */
522 int string_print(IOStream *io, Sxpr obj, unsigned flags){
523 return _string_print(io, OBJ_STRING(obj), flags);
524 }
526 /** Compare an sxpr with a string for equality.
527 *
528 * @param x string to compare with
529 * @param y sxpr to compare
530 * @return 1 if equal, 0 otherwise
531 */
532 int string_equal(Sxpr x, Sxpr y){
533 int ok = 0;
534 ok = eq(x,y);
535 if(ok) goto exit;
536 ok = has_type(y, T_STRING) && !strcmp(OBJ_STRING(x), OBJ_STRING(y));
537 if(ok) goto exit;
538 ok = has_type(y, T_ATOM) && !strcmp(OBJ_STRING(x), atom_name(y));
539 exit:
540 return ok;
541 }
543 /** Create a new cons cell.
544 * The cell is ONOMEM if either argument is.
545 *
546 * @param car sxpr for the car
547 * @param cdr sxpr for the cdr
548 * @return new cons
549 */
550 Sxpr cons_new(Sxpr car, Sxpr cdr){
551 Sxpr obj;
552 if(NOMEMP(car) || NOMEMP(cdr)){
553 obj = ONOMEM;
554 } else {
555 obj = HALLOC(ObjCons, T_CONS);
556 if(!NOMEMP(obj)){
557 ObjCons *z = OBJ_CONS(obj);
558 z->car = car;
559 z->cdr = cdr;
560 }
561 }
562 return obj;
563 }
565 /** Push a new element onto a list.
566 *
567 * @param list list to add to
568 * @param elt element to add
569 * @return 0 if successful, error code otherwise
570 */
571 int cons_push(Sxpr *list, Sxpr elt){
572 Sxpr l;
573 l = cons_new(elt, *list);
574 if(NOMEMP(l)) return -ENOMEM;
575 *list = l;
576 return 0;
577 }
579 /** Free a cons. Recursively frees the car and cdr.
580 *
581 * @param obj to free
582 */
583 void cons_free(Sxpr obj){
584 Sxpr next;
585 for(; CONSP(obj); obj = next){
586 next = CDR(obj);
587 objfree(CAR(obj));
588 hfree(obj);
589 }
590 if(!NULLP(obj)){
591 objfree(obj);
592 }
593 }
595 /** Free a cons and its cdr cells, but not the car sxprs.
596 * Does nothing if called on something that is not a cons.
597 *
598 * @param obj to free
599 */
600 void cons_free_cells(Sxpr obj){
601 Sxpr next;
602 for(; CONSP(obj); obj = next){
603 next = CDR(obj);
604 hfree(obj);
605 }
606 }
608 /** Print a cons.
609 * Prints the cons in list format if the cdrs are conses.
610 * uses pair (dot) format if the last cdr is not a cons (or null).
611 *
612 * @param io stream to print to
613 * @param obj to print
614 * @param flags print flags
615 * @return number of bytes written
616 */
617 int cons_print(IOStream *io, Sxpr obj, unsigned flags){
618 int first = 1;
619 int k = 0;
620 k += IOStream_print(io, "(");
621 for( ; CONSP(obj) ; obj = CDR(obj)){
622 if(first){
623 first = 0;
624 } else {
625 k += IOStream_print(io, " ");
626 }
627 k += objprint(io, CAR(obj), flags);
628 }
629 if(!NULLP(obj)){
630 k += IOStream_print(io, " . ");
631 k += objprint(io, obj, flags);
632 }
633 k += IOStream_print(io, ")");
634 return (IOStream_error(io) ? -1 : k);
635 }
637 /** Compare a cons with another sxpr for equality.
638 * If y is a cons, compares the cars and cdrs recursively.
639 *
640 * @param x cons to compare
641 * @param y sxpr to compare
642 * @return 1 if equal, 0 otherwise
643 */
644 int cons_equal(Sxpr x, Sxpr y){
645 return CONSP(y) &&
646 objequal(CAR(x), CAR(y)) &&
647 objequal(CDR(x), CDR(y));
648 }
650 /** Return the length of a cons list.
651 *
652 * @param obj list
653 * @return length
654 */
655 int cons_length(Sxpr obj){
656 int count = 0;
657 for( ; CONSP(obj); obj = CDR(obj)){
658 count++;
659 }
660 return count;
661 }
663 /** Destructively reverse a cons list in-place.
664 * If the argument is not a cons it is returned unchanged.
665 *
666 * @param l to reverse
667 * @return reversed list
668 */
669 Sxpr nrev(Sxpr l){
670 if(CONSP(l)){
671 // Iterate down the cells in the list making the cdr of
672 // each cell point to the previous cell. The last cell
673 // is the head of the reversed list.
674 Sxpr prev = ONULL;
675 Sxpr cell = l;
676 Sxpr next;
678 while(1){
679 next = CDR(cell);
680 CDR(cell) = prev;
681 if(!CONSP(next)) break;
682 prev = cell;
683 cell = next;
684 }
685 l = cell;
686 }
687 return l;
688 }
690 /** Print the null sxpr.
691 *
692 * @param io stream to print to
693 * @param obj to print
694 * @param flags print flags
695 * @return number of bytes written
696 */
697 static int null_print(IOStream *io, Sxpr obj, unsigned flags){
698 return IOStream_print(io, "()");
699 }
701 /** Print the `unspecified' sxpr none.
702 *
703 * @param io stream to print to
704 * @param obj to print
705 * @param flags print flags
706 * @return number of bytes written
707 */
708 static int none_print(IOStream *io, Sxpr obj, unsigned flags){
709 return IOStream_print(io, "<none>");
710 }
712 /** Print an integer.
713 *
714 * @param io stream to print to
715 * @param obj to print
716 * @param flags print flags
717 * @return number of bytes written
718 */
719 static int int_print(IOStream *io, Sxpr obj, unsigned flags){
720 return IOStream_print(io, "%d", OBJ_INT(obj));
721 }
723 /** Print a boolean.
724 *
725 * @param io stream to print to
726 * @param obj to print
727 * @param flags print flags
728 * @return number of bytes written
729 */
730 static int bool_print(IOStream *io, Sxpr obj, unsigned flags){
731 return IOStream_print(io, (OBJ_UINT(obj) ? k_true : k_false));
732 }
734 int sxprp(Sxpr obj, Sxpr name){
735 return CONSP(obj) && objequal(CAR(obj), name);
736 }
738 /** Get the name of an element.
739 *
740 * @param obj element
741 * @return name
742 */
743 Sxpr sxpr_name(Sxpr obj){
744 Sxpr val = ONONE;
745 if(CONSP(obj)){
746 val = CAR(obj);
747 } else if(STRINGP(obj) || ATOMP(obj)){
748 val = obj;
749 }
750 return val;
751 }
753 int sxpr_is(Sxpr obj, char *s){
754 if(ATOMP(obj)) return !strcmp(atom_name(obj), s);
755 if(STRINGP(obj)) return !strcmp(string_string(obj), s);
756 return 0;
757 }
759 int sxpr_elementp(Sxpr obj, Sxpr name){
760 int ok = 0;
761 ok = CONSP(obj) && objequal(CAR(obj), name);
762 return ok;
763 }
765 /** Get the attributes of an sxpr.
766 *
767 * @param obj sxpr
768 * @return attributes
769 */
770 Sxpr sxpr_attributes(Sxpr obj){
771 Sxpr val = ONULL;
772 if(CONSP(obj)){
773 obj = CDR(obj);
774 if(CONSP(obj)){
775 obj = CAR(obj);
776 if(sxprp(obj, intern("@"))){
777 val = CDR(obj);
778 }
779 }
780 }
781 return val;
782 }
784 Sxpr sxpr_attribute(Sxpr obj, Sxpr key, Sxpr def){
785 Sxpr val = ONONE;
786 val = assoc(sxpr_attributes(obj), key);
787 if(CONSP(val) && CONSP(CDR(val))){
788 val = CADR(def);
789 } else {
790 val = def;
791 }
792 return val;
793 }
795 /** Get the children of an sxpr.
796 *
797 * @param obj sxpr
798 * @return children
799 */
800 Sxpr sxpr_children(Sxpr obj){
801 Sxpr val = ONULL;
802 if(CONSP(obj)){
803 val = CDR(obj);
804 if(CONSP(val) && sxprp(CAR(val), intern("@"))){
805 val = CDR(val);
806 }
807 }
808 return val;
809 }
811 Sxpr sxpr_child(Sxpr obj, Sxpr name, Sxpr def){
812 Sxpr val = ONONE;
813 Sxpr l;
814 for(l = sxpr_children(obj); CONSP(l); l = CDR(l)){
815 if(sxprp(CAR(l), name)){
816 val = CAR(l);
817 break;
818 }
819 }
820 if(NONEP(val)) val = def;
821 return val;
822 }
824 Sxpr sxpr_child0(Sxpr obj, Sxpr def){
825 Sxpr val = ONONE;
826 Sxpr l = sxpr_children(obj);
827 if(CONSP(l)){
828 val = CAR(l);
829 } else {
830 val = def;
831 }
832 return val;
833 }
835 Sxpr sxpr_childN(Sxpr obj, int n, Sxpr def){
836 Sxpr val = def;
837 Sxpr l;
838 int i;
839 for (i = 0, l = sxpr_children(obj); CONSP(l); i++, l = CDR(l)){
840 if(i == n){
841 val = CAR(l);
842 break;
843 }
844 }
845 return val;
846 }
848 Sxpr sxpr_child_value(Sxpr obj, Sxpr name, Sxpr def){
849 Sxpr val = ONONE;
850 val = sxpr_child(obj, name, ONONE);
851 if(NONEP(val)){
852 val = def;
853 } else {
854 val = sxpr_child0(val, def);
855 }
856 return val;
857 }
859 /** Table of interned symbols. Indexed by symbol name. */
860 static HashTable *symbols = NULL;
862 /** Hash function for entries in the symbol table.
863 *
864 * @param key to hash
865 * @return hashcode
866 */
867 static Hashcode sym_hash_fn(void *key){
868 return hash_string((char*)key);
869 }
871 /** Key equality function for the symbol table.
872 *
873 * @param x to compare
874 * @param y to compare
875 * @return 1 if equal, 0 otherwise
876 */
877 static int sym_equal_fn(void *x, void *y){
878 return !strcmp((char*)x, (char*)y);
879 }
881 /** Entry free function for the symbol table.
882 *
883 * @param table the entry is in
884 * @param entry being freed
885 */
886 static void sym_free_fn(HashTable *table, HTEntry *entry){
887 if(entry){
888 objfree(((ObjAtom*)entry->value)->name);
889 HTEntry_free(entry);
890 }
891 }
893 /** Initialize the symbol table.
894 *
895 * @return 0 on sucess, error code otherwise
896 */
897 static int init_symbols(void){
898 symbols = HashTable_new(100);
899 if(symbols){
900 symbols->key_hash_fn = sym_hash_fn;
901 symbols->key_equal_fn = sym_equal_fn;
902 symbols->entry_free_fn = sym_free_fn;
903 return 0;
904 }
905 return -1;
906 }
908 /** Cleanup the symbol table. Frees the table and all its symbols.
909 */
910 void cleanup_symbols(void){
911 HashTable_free(symbols);
912 symbols = NULL;
913 }
915 /** Get the interned symbol with the given name.
916 * No new symbol is created.
917 *
918 * @return symbol or null
919 */
920 Sxpr get_symbol(char *sym){
921 HTEntry *entry;
922 if(!symbols){
923 if(init_symbols()) return ONOMEM;
924 return ONULL;
925 }
926 entry = HashTable_get_entry(symbols, sym);
927 if(entry){
928 return OBJP(T_ATOM, entry->value);
929 } else {
930 return ONULL;
931 }
932 }
934 /** Get the interned symbol with the given name.
935 * Creates a new symbol if necessary.
936 *
937 * @return symbol
938 */
939 Sxpr intern(char *sym){
940 Sxpr symbol = get_symbol(sym);
941 if(NULLP(symbol)){
942 if(!symbols) return ONOMEM;
943 symbol = atom_new(sym);
944 if(!NOMEMP(symbol)){
945 OBJ_ATOM(symbol)->interned = TRUE;
946 HashTable_add(symbols, atom_name(symbol), get_ptr(symbol));
947 }
948 }
949 return symbol;
950 }