stk/Src/tcl-glue.c

301 lines
7.8 KiB
C

/*
*
* t c l - g l u e . c - Glue functions between the scheme and Tcl worlds
*
* Copyright © 1997-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* 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
*
* $Id: tcl-glue.c 1.7 Thu, 10 Sep 1998 23:44:28 +0200 eg $
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 6-Aug-1997 12:48
* Last file update: 10-Sep-1998 15:13
*
*/
#include "stk.h"
#include "tcl-glue.h"
#include "module.h"
#include "gc.h"
#include "extend.h"
#ifdef USE_TK
extern SCM STk_root_window;
#endif
SCM STk_convert_Tcl_string2list(char *s)
{
register SCM tmp1, tmp2, z, port;
SCM result = NIL;
int eof;
#ifdef USE_TK
SCM module;
/* Evaluation takes place in the Tk module (for '#.' objects mainly) */
module = STk_selected_module;
STk_selected_module = STk_Tk_module;
#endif
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);
#ifdef USE_TK
if (result == Sym_dot) result = STk_root_window;
#endif
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;
#ifdef USE_TK
if (z == Sym_dot) z = STk_root_window;
#endif
NEWCELL(tmp2, tc_cons);
CAR(tmp2) = z;
CDR(tmp1) = tmp2;
tmp1 = tmp2;
}
CDR(tmp1) = NIL;
}
/* close_string_port(port); */
}
#ifdef USE_TK
STk_selected_module = module;
#endif
return (result == EVAL_ERROR)? UNDEFINED: result;
}
char *STk_convert_for_Tcl(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);
#ifdef USE_TK
case tc_tkcommand: return (obj->storage_as.tk.data)->Id;
#endif
case tc_keyword: *res = obj; return obj->storage_as.keyword.data;
case tc_boolean: *res = STk_makestring((obj == Truth)? "#t" : "#f");
return CHARS(*res);
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 "<Enter>" '(display "<Enter>"))
* First <Enter> 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);
}
}
}
/*
* STk_stringify permits to transform the string "s" in a valid STk string.
* Original string is deallocated if free_original is 1
*/
char *STk_stringify(char *s, int free_original)
{
char *res, *d;
if (s == NULL) s = "";
res = d = must_malloc(2 * strlen(s) + 3); /* worst overestimation */
for ( *d++ = '"'; *s; s++, d++) {
if (*s == '"' || *s == '\\') *d++ = '\\';
*d = *s;
}
*d++ = '"';
*d = '\0';
if (free_original) free(s);
return res;
}
/*******************************************************************************
*
* Accessing Scheme variable in a given environment from Tcl implementation code
*
******************************************************************************/
int STk_valid_environment(char *s, void **env)
{
/* An environment is valid iff it is of the form "#pxxxx" where xxxx is composed
* only of hexadecimal digits.
* This procedure is more restrictive than its cousin procedure
* STk_valid_procedure because it accepts only environment whereas
* the valid_procedure accepts closure AND strings for pre STk3.0
* compatibility reasons.
*/
unsigned long tmp;
int l = strlen(s);
char *p;
if (l == 0 || (l == 2 && s[0] == '#' && s[1] == 'f')) {
#ifdef USE_TK
*env = STk_makeenv(MOD_ENV(STk_Tk_module), 0);
#else
*env = STk_globenv;
#endif
return TRUE;
}
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", &tmp);
if (STk_valid_address((SCM) tmp) && ENVP((SCM) tmp)) {
*(SCM *)env = (SCM) tmp;
return TRUE;
}
}
}
return FALSE;
}
char *STk_tcl_getvar(char *name, char *env)
{
SCM dumb, V, e;
if (!STk_valid_environment(env, (void **) &e)) return NULL;
V = *(STk_varlookup(Intern(name), e->storage_as.env.data, 0));
if (V == UNBOUND) {
/* We should probably complain here, but this would break old code */
STk_tcl_setvar(name, "", 0, env);
return "";
}
else
return STk_convert_for_Tcl(V, &dumb);
}
char *STk_tcl_getvar2(char *name1, char *name2, char *env)
{
if (name2 && *name2) {
char *res, *s = must_malloc(strlen(name1) + strlen(name2) + 3);
sprintf(s, "%s{%s}", name1, name2);
res = STk_tcl_getvar(s, env);
free(s);
return res;
}
return STk_tcl_getvar(name1,env);
}
char *STk_tcl_setvar(char *name, char *val, int flags, char *env)
{
register SCM var, value;
SCM e, *tmp;
if (!STk_valid_environment(env, (void **) &e)) return NULL;
if (flags & STk_STRINGIFY) {
/* Val is already a string, since it comes from Tk */
value = STk_makestring(val);
}
else {
if (*val) {
SCM port;
int eof;
port = STk_internal_open_input_string(val);
value = STk_internal_read_from_string(port, &eof, TRUE);
if (value == EVAL_ERROR) return NULL;
}
else
value = STk_makestring("");
}
var = Intern(name);
tmp = STk_varlookup(var, e->storage_as.env.data, 0);
if (*tmp == UNBOUND) {
if (var->cell_info & CELL_INFO_C_VAR) {
/* This is not an unbound variable but rather a C variable */
STk_apply_setter_C_variable(PNAME(var), value);
goto Out;
}
/* Unbound variable. Define it in the given environment
* Use big hammer here, since it occcurs only once (at most)
* for a given widget
*/
STk_eval(LIST3(Intern("define"), var, value), e->storage_as.env.data);
return val;
}
*tmp = value;
Out:
STk_change_value(var, e);
return val;
}
char *STk_tcl_setvar2(char *name1, char *name2, char *val, int flags, char *env)
{
if (name2 && *name2) {
char *res, *s = must_malloc(strlen(name1) + strlen(name2) + 3);
sprintf(s, "%s{%s}", name1, name2);
res = STk_tcl_setvar(s, val, flags, env);
free(s);
return res;
}
return STk_tcl_setvar(name1, val, flags, env);
}
/******************************************************************************
*
* Tcl_Obj procedures (the one which are not defined in Tcl)
*
******************************************************************************/
Tcl_Obj *STk_create_tcl_object(SCM data)
{
SCM z;
NEWCELL(z, tc_tclobject);
TCLOBJDATA(z) = data;
return (Tcl_Obj *) z;
}
Tcl_Obj *STk_NewKeywordObj(char *str)
{
char copy[100]; /* big enough !!! */
strcpy(copy, str); /* because STk_makekey ill patch first char */
return STk_create_tcl_object(STk_makekey(copy));
}
Tcl_Obj *STk_NewSymbolObj(char *str)
{
return STk_create_tcl_object(Intern(str));
}