diff options
Diffstat (limited to 'tools/libxutil/sxpr.c')
-rw-r--r-- | tools/libxutil/sxpr.c | 935 |
1 files changed, 935 insertions, 0 deletions
diff --git a/tools/libxutil/sxpr.c b/tools/libxutil/sxpr.c new file mode 100644 index 0000000000..adeffbe5eb --- /dev/null +++ b/tools/libxutil/sxpr.c @@ -0,0 +1,935 @@ +/* + * + * This library is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as + * published by the Free Software Foundation; either version 2.1 of the + * License, or (at your option) any later version. This library is + * distributed in the hope that it will be useful, but WITHOUT ANY + * WARRANTY; without even the implied warranty of MERCHANTABILITY or + * FITNESS FOR A PARTICULAR PURPOSE. + * See the GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this library; if not, write to the Free Software Foundation, + * Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include <stdarg.h> +#include "sys_string.h" +#include "lexis.h" +#include "sys_net.h" +#include "hash_table.h" +#include "sxpr.h" + +#include <errno.h> +#undef free + +/** @file + * General representation of sxprs. + * Includes print, equal, and free functions for the sxpr types. + * + * Zero memory containing an Sxpr will have the value ONONE - this is intentional. + * When a function returning an sxpr cannot allocate memory we return ONOMEM. + * + */ + +static int atom_print(IOStream *io, Sxpr obj, unsigned flags); +static int atom_equal(Sxpr x, Sxpr y); +static void atom_free(Sxpr obj); + +static int string_print(IOStream *io, Sxpr obj, unsigned flags); +static int string_equal(Sxpr x, Sxpr y); +static void string_free(Sxpr obj); + +static int cons_print(IOStream *io, Sxpr obj, unsigned flags); +static int cons_equal(Sxpr x, Sxpr y); +static void cons_free(Sxpr obj); + +static int null_print(IOStream *io, Sxpr obj, unsigned flags); +static int none_print(IOStream *io, Sxpr obj, unsigned flags); +static int int_print(IOStream *io, Sxpr obj, unsigned flags); +static int bool_print(IOStream *io, Sxpr obj, unsigned flags); + +/** Type definitions. */ +static SxprType types[1024] = { + [T_NONE] { type: T_NONE, name: "none", print: none_print }, + [T_NULL] { type: T_NULL, name: "null", print: null_print }, + [T_UINT] { type: T_UINT, name: "int", print: int_print, }, + [T_BOOL] { type: T_BOOL, name: "bool", print: bool_print, }, + [T_ATOM] { type: T_ATOM, name: "atom", print: atom_print, + pointer: TRUE, + free: atom_free, + equal: atom_equal, + }, + [T_STRING] { type: T_STRING, name: "string", print: string_print, + pointer: TRUE, + free: string_free, + equal: string_equal, + }, + [T_CONS] { type: T_CONS, name: "cons", print: cons_print, + pointer: TRUE, + free: cons_free, + equal: cons_equal, + }, +}; + +/** Number of entries in the types array. */ +static int type_sup = sizeof(types)/sizeof(types[0]); + +/** Get the type definition for a given type code. + * + * @param ty type code + * @return type definition or null + */ +SxprType *get_sxpr_type(int ty){ + if(0 <= ty && ty < type_sup){ + return types+ty; + } + return NULL; +} + +/** The default print function. + * + * @param io stream to print to + * @param x sxpr to print + * @param flags print flags + * @return number of bytes written on success + */ +int default_print(IOStream *io, Sxpr x, unsigned flags){ + return IOStream_print(io, "#<%u %lu>\n", get_type(x), get_ul(x)); +} + +/** The default equal function. + * Uses eq(). + * + * @param x sxpr to compare + * @param y sxpr to compare + * @return 1 if equal, 0 otherwise + */ +int default_equal(Sxpr x, Sxpr y){ + return eq(x, y); +} + +/** General sxpr print function. + * Prints an sxpr on a stream using the print function for the sxpr type. + * Printing is controlled by flags from the PrintFlags enum. + * If PRINT_TYPE is in the flags the sxpr type is printed before the sxpr + * (for debugging). + * + * @param io stream to print to + * @param x sxpr to print + * @param flags print flags + * @return number of bytes written + */ +int objprint(IOStream *io, Sxpr x, unsigned flags){ + SxprType *def = get_sxpr_type(get_type(x)); + ObjPrintFn *print_fn = (def && def->print ? def->print : default_print); + int k = 0; + if(!io) return k; + if(flags & PRINT_TYPE){ + k += IOStream_print(io, "%s:", def->name); + } + k += print_fn(io, x, flags); + return k; +} + +/** General sxpr free function. + * Frees an sxpr using the free function for its type. + * Free functions must recursively free any subsxprs. + * If no function is defined then the default is to + * free sxprs whose type has pointer true. + * Sxprs must not be used after freeing. + * + * @param x sxpr to free + */ +void objfree(Sxpr x){ + SxprType *def = get_sxpr_type(get_type(x)); + + if(def){ + if(def->free){ + def->free(x); + } else if (def->pointer){ + hfree(x); + } + } +} + +/** General sxpr equality function. + * Compares x and y using the equal function for x. + * Uses default_equal() if x has no equal function. + * + * @param x sxpr to compare + * @param y sxpr to compare + * @return 1 if equal, 0 otherwise + */ +int objequal(Sxpr x, Sxpr y){ + SxprType *def = get_sxpr_type(get_type(x)); + ObjEqualFn *equal_fn = (def && def->equal ? def->equal : default_equal); + return equal_fn(x, y); +} + +/** Search for a key in an alist. + * An alist is a list of conses, where the cars + * of the conses are the keys. Compares keys using equality. + * + * @param k key + * @param l alist to search + * @return first element of l with car k, or ONULL + */ +Sxpr assoc(Sxpr k, Sxpr l){ + for( ; CONSP(l) ; l = CDR(l)){ + Sxpr x = CAR(l); + if(CONSP(x) && objequal(k, CAR(x))){ + return x; + } + } + return ONULL; +} + +/** Search for a key in an alist. + * An alist is a list of conses, where the cars + * of the conses are the keys. Compares keys using eq. + * + * @param k key + * @param l alist to search + * @return first element of l with car k, or ONULL + */ +Sxpr assocq(Sxpr k, Sxpr l){ + for( ; CONSP(l); l = CDR(l)){ + Sxpr x = CAR(l); + if(CONSP(x) && eq(k, CAR(x))){ + return x; + } + } + return ONULL; +} + +/** Add a new key and value to an alist. + * + * @param k key + * @param l value + * @param l alist + * @return l with the new cell added to the front + */ +Sxpr acons(Sxpr k, Sxpr v, Sxpr l){ + Sxpr x, y; + x = cons_new(k, v); + if(NOMEMP(x)) return x; + y = cons_new(x, l); + if(NOMEMP(y)) cons_free_cells(x); + return y; +} + +/** Test if a list contains an element. + * Uses sxpr equality. + * + * @param l list + * @param x element to look for + * @return a tail of l with x as car, or ONULL + */ +Sxpr cons_member(Sxpr l, Sxpr x){ + for( ; CONSP(l) && !eq(x, CAR(l)); l = CDR(l)){} + return l; +} + +/** Test if a list contains an element satisfying a test. + * The test function is called with v and an element of the list. + * + * @param l list + * @param test_fn test function to use + * @param v value for first argument to the test + * @return a tail of l with car satisfying the test, or 0 + */ +Sxpr cons_member_if(Sxpr l, ObjEqualFn *test_fn, Sxpr v){ + for( ; CONSP(l) && !test_fn(v, CAR(l)); l = CDR(l)){ } + return l; +} + +/** Test if the elements of list 't' are a subset of the elements + * of list 's'. Element order is not significant. + * + * @param s element list to check subset of + * @param t element list to check if is a subset + * @return 1 if is a subset, 0 otherwise + */ +int cons_subset(Sxpr s, Sxpr t){ + for( ; CONSP(t); t = CDR(t)){ + if(!CONSP(cons_member(s, CAR(t)))){ + return 0; + } + } + return 1; +} + +/** Test if two lists have equal sets of elements. + * Element order is not significant. + * + * @param s list to check + * @param t list to check + * @return 1 if equal, 0 otherwise + */ +int cons_set_equal(Sxpr s, Sxpr t){ + return cons_subset(s, t) && cons_subset(t, s); +} + +#ifdef USE_GC +/*============================================================================*/ +/* The functions inside this ifdef are only safe if GC is used. + * Otherwise they may leak memory. + */ + +/** Remove an element from a list (GC only). + * Uses sxpr equality and removes all instances, even + * if there are more than one. + * + * @param l list to remove elements from + * @param x element to remove + * @return modified input list + */ +Sxpr cons_remove(Sxpr l, Sxpr x){ + return cons_remove_if(l, eq, x); +} + +/** Remove elements satisfying a test (GC only). + * The test function is called with v and an element of the set. + * + * @param l list to remove elements from + * @param test_fn function to use to decide if an element should be removed + * @return modified input list + */ +Sxpr cons_remove_if(Sxpr l, ObjEqualFn *test_fn, Sxpr v){ + Sxpr prev = ONULL, elt, next; + + for(elt = l; CONSP(elt); elt = next){ + next = CDR(elt); + if(test_fn(v, CAR(elt))){ + if(NULLP(prev)){ + l = next; + } else { + CDR(prev) = next; + } + } + } + return l; +} + +/** Set the value for a key in an alist (GC only). + * If the key is present, changes the value, otherwise + * adds a new cell. + * + * @param k key + * @param v value + * @param l alist + * @return modified or extended list + */ +Sxpr setf(Sxpr k, Sxpr v, Sxpr l){ + Sxpr e = assoc(k, l); + if(NULLP(e)){ + l = acons(k, v, l); + } else { + CAR(CDR(e)) = v; + } + return l; +} +/*============================================================================*/ +#endif /* USE_GC */ + +/** Create a new atom with the given name. + * + * @param name the name + * @return new atom + */ +Sxpr atom_new(char *name){ + Sxpr n, obj = ONOMEM; + + n = string_new(name); + if(NOMEMP(n)) goto exit; + obj = HALLOC(ObjAtom, T_ATOM); + if(NOMEMP(obj)) goto exit; + OBJ_ATOM(obj)->name = n; + exit: + return obj; +} + +/** Free an atom. + * + * @param obj to free + */ +void atom_free(Sxpr obj){ + // Interned atoms are shared, so do not free. + if(OBJ_ATOM(obj)->interned) return; + objfree(OBJ_ATOM(obj)->name); + hfree(obj); +} + +/** Print an atom. Prints the atom name. + * + * @param io stream to print to + * @param obj to print + * @param flags print flags + * @return number of bytes printed + */ +int atom_print(IOStream *io, Sxpr obj, unsigned flags){ + //return string_print(io, OBJ_ATOM(obj)->name, (flags | PRINT_RAW)); + return string_print(io, OBJ_ATOM(obj)->name, flags); +} + +/** Atom equality. + * + * @param x to compare + * @param y to compare + * @return 1 if equal, 0 otherwise + */ +int atom_equal(Sxpr x, Sxpr y){ + int ok; + ok = eq(x, y); + if(ok) goto exit; + ok = ATOMP(y) && string_equal(OBJ_ATOM(x)->name, OBJ_ATOM(y)->name); + if(ok) goto exit; + ok = STRINGP(y) && string_equal(OBJ_ATOM(x)->name, y); + exit: + return ok; +} + +/** Get the name of an atom. + * + * @param obj atom + * @return name + */ +char * atom_name(Sxpr obj){ + return string_string(OBJ_ATOM(obj)->name); +} + +/** Get the C string from a string sxpr. + * + * @param obj string sxpr + * @return string + */ +char * string_string(Sxpr obj){ + return OBJ_STRING(obj); +} + +/** Get the length of a string. + * + * @param obj string + * @return length + */ +int string_length(Sxpr obj){ + return strlen(OBJ_STRING(obj)); +} + +/** Create a new string. The input string is copied, + * and must be null-terminated. + * + * @param s characters to put in the string + * @return new sxpr + */ +Sxpr string_new(char *s){ + int n = (s ? strlen(s) : 0); + Sxpr obj; + obj = halloc(n+1, T_STRING); + if(!NOMEMP(obj)){ + char *str = OBJ_STRING(obj); + strncpy(str, s, n); + str[n] = '\0'; + } + return obj; +} + +/** Free a string. + * + * @param obj to free + */ +void string_free(Sxpr obj){ + hfree(obj); +} + +/** Determine if a string needs escapes when printed + * using the given flags. + * + * @param str string to check + * @param flags print flags + * @return 1 if needs escapes, 0 otherwise + */ +int needs_escapes(char *str, unsigned flags){ + char *c; + int val = 0; + + if(str){ + for(c=str; *c; c++){ + if(in_alpha_class(*c)) continue; + if(in_decimal_digit_class(*c)) continue; + if(in_class(*c, "/._+:@~-")) continue; + val = 1; + break; + } + } + //printf("\n> val=%d str=|%s|\n", val, str); + return val; +} + +/** Print a string to a stream, with escapes if necessary. + * + * @param io stream to print to + * @param str string + * @param flags print flags + * @return number of bytes written + */ +int _string_print(IOStream *io, char *str, unsigned flags){ + int k = 0; + if((flags & PRINT_RAW) || !needs_escapes(str, flags)){ + k += IOStream_print(io, str); + } else { + k += IOStream_print(io, "\""); + if(str){ + char *s; + for(s = str; *s; s++){ + if(*s < ' ' || *s >= 127 ){ + switch(*s){ + case '\a': k += IOStream_print(io, "\\a"); break; + case '\b': k += IOStream_print(io, "\\b"); break; + case '\f': k += IOStream_print(io, "\\f"); break; + case '\n': k += IOStream_print(io, "\\n"); break; + case '\r': k += IOStream_print(io, "\\r"); break; + case '\t': k += IOStream_print(io, "\\t"); break; + case '\v': k += IOStream_print(io, "\\v"); break; + default: + // Octal escape; + k += IOStream_print(io, "\\%o", *s); + break; + } + } else if(*s == c_double_quote || + *s == c_single_quote || + *s == c_escape){ + k += IOStream_print(io, "\\%c", *s); + } else { + k+= IOStream_print(io, "%c", *s); + } + } + } + k += IOStream_print(io, "\""); + } + return k; +} + +/** Print a string to a stream, with escapes if necessary. + * + * @param io stream to print to + * @param obj string + * @param flags print flags + * @return number of bytes written + */ +int string_print(IOStream *io, Sxpr obj, unsigned flags){ + return _string_print(io, OBJ_STRING(obj), flags); +} + +/** Compare an sxpr with a string for equality. + * + * @param x string to compare with + * @param y sxpr to compare + * @return 1 if equal, 0 otherwise + */ +int string_equal(Sxpr x, Sxpr y){ + int ok = 0; + ok = eq(x,y); + if(ok) goto exit; + ok = has_type(y, T_STRING) && !strcmp(OBJ_STRING(x), OBJ_STRING(y)); + if(ok) goto exit; + ok = has_type(y, T_ATOM) && !strcmp(OBJ_STRING(x), atom_name(y)); + exit: + return ok; +} + +/** Create a new cons cell. + * The cell is ONOMEM if either argument is. + * + * @param car sxpr for the car + * @param cdr sxpr for the cdr + * @return new cons + */ +Sxpr cons_new(Sxpr car, Sxpr cdr){ + Sxpr obj; + if(NOMEMP(car) || NOMEMP(cdr)){ + obj = ONOMEM; + } else { + obj = HALLOC(ObjCons, T_CONS); + if(!NOMEMP(obj)){ + ObjCons *z = OBJ_CONS(obj); + z->car = car; + z->cdr = cdr; + } + } + return obj; +} + +/** Push a new element onto a list. + * + * @param list list to add to + * @param elt element to add + * @return 0 if successful, error code otherwise + */ +int cons_push(Sxpr *list, Sxpr elt){ + Sxpr l; + l = cons_new(elt, *list); + if(NOMEMP(l)) return -ENOMEM; + *list = l; + return 0; +} + +/** Free a cons. Recursively frees the car and cdr. + * + * @param obj to free + */ +void cons_free(Sxpr obj){ + Sxpr next; + for(; CONSP(obj); obj = next){ + next = CDR(obj); + objfree(CAR(obj)); + hfree(obj); + } + if(!NULLP(obj)){ + objfree(obj); + } +} + +/** Free a cons and its cdr cells, but not the car sxprs. + * Does nothing if called on something that is not a cons. + * + * @param obj to free + */ +void cons_free_cells(Sxpr obj){ + Sxpr next; + for(; CONSP(obj); obj = next){ + next = CDR(obj); + hfree(obj); + } +} + +/** Print a cons. + * Prints the cons in list format if the cdrs are conses. + * uses pair (dot) format if the last cdr is not a cons (or null). + * + * @param io stream to print to + * @param obj to print + * @param flags print flags + * @return number of bytes written + */ +int cons_print(IOStream *io, Sxpr obj, unsigned flags){ + int first = 1; + int k = 0; + k += IOStream_print(io, "("); + for( ; CONSP(obj) ; obj = CDR(obj)){ + if(first){ + first = 0; + } else { + k += IOStream_print(io, " "); + } + k += objprint(io, CAR(obj), flags); + } + if(!NULLP(obj)){ + k += IOStream_print(io, " . "); + k += objprint(io, obj, flags); + } + k += IOStream_print(io, ")"); + return (IOStream_error(io) ? -1 : k); +} + +/** Compare a cons with another sxpr for equality. + * If y is a cons, compares the cars and cdrs recursively. + * + * @param x cons to compare + * @param y sxpr to compare + * @return 1 if equal, 0 otherwise + */ +int cons_equal(Sxpr x, Sxpr y){ + return CONSP(y) && + objequal(CAR(x), CAR(y)) && + objequal(CDR(x), CDR(y)); +} + +/** Return the length of a cons list. + * + * @param obj list + * @return length + */ +int cons_length(Sxpr obj){ + int count = 0; + for( ; CONSP(obj); obj = CDR(obj)){ + count++; + } + return count; +} + +/** Destructively reverse a cons list in-place. + * If the argument is not a cons it is returned unchanged. + * + * @param l to reverse + * @return reversed list + */ +Sxpr nrev(Sxpr l){ + if(CONSP(l)){ + // Iterate down the cells in the list making the cdr of + // each cell point to the previous cell. The last cell + // is the head of the reversed list. + Sxpr prev = ONULL; + Sxpr cell = l; + Sxpr next; + + while(1){ + next = CDR(cell); + CDR(cell) = prev; + if(!CONSP(next)) break; + prev = cell; + cell = next; + } + l = cell; + } + return l; +} + +/** Print the null sxpr. + * + * @param io stream to print to + * @param obj to print + * @param flags print flags + * @return number of bytes written + */ +static int null_print(IOStream *io, Sxpr obj, unsigned flags){ + return IOStream_print(io, "()"); +} + +/** Print the `unspecified' sxpr none. + * + * @param io stream to print to + * @param obj to print + * @param flags print flags + * @return number of bytes written + */ +static int none_print(IOStream *io, Sxpr obj, unsigned flags){ + return IOStream_print(io, "<none>"); +} + +/** Print an integer. + * + * @param io stream to print to + * @param obj to print + * @param flags print flags + * @return number of bytes written + */ +static int int_print(IOStream *io, Sxpr obj, unsigned flags){ + return IOStream_print(io, "%d", OBJ_INT(obj)); +} + +/** Print a boolean. + * + * @param io stream to print to + * @param obj to print + * @param flags print flags + * @return number of bytes written + */ +static int bool_print(IOStream *io, Sxpr obj, unsigned flags){ + return IOStream_print(io, (OBJ_UINT(obj) ? k_true : k_false)); +} + +int sxprp(Sxpr obj, Sxpr name){ + return CONSP(obj) && objequal(CAR(obj), name); +} + +/** Get the name of an element. + * + * @param obj element + * @return name + */ +Sxpr sxpr_name(Sxpr obj){ + Sxpr val = ONONE; + if(CONSP(obj)){ + val = CAR(obj); + } else if(STRINGP(obj) || ATOMP(obj)){ + val = obj; + } + return val; +} + +int sxpr_is(Sxpr obj, char *s){ + if(ATOMP(obj)) return !strcmp(atom_name(obj), s); + if(STRINGP(obj)) return !strcmp(string_string(obj), s); + return 0; +} + +int sxpr_elementp(Sxpr obj, Sxpr name){ + return CONSP(obj) && objequal(CAR(obj), name); +} + +/** Get the attributes of an sxpr. + * + * @param obj sxpr + * @return attributes + */ +Sxpr sxpr_attributes(Sxpr obj){ + Sxpr val = ONULL; + if(CONSP(obj)){ + obj = CDR(obj); + if(CONSP(obj)){ + obj = CAR(obj); + if(sxprp(obj, intern("@"))){ + val = CDR(obj); + } + } + } + return val; +} + +Sxpr sxpr_attribute(Sxpr obj, Sxpr key, Sxpr def){ + Sxpr val = ONONE; + val = assoc(sxpr_attributes(obj), key); + if(CONSP(val) && CONSP(CDR(val))){ + val = CADR(def); + } else { + val = def; + } + return val; +} + +/** Get the children of an sxpr. + * + * @param obj sxpr + * @return children + */ +Sxpr sxpr_children(Sxpr obj){ + Sxpr val = ONULL; + if(CONSP(obj)){ + val = CDR(obj); + if(CONSP(val) && sxprp(CAR(val), intern("@"))){ + val = CDR(val); + } + } + return val; +} + +Sxpr sxpr_child(Sxpr obj, Sxpr name, Sxpr def){ + Sxpr val = ONONE; + Sxpr l; + for(l = sxpr_children(obj); CONSP(l); l = CDR(l)){ + if(sxprp(CAR(l), name)){ + val = CAR(l); + break; + } + } + if(NONEP(val)) val = def; + return val; +} + +Sxpr sxpr_child0(Sxpr obj, Sxpr def){ + Sxpr val = ONONE; + Sxpr l = sxpr_children(obj); + if(CONSP(l)){ + val = CAR(l); + } else { + val = def; + } + return val; +} + +Sxpr sxpr_child_value(Sxpr obj, Sxpr name, Sxpr def){ + Sxpr val = ONONE; + val = sxpr_child(obj, name, ONONE); + if(NONEP(val)){ + val = def; + } else { + val = sxpr_child0(val, def); + } + return val; +} + +/** Table of interned symbols. Indexed by symbol name. */ +static HashTable *symbols = NULL; + +/** Hash function for entries in the symbol table. + * + * @param key to hash + * @return hashcode + */ +static Hashcode sym_hash_fn(void *key){ + return hash_string((char*)key); +} + +/** Key equality function for the symbol table. + * + * @param x to compare + * @param y to compare + * @return 1 if equal, 0 otherwise + */ +static int sym_equal_fn(void *x, void *y){ + return !strcmp((char*)x, (char*)y); +} + +/** Entry free function for the symbol table. + * + * @param table the entry is in + * @param entry being freed + */ +static void sym_free_fn(HashTable *table, HTEntry *entry){ + if(entry){ + objfree(((ObjAtom*)entry->value)->name); + HTEntry_free(entry); + } +} + +/** Initialize the symbol table. + * + * @return 0 on sucess, error code otherwise + */ +static int init_symbols(void){ + symbols = HashTable_new(100); + if(symbols){ + symbols->key_hash_fn = sym_hash_fn; + symbols->key_equal_fn = sym_equal_fn; + symbols->entry_free_fn = sym_free_fn; + return 0; + } + return -1; +} + +/** Cleanup the symbol table. Frees the table and all its symbols. + */ +void cleanup_symbols(void){ + HashTable_free(symbols); + symbols = NULL; +} + +/** Get the interned symbol with the given name. + * No new symbol is created. + * + * @return symbol or null + */ +Sxpr get_symbol(char *sym){ + HTEntry *entry; + if(!symbols){ + if(init_symbols()) return ONOMEM; + return ONULL; + } + entry = HashTable_get_entry(symbols, sym); + if(entry){ + return OBJP(T_ATOM, entry->value); + } else { + return ONULL; + } +} + +/** Get the interned symbol with the given name. + * Creates a new symbol if necessary. + * + * @return symbol + */ +Sxpr intern(char *sym){ + Sxpr symbol = get_symbol(sym); + if(NULLP(symbol)){ + if(!symbols) return ONOMEM; + symbol = atom_new(sym); + if(!NOMEMP(symbol)){ + OBJ_ATOM(symbol)->interned = TRUE; + HashTable_add(symbols, atom_name(symbol), get_ptr(symbol)); + } + } + return symbol; +} |