301 lines
7.8 KiB
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));
|
|
}
|