/* * * t k - g l u e . c - Glue function between the scheme and Tk worlds * * Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI * * * Permission to use, copy, modify, distribute,and license this * software and its documentation for any purpose is hereby granted, * provided that existing copyright notices are retained in all * copies and that this notice is included verbatim in any * distributions. No written agreement, license, or royalty fee is * required for any of the authorized uses. * This software is provided ``AS IS'' without express or implied * warranty. * * Author: Erick Gallesio [eg@unice.fr] * Creation date: 19-Feb-1993 22:15 * Last file update: 4-Sep-1999 14:26 (eg) * */ #ifdef USE_TK #include "stk.h" #include "tk-glue.h" #include "gc.h" #include "tkInt.h" #define MAXARG 64 /* Max args on stack. Use malloc if greater */ /* Scheme objects used to represent the "." pseudo widget and its name */ SCM STk_root_window; ; /* kept in a global to avoid application * termination if redfined as UNBOUND */ /* Last result of Tcl_GlobalEval (as a SCM object rather than a string) */ SCM STk_last_Tk_result; SCM STk_convert_tcl_list_to_scheme(SCM l) { if (!l) return NIL; if (NCONSP(l)) return TCLOBJP(l) ? TCLOBJDATA(l) : l; return Cons(STk_convert_tcl_list_to_scheme(CAR(l)), STk_convert_tcl_list_to_scheme(CDR(l))); } static SCM TkResult2Scheme(Tcl_Interp *interp, int objproc) { SCM res; if (objproc) { register SCM data = TCLOBJDATA((SCM) Tcl_GetObjResult(interp)); res = data ? STk_convert_tcl_list_to_scheme(data) : NIL; } else { register char *s = interp->result; res = (*s) ? STk_convert_Tcl_string2list(s) : NIL; } Tcl_ResetResult(interp); return res; } SCM STk_execute_Tcl_lib_cmd(SCM cmd, SCM args, SCM env, int eval_args) { char *buffer[MAXARG+2]; int tkres; char **argv = buffer; int argc = STk_llength(args); SCM conv_res, start = args; struct Tk_command *W = cmd->storage_as.tk.data; int objproc; objproc = W->objproc; if (argc >= MAXARG) { /* allocate dynamically the argv array (one extra for argv[0] and one * for the NULL terminator -dsf */ argv=(char **) must_malloc((argc+2) * sizeof(char *)); } /* First initialize an argv array */ if (objproc) { /* Objproc procedure (Tcl_8.0+) */ argv[0] = (char*) Tcl_NewStringObj(cmd->storage_as.tk.data->Id, -1); for (argc = 1; NNULLP(args); argc++, args=CDR(args)) { if (NCONSP(args)) Err("Malformed list of arguments", start); argv[argc] = (char*) STk_create_tcl_object(eval_args ? STk_eval(CAR(args), env): CAR(args)); } } else { /* Classical Tcl procedure */ /* * conv_res is (roughly) a vector of the values returned by convert_for_Tcl. * It serves only to have pointers in the stack on the converted values. * This permits to avoid GC problems (i.e. a GC between 1 and argc * whereas convert_for_Tcl has created new cells in a previous iteration */ conv_res = STk_makevect(argc+2, NIL); argv[0] = cmd->storage_as.tk.data->Id; for (argc = 1; NNULLP(args); argc++, args=CDR(args)) { if (NCONSP(args)) Err("Malformed list of arguments", start); argv[argc] = STk_convert_for_Tcl(eval_args? STk_eval(CAR(args),env): CAR(args), &(VECT(conv_res)[argc])); } } argv[argc] = NULL; /* Now, call the Tk library function */ Tcl_ResetResult(STk_main_interp); tkres = (*W->fct)(W->ptr, STk_main_interp, argc, argv); if (argv != buffer) { /* argv was allocated dynamically. Dispose it */ free(argv); } /* return result as a string or "evaluated" depending of string_result field */ if (tkres == TCL_OK) return TkResult2Scheme(STk_main_interp, objproc); /* if we are here, we had an error. Signal it */ if (objproc) { Tcl_Obj *mess = Tcl_GetObjResult(STk_main_interp); SCM msg; msg = TCLOBJDATA((SCM) mess); if (!msg) msg = NIL; if (NSTRINGP(msg)) Err("an error occured in a Tk procedure", msg); else Err(CHARS(msg), NIL); } else Err(STk_main_interp->result, NIL); return UNDEFINED; /* never reached */ } /****************************************************************************** * * Callback management * ******************************************************************************/ static Tcl_HashTable Tk_callbacks; int STk_valid_callback(char *s, void **closure) { /* A callback is valid iff it is of the form "#pxxxx" where xxxx is composed * only of hexadecimal digits. * Furthermore, the given address must be a valid adress */ int l = strlen(s); char *p; *closure = NULL; if (l > 2) { if (s[0] == '#' && s[1] == 'p') { /* Verify that the rest of the string only contains hexadecimal digits */ for (p = s + 2; *p; p++) if (!isxdigit(*p)) return FALSE; sscanf(s+2, "%lx", (unsigned long *) closure); if (!STk_valid_address((SCM) *closure)) return FALSE; } } return TRUE; } void STk_add_callback(char *key1, char *key2, char *key3, SCM closure) { Tcl_HashEntry *entry; Tcl_HashTable *secondary_hash_table; int new_entry; char key[200]; /* Largely sufficient */ if (*key2) { /* We have two keys. Use a secondary hash table */ if ((entry=Tcl_FindHashEntry(&Tk_callbacks, key1))) /* Key already in hash table */ secondary_hash_table = (Tcl_HashTable * ) Tcl_GetHashValue(entry); else { secondary_hash_table = (Tcl_HashTable *) must_malloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(secondary_hash_table, TCL_STRING_KEYS); entry = Tcl_CreateHashEntry(&Tk_callbacks, (char *) key1, &new_entry); Tcl_SetHashValue(entry, secondary_hash_table); } /* Enter a new key (obtained from key2 and key3) in the hash table. * Don't worry about old value: since it is no more pointed by the * hash table, it will be garbaged at next GC run */ sprintf(key, "%s#%s", key2, key3);/* Create a new key from key2 and key3 */ entry = Tcl_CreateHashEntry(secondary_hash_table, key, &new_entry); Tcl_SetHashValue(entry, closure); } else { /* Only one key. No need for a secondary hash table */ entry =Tcl_CreateHashEntry(&Tk_callbacks, key1, &new_entry); Tcl_SetHashValue(entry, closure); } } void STk_delete_callback(char *key) { /* * key is destroyed. We only need to free the entry associated to it in the * Tk_callback hash table (if it exists). */ Tcl_HashEntry *entry; Tcl_HashTable *secondary_hash_table; if ((entry=Tcl_FindHashEntry(&Tk_callbacks, key))) { if (*key != '(' && (*key == 'a' && strncmp(key, "after#", 6) != 0)) { /* Delete the secondary hash table associated to this entry */ secondary_hash_table = (Tcl_HashTable * ) Tcl_GetHashValue(entry); Tcl_DeleteHashTable(secondary_hash_table); free(secondary_hash_table); } /* Delete the entry itself */ Tcl_DeleteHashEntry(entry); } } void STk_mark_callbacks(void) { Tcl_HashEntry *entry1, *entry2; Tcl_HashSearch search1, search2; Tcl_HashTable *secondary; char *key; for (entry1 = Tcl_FirstHashEntry(&Tk_callbacks, &search1); entry1; entry1 = Tcl_NextHashEntry(&search1)) { key = Tcl_GetHashKey(&Tk_callbacks, entry1); if (*key == '(' || (*key == 'a' && strncmp(key, "after#", 6) == 0)) { /* No secondary hash table */ STk_gc_mark((SCM) Tcl_GetHashValue(entry1)); } else { /* We have a secondary hash table. Scan it */ secondary = (Tcl_HashTable * ) Tcl_GetHashValue(entry1); for (entry2 = Tcl_FirstHashEntry(secondary, &search2); entry2; entry2 = Tcl_NextHashEntry(&search2)) { STk_gc_mark((SCM) Tcl_GetHashValue(entry2)); } } } } /* * Return the parameters associated to the callback contained (as a string) * in the value parameter. If an error occurs, this function returns NULL * */ char *STk_append_callback_parameters(SCM proc) { SCM param, port; if (!CLOSUREP(proc)) return NULL; param = CLOSURE_PARAMETERS(proc); if (NULLP(param) || CONSP(param)) { port = STk_open_output_string(); STk_print(Cons(proc, param) , port, TK_MODE); return CHARS(STk_get_output_string(port)); } return NULL; } /****************************************************************************** * * Tcl result manipulation functions * ******************************************************************************/ void STk_sharp_dot_result(Tcl_Interp *interp, char *value) { /* Transform Tcl result in #.result so that it is evaluated when read */ int len = strlen(value); char *s; s = (char *) STk_must_malloc((size_t) len + 3); s[0] = '#'; s[1] = '.'; strcpy(s+2, value); Tcl_SetResult(interp, s, TCL_DYNAMIC); } void STk_stringify_result(Tcl_Interp *interp, char *value) { /* Transform Tcl result in "result" with " and \ escaped */ Tcl_SetResult(interp, STk_stringify(value, 0), TCL_DYNAMIC); } SCM STk_last_Tk_as_SCM(void) { return STk_last_Tk_result; } SCM STk_get_NIL_value(void) { return NIL; } SCM STk_get_widget_value(char *name) { return STk_lookup_variable(name, STk_Tk_module); } /****************************************************************************** * * Motif simulation * * Tk 4.0 uses a field in the Tk_Window structure to tell the library if it * must be conform to Motif look. This field is Tcl_LinkVar'ed. * ******************************************************************************/ static SCM get_Motif(char *s) { TkWindow *p = (TkWindow *) Tk_MainWindow(STk_main_interp); return (p->mainPtr->strictMotif) ? Truth: Ntruth; } static void set_Motif(char *s, SCM value) { TkWindow *p = (TkWindow *) Tk_MainWindow(STk_main_interp); p->mainPtr->strictMotif = !(value == Ntruth); } void STk_init_glue(void) { /* * Take into account the fact that Tk main window name (i.e. ``.'') * cannot be used in list since it leads to erroneous evaluation * (e.g. [focus .] would produce an error since read will find a malformed * pair). * */ STk_root_window = STk_lookup_variable(".", STk_Tk_module); STk_gc_protect(&STk_root_window); STk_define_variable(ROOT_WINDOW, STk_root_window, STk_Tk_module); /* Init the callback table */ Tcl_InitHashTable(&Tk_callbacks, TCL_STRING_KEYS); /* Associate a getter and a setter for the global variable *Tk-strict-Motif* */ STk_define_C_variable("*tk-strict-motif*", get_Motif, set_Motif); } #endif /* USE_TK */