unroff/src/scmtable.c

106 lines
2.5 KiB
C
Raw Permalink Normal View History

2023-02-13 08:45:50 -05:00
/* $Revision: 1.3 $
*/
/* The implementation of the Scheme type `table' and the primitives
* that work on tables. This file is basically an additional layer
* on top of the code in table.c.
*/
#include "unroff.h"
#define TABLE(x) ((struct s_table *)POINTER(x))
struct s_table {
Object tag;
Table *t;
};
static int T_Table;
static Object p_tablep(Object x) {
return TYPE(x) == T_Table ? True : False;
}
static int table_equal(Object t1, Object t2) {
return EQ(t1, t2);
}
static int table_print(Object x, Object port, int raw, int depth,
int length) {
Printf(port, "#[table %lu]", TABLE(x)->t);
return 0;
}
static Object terminate_table(Object x) {
table_delete(TABLE(x)->t);
return Void;
}
static Object p_make_table(Object size) {
Object t;
int s;
if ((s = Get_Integer(size)) <= 0)
Range_Error(size);
t = Alloc_Object(sizeof(struct s_table), T_Table, 0);
TABLE(t)->tag = Null;
TABLE(t)->t = table_new(s);
Register_Object(t, (GENERIC)0, terminate_table, 0);
return t;
}
static Object table_op(int op, Object t, Object key, Object val) {
Elem *p;
Object ret = Void;
char *data;
int size;
Table *tp;
Check_Type(t, T_Table);
tp = TABLE(t)->t;
if (TYPE(key) == T_Symbol)
key = SYMBOL(key)->name;
else if (TYPE(key) != T_String)
Wrong_Type_Combination(key, "string or symbol");
data = STRING(key)->data;
size = STRING(key)->size;
if (size == 0)
Primitive_Error("key must be of non-zero length");
switch(op) {
case 's':
table_store(tp, data, size, val, 0);
break;
case 'r':
table_remove(tp, data, size);
break;
case 'l':
if ((p = table_lookup(tp, data, size)) == 0)
ret = False;
else
ret = get_object(p->obj);
}
return ret;
}
static Object p_table_store(Object t, Object key, Object val) {
return table_op('s', t, key, val);
}
static Object p_table_remove(Object t, Object key) {
return table_op('r', t, key, Null);
}
static Object p_table_lookup(Object t, Object key) {
return table_op('l', t, key, Null);
}
void init_scmtable(void) {
T_Table = Define_Type(0, "table", NOFUNC, sizeof(struct s_table),
table_equal, table_equal, table_print, NOFUNC);
Define_Primitive(p_tablep, "table?", 1, 1, EVAL);
Define_Primitive(p_make_table, "make-table", 1, 1, EVAL);
Define_Primitive(p_table_store, "table-store!", 3, 3, EVAL);
Define_Primitive(p_table_remove, "table-remove!", 2, 2, EVAL);
Define_Primitive(p_table_lookup, "table-lookup", 2, 2, EVAL);
}