/* $Revision: 1.15 $ */ /* Scheme primitives that define and query event procedures, and * functions to lookup and execute events. */ #include "unroff.h" #define NUM_VEC_EVENTS 6 static Table *requests, *numregs, *specials, *escapes, *chars, *others; static Table *fallbacks; static Object Key_Equation, Key_Sentence; Object eventsvec; static SYMDESCR event_syms[] = { { "line", EV_LINE }, { "prolog", EV_PROLOG }, { "epilog", EV_EPILOG }, { "option", EV_OPTION }, { "start", EV_START }, { "exit", EV_EXIT }, { 0, 0 } }; static char *event_names[] = { "line event", "prolog event", "epilog event", "option event", "start event", "exit event", "request", "macro", "string", "number register", "special character", "inline equation", "sentence event", "escape sequence", "character event", }; static Object make_event_object(Object x) { switch (TYPE(x)) { case T_Null: case T_Compound: case T_String: case T_Character: case T_Symbol: return x; case T_Primitive: Primitive_Error("event function must be a compound procedure"); default: if (EQ(x, False)) return x; Primitive_Error("invalid event value argument"); } } static Object store_event(Table *tp, char *key, int size, Object obj, char flags) { Elem *oldp; Object ret = False; if ((oldp = table_lookup(tp, key, size)) != 0) ret = get_object(oldp->obj); if (!Nullp(obj)) if (EQ(obj, False)) table_remove(tp, key, size); else table_store(tp, key, size, obj, (unsigned long)flags); return ret; } static Object def_indexed(Table *tp, Object key, Object obj, char flags, char *code) { if (TYPE(key) == T_Symbol) key = SYMBOL(key)->name; else if (TYPE(key) != T_String) Wrong_Type_Combination(key, "string or symbol"); if (STRING(key)->size == 0) { if (*code != 'r' && *code != 'p') Primitive_Error("event key must be of non-zero length"); return store_event(fallbacks, code, 1, make_event_object(obj), flags); } return store_event(tp, STRING(key)->data, STRING(key)->size, make_event_object(obj), flags); } static Object p_defrequest(Object key, Object obj) { return def_indexed(requests, key, obj, 0, "r"); } static Object p_defmacro(Object key, Object obj) { return def_indexed(requests, key, obj, RQ_MACRO, "m"); } static Object p_defstring(Object key, Object obj) { return def_indexed(requests, key, obj, RQ_STRING, "s"); } static Object p_defnumreg(Object key, Object obj) { return def_indexed(numregs, key, obj, 0, "n"); } static Object p_defspecial(Object key, Object obj) { return def_indexed(specials, key, obj, 0, "p"); } static Object p_defequation(Object obj) { return def_indexed(others, Key_Equation, obj, 0, 0); } static Object p_defsentence(Object obj) { return def_indexed(others, Key_Sentence, obj, 0, 0); } static Object p_requestdef(Object key) { return def_indexed(requests, key, Null, 0, "r"); } static Object p_macrodef(Object key) { return def_indexed(requests, key, Null, 0, "m"); } static Object p_stringdef(Object key) { return def_indexed(requests, key, Null, 0, "s"); } static Object p_numregdef(Object key) { return def_indexed(numregs, key, Null, 0, "n"); } static Object p_specialdef(Object key) { return def_indexed(specials, key, Null, 0, "p"); } static Object p_equationdef(void) { return def_indexed(others, Key_Equation, Null, 0, 0); } static Object p_sentencedef(void) { return def_indexed(others, Key_Sentence, Null, 0, 0); } static Object def_char_event(Table *tp, Object key, Object obj) { char c; switch (TYPE(key)) { case T_Character: c = CHAR(key); break; case T_Symbol: key = SYMBOL(key)->name; /* fall through */ case T_String: if (tp == escapes && STRING(key)->size == 0) return store_event(fallbacks, "e", 1, make_event_object(obj), 0); if (STRING(key)->size != 1) goto err; c = STRING(key)->data[0]; break; default: err: Primitive_Error("cannot coerce argument to character"); } return store_event(tp, &c, 1, make_event_object(obj), 0); } Object p_defescape(Object key, Object obj) { return def_char_event(escapes, key, obj); } Object p_defchar(Object key, Object obj) { return def_char_event(chars, key, obj); } Object p_escapedef(Object key) { return def_char_event(escapes, key, Null); } Object p_chardef(Object key) { return def_char_event(chars, key, Null); } Elem *event_lookup(Event e, char *key, int size) { Elem *p; if (key && size == 0) { switch(e) { case EV_REQUEST: return table_lookup(fallbacks, "r", 1); /* not yet */ case EV_MACRO: return table_lookup(fallbacks, "m", 1); /* not yet */ case EV_SPECIAL: return table_lookup(fallbacks, "p", 1); case EV_ESCAPE: return table_lookup(fallbacks, "e", 1); default: assert(0); } } else { switch (e) { case EV_REQUEST: return ((p = table_lookup(requests, key, size)) && !(p->flags & RQ_MACRO)) ? p : 0; case EV_MACRO: return ((p = table_lookup(requests, key, size)) && (p->flags & RQ_MACRO)) ? p : 0; case EV_STRING: return table_lookup(requests, key, size); case EV_NUMREG: return table_lookup(numregs, key, size); case EV_SPECIAL: return table_lookup(specials, key, size); case EV_ESCAPE: return table_lookup(escapes, key, size); case EV_CHAR: assert(size == 1); return table_lookup(chars, key, size); case EV_EQUATION: return table_lookup(others, "e", 1); case EV_SENTENCE: return table_lookup(others, "s", 1); case EV_LINE: case EV_PROLOG: case EV_EPILOG: case EV_OPTION: case EV_START: case EV_EXIT: default: assert(0); } } return 0; /* shut up gcc -W */ } static int check_num_args(Object fun, int num, char *evnam) { char *s = 0; struct S_Compound *comp = COMPOUND(fun); if (num < comp->min_args) s = "few"; else if (comp->max_args >= 0 && num > comp->max_args) s = "many"; if (s) warn("too %s arguments for %s function", s, evnam); return !s; } char *event_exec(Event e, char *key, int size, int *size_ret, int complain) { Elem *p = event_lookup(e, key, size); Object ret; char *name = event_names[e]; static char c; if (p) { if ((e == EV_REQUEST || e == EV_MACRO) && (p->flags & RQ_STRING)) { warn("cannot execute string as request or macro"); return 0; } if (e == EV_STRING && !(p->flags & RQ_STRING)) { warn("cannot execute request or macro as string"); return 0; } ret = get_object(p->obj); if (TYPE(ret) == T_Compound) { if (!check_num_args(ret, args_num(), name)) return 0; ret = Funcall(ret, args_get(), 0); } assert(size_ret != 0); switch (TYPE(ret)) { case T_Character: c = CHAR(ret); *size_ret = 1; return &c; case T_Symbol: ret = SYMBOL(ret)->name; /* fall through */ case T_String: *size_ret = STRING(ret)->size; return STRING(ret)->data; default: warn("cannot coerce result of %s function to string", name); return 0; } } if (complain) warn("no event value for %s `%s'", name, printable_string(key, size)); return 0; } char *event_exec_fallback(Event e, char *key, int size, int *size_ret) { if (!event_lookup(e, key, size) && event_lookup(e, "", 0)) return event_exec(e, "", 0, size_ret, 1); else return event_exec(e, key, size, size_ret, 1); } static Object store_vec_event(int e, Object pri, Object obj) { Object ret, v = VECTOR(eventsvec)->data[e]; int p = Get_Integer(pri); if (p < 0 || p > 99) Range_Error(pri); ret = VECTOR(v)->data[p]; if (!Nullp(obj)) VECTOR(v)->data[p] = obj; return ret; } static Object p_defevent(Object event, Object pri, Object obj) { char e = Symbols_To_Bits(event, 0, event_syms); if (Truep(obj) && TYPE(obj) != T_Compound) Wrong_Type_Combination(obj, "compound procedure or #f"); return store_vec_event(e, pri, obj); } static Object p_eventdef(Object event, Object pri) { char e = Symbols_To_Bits(event, 0, event_syms); return store_vec_event(e, pri, Null); } void events_vec_exec(Event e) { Object func, v; int i; for (i = 0; i < 100; i++) { v = VECTOR(eventsvec)->data[e]; func = VECTOR(v)->data[i]; if (Truep(func) && check_num_args(func, args_num(), event_names[e])) (void)Funcall(func, args_get(), 0); } } void init_event(void) { int i; requests = table_new(256*256); numregs = table_new(256*256); specials = table_new(256*256); escapes = table_new(256); chars = table_new(256); others = table_new(10); fallbacks = table_new(256); Key_Equation = Make_String("e", 1); Global_GC_Link(Key_Equation); Key_Sentence = Make_String("s", 1); Global_GC_Link(Key_Sentence); eventsvec = Make_Vector(NUM_VEC_EVENTS, Null); Global_GC_Link(eventsvec); for (i = 0; i < NUM_VEC_EVENTS; i++) VECTOR(eventsvec)->data[i] = Make_Vector(100, False); Define_Primitive(p_defrequest, "defrequest", 2, 2, EVAL); Define_Primitive(p_defmacro, "defmacro", 2, 2, EVAL); Define_Primitive(p_defstring, "defstring", 2, 2, EVAL); Define_Primitive(p_defnumreg, "defnumreg", 2, 2, EVAL); Define_Primitive(p_defspecial, "defspecial", 2, 2, EVAL); Define_Primitive(p_defequation, "defequation", 1, 1, EVAL); Define_Primitive(p_defsentence, "defsentence", 1, 1, EVAL); Define_Primitive(p_defescape, "defescape", 2, 2, EVAL); Define_Primitive(p_defchar, "defchar", 2, 2, EVAL); Define_Primitive(p_defevent, "defevent", 3, 3, EVAL); Define_Primitive(p_requestdef, "requestdef", 1, 1, EVAL); Define_Primitive(p_macrodef, "macrodef", 1, 1, EVAL); Define_Primitive(p_stringdef, "stringdef", 1, 1, EVAL); Define_Primitive(p_numregdef, "numregdef", 1, 1, EVAL); Define_Primitive(p_specialdef, "specialdef", 1, 1, EVAL); Define_Primitive(p_equationdef, "equationdef", 0, 0, EVAL); Define_Primitive(p_sentencedef, "sentencedef", 0, 0, EVAL); Define_Primitive(p_escapedef, "escapedef", 1, 1, EVAL); Define_Primitive(p_chardef, "chardef", 1, 1, EVAL); Define_Primitive(p_eventdef, "eventdef", 2, 2, EVAL); }