/* * * t k - g l u e . c - Glue function between the scheme and Tk worlds * * Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI * * * Permission to use, copy, and/or distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that both the above copyright notice and this permission notice appear in * all copies and derived works. Fees for distribution or use of this * software or derived works may only be charged with express written * permission of the copyright holder. * This software is provided ``as is'' without express or implied warranty. * * This software is a derivative work of other copyrighted softwares; the * copyright notices of these softwares are placed in the file COPYRIGHTS * * * Author: Erick Gallesio [eg@unice.fr] * Creation date: 19-Feb-1993 22:15 * Last file update: 26-Apr-1995 23:45 * * */ #ifdef USE_TK #include #include "stk.h" #include "tk-glue.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, STk_root_window_name; /* * In STk, result of a Tk primitive result is parsed to try to have a * a result whose type is as convenient as possible. * However, certain command results are kept as string to avoid problems. */ static char *keeping[] = { "option", "selection", "tk", "wm", "" }; static void Keep_result_as_string(char *s) { SCM tmp = VCELL(Intern(s)); if (TKCOMMP(tmp)) tmp->storage_as.tk.data->string_result = 1; } static SCM TkResult2Scheme(Tcl_Interp *interp) { register char*s= interp->result; register SCM tmp1, tmp2, z, port; SCM result = NIL; int eof; if (*s) { /* Create a string port to read in the result */ port = STk_internal_open_input_string(s); result = STk_internal_read_from_string(port, &eof, TRUE); if (result == Sym_dot) result = STk_root_window_name; if (!eof) { /* Result was a list of value, build a proper Scheme list */ tmp1 = result = LIST1(result); for ( ; ; ) { z = STk_internal_read_from_string(port, &eof, TRUE); if (z == EVAL_ERROR || EOFP(z)) break; if (z == Sym_dot) z = STk_root_window_name; NEWCELL(tmp2, tc_cons); CAR(tmp2) = z; CDR(tmp1) = tmp2; tmp1 = tmp2; } CDR(tmp1) = NIL; } /* close_string_port(port); */ } Tcl_ResetResult(interp); return (result == EVAL_ERROR)? UNDEFINED: result; } static SCM TkResult2String(Tcl_Interp *interp) { register char *tmp, *d, *s= interp->result; register int len,newlen; SCM z; /* Build a Scheme string from Tk result and free the interp->result */ len = newlen = strlen(s); tmp = d = must_malloc(len+1); /* overestimation */ while (len--) { if (*s == '\\') {s++; newlen--;} *d++ = *s++; } /* Create a new Scheme string */ NEWCELL(z, tc_string); z->storage_as.string.dim = newlen; z->storage_as.string.data = tmp; z->storage_as.string.data[newlen] = 0; Tcl_ResetResult(interp); return z; } char *STk_convert_for_tk(SCM obj, SCM *res) { switch (TYPE(obj)) { case tc_symbol: *res = obj; return PNAME(obj); case tc_integer: case tc_bignum: case tc_flonum: *res = STk_number2string(obj, UNBOUND); return CHARS(*res); case tc_string: *res = obj; return CHARS(obj); case tc_tkcommand: return (obj->storage_as.tk.data)->Id; case tc_keyword: *res = obj; return obj->storage_as.keyword.data; case tc_boolean: return (obj == Truth)? "1" : "0"; default: /* Ok, take the big hammer (i.e. use a string port for * type coercion) Here, use write (and not display) * since it handles complex data structures containing * eventually special chars which must be escaped * Ex: (bind .w "" '(display "")) * First is unquotted and second is not */ { SCM port; port = STk_open_output_string(); STk_print(obj, port, TK_MODE); *res = STk_get_output_string(port); return CHARS(*res); } } } SCM STk_execute_Tk_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; 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 *)); } /* * conv_res is (roughly) a vector of the values returned by convert_for_tk. * 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_Tk has created new cells in a previous iteration */ conv_res = STk_makevect(argc+2, NIL); /* First initialize an argv array */ 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_tk(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 cmd->storage_as.tk.data->string_result? TkResult2String(STk_main_interp) : TkResult2Scheme(STk_main_interp); Err(STk_main_interp->result, NIL); } void STk_init_glue(void) { char **s; /* * 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_name=Intern(ROOT_WINDOW); STk_gc_protect(&STk_root_window_name); STk_root_window =STk_eval(Sym_dot, NIL);STk_gc_protect(&STk_root_window); VCELL(STk_root_window_name) = STk_root_window; for (s = keeping; **s; s++) Keep_result_as_string(*s); } #endif /* USE_TK */