mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-02-22 06:50:44 -08:00
Code Issues Projects Releases Packages Wiki Activity

Remove unused files and flags

Browse source
This commit is contained in:
jjgarcia 2005-12-13 10:00:36 +00:00
parent 4d94a84b79
commit 84e76bd6cf
5 changed files with 0 additions and 1013 deletions
Download patch file Download diff file Expand all files Collapse all files

6
src/c/cinit.d
View file

@ -47,9 +47,6 @@ static cl_object si_simple_toplevel ()
/* Simple minded top level loop */
printf(";*** Lisp core booted ****\nECL (Embeddable Common Lisp) %d pages\n", MAXPAGE);
fflush(stdout);
#ifdef TK
StdinResume();
#endif
for (i = 1; i<fix(si_argc()); i++) {
cl_object arg = si_argv(MAKE_FIXNUM(i));
cl_load(1, arg);
@ -60,9 +57,6 @@ static cl_object si_simple_toplevel ()
if (sentence == OBJNULL)
@(return);
prin1(si_eval_with_env(1, sentence), Cnil);
#ifdef TK
StdinResume();
#endif
}
}

7
src/c/main.d
View file

@ -20,9 +20,6 @@
#include <limits.h>
#include "ecl.h"
#include "internal.h"
#ifdef TK
# include "tk.h"
#endif
/******************************* EXPORTS ******************************/
@ -229,10 +226,6 @@ cl_boot(int argc, char **argv)
cl_core.clos_package = make_package(make_constant_string("CLOS"),
Cnil, CONS(cl_core.lisp_package, Cnil));
#endif
#ifdef TK
cl_core.tk_package = make_package(make_constant_string("TK"),
Cnil, CONS(cl_core.lisp_package, Cnil));
#endif
#ifdef ECL_THREADS
cl_core.mp_package = make_package(make_constant_string("MP"),
CONS(make_constant_string("MULTIPROCESSING"), Cnil),

787
src/c/tclBasic.d
View file

@ -1,787 +0,0 @@
/*
*
* tclBasic. c - A library replacement for simulating
* a Tcl interpreter in ECoLisp
*
* Copyright (C) 1993,1994,1995 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
*
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 19-Feb-1993 22:15
* Last file update: 11-Feb-1995 15:07
*
* Modified for ECL by Giuseppe Attardi [attardi@di.unipi.it]
*
*/
#include "ecl.h"
#include "tk.h"
#include "tclInt.h"
cl_object TkWidgetType;
Tcl_Interp *ECL_interp;
extern cl_object tk_package;
static Tcl_HashTable VarTable; /* Global hash table retaining traced variables */
#define STRING_INPUT_STREAM(s, strm) \
struct stream strm; \
struct string string; \
string.t = (short)t_string; \
string.m = FALSE; \
string.st_hasfillp = FALSE; \
string.st_adjustable = FALSE; \
string.st_displaced = Cnil; \
string.st_dim = (string.st_fillp = strlen(s)) + 1; \
string.st_self = s; \
strm.t = (short)t_stream; \
strm.m = FALSE; \
strm.sm_mode = (short)smm_string_input; \
strm.sm_fp = NULL; \
strm.sm_object0 = (cl_object)&string; \
strm.sm_object1 = OBJNULL; \
strm.sm_int0 = 0; \
strm.sm_int1 = string.st_fillp
static cl_object
eval_from_string(char *s)
{
cl_object x;
STRING_INPUT_STREAM(s, strm);
x = @read(3, (cl_object)&strm, Cnil, OBJNULL);
return (x != OBJNULL) ? si_eval_with_env(1, x) : Cnil;
}
static cl_object string_stream;
static char char_string[2] = { 0, 0};
static char *empty = "()";
static char *
object2string(cl_object x)
{
extern VOID *malloc();
switch (type_of(x)) {
case t_string:
case t_symbol:
if (x == Cnil)
return(empty);
else
return(x->string.self);
case t_fixnum: {
char *num = malloc(12);
sprintf(num, "%d", fix(x));
return(num);
}
case t_character: {
char_string[0] = char_code(x);
return char_string;
}
case t_cons: {
extern cl_object @'si::*print-package*';
string_stream->stream.object0->string.fillp = 0;
string_stream->stream.int0 = string_stream->stream.int1 = 0;
bds_bind(@'si::*print-package*', Ct);
prin1(x, string_stream);
bds_unwind1;
return(string_stream->stream.object0->string.self);
}
case t_pathname:
return namestring(x)->string.self;
case t_shortfloat: {
char *num = malloc(12);
sprintf(num, "%f", sf(x));
return(num);
}
case t_longfloat: {
char *num = malloc(12);
sprintf(num, "%f", lf(x));
return(num);
}
case t_ratio: {
char *num = malloc(12);
if (FIXNUMP(x->ratio.num) && FIXNUMP(x->ratio.den)) {
sprintf(num, "%d", fix(x->ratio.num) / fix(x->ratio.den));
return(num);
}
break;
}
}
FEerror("~S cannot be coerced to a C string.", 1, x);
}
/*****************************************************************************
*
* Eval functions
*
*****************************************************************************/
int
Tcl_GlobalEval(Tcl_Interp *interp, char *s)
{
cl_object result;
if (*s == '\0') return TCL_OK;
/* In some situations Tk appends some data (numbers) to the callback. This
* arise for scrollbars and scales. These parameters are normally used to
* reflect slider position. When such a situation arises, we have to
* specify the callback as a string and add a pair of parenthesis around
* this string to form a valid sexpr. To recognize such cases, we look
* at first character: if it is not an open parenthesis, we add a pair of ()
* around the callback string
*
*/
if (*s != '(') {
/* Build the command to evaluate by adding a pair of parenthesis */
char buffer[strlen(s)+3]; /* __GNUC__ */
sprintf(buffer, "(%s)", s);
result = eval_from_string(buffer);
}
else result = eval_from_string(s);
/* we might use TCL_DYNAMIC if object_to_string used malloc */
Tcl_SetResult(interp, object2string(result), TCL_STATIC);
return TCL_OK;
}
/* very simplistic. But do we need something more clever? */
int
Tcl_Eval(Tcl_Interp *interp, char *s)
{
return Tcl_GlobalEval(interp, s);
}
int
Tcl_VarEval(Tcl_Interp *interp, /* Interpreter in which to execute command */
...) /* One or more strings to concatenate,
terminated with a NULL string. */
{
va_list argList;
#define FIXED_SIZE 200
char fixedSpace[FIXED_SIZE+1];
int spaceAvl, spaceUsed, length;
char *string, *cmd;
int result;
/*
* Copy the strings one after the other into a single larger
* string. Use stack-allocated space for small commands, but if
* the commands gets too large than call ckalloc to create the
* space.
*/
va_start(argList, interp);
spaceAvl = FIXED_SIZE;
spaceUsed = 0;
cmd = fixedSpace;
while (TRUE) {
string = va_arg(argList, char *);
if (string == NULL) {
break;
}
length = strlen(string);
if ((spaceUsed + length) > spaceAvl) {
char *new;
spaceAvl = spaceUsed + length;
spaceAvl += spaceAvl/2;
new = ckalloc((unsigned) spaceAvl);
memcpy((VOID *) new, (VOID *) cmd, spaceUsed);
if (cmd != fixedSpace) {
ckfree(cmd);
}
cmd = new;
}
strcpy(cmd + spaceUsed, string);
spaceUsed += length;
}
va_end(argList);
cmd[spaceUsed] = '\0';
result = Tcl_GlobalEval(interp, cmd);
if (cmd != fixedSpace) {
ckfree(cmd);
}
return result;
}
static void
upcase(char *s, char *d)
{
for ( ; *s != '\0'; s++)
*d++ = toupper(*s);
*d = '\0';
}
/*****************************************************************************
*
* Variable accesses (GetVar, GetVar2, SetVar, SetVar2)
*
*****************************************************************************/
char *
Tcl_GetVar(Tcl_Interp *interp, char *var, int flags)
{
cl_object V;
char VAR[strlen(var)+1]; /* __GNUC__ */
upcase(var, VAR);
V = SYM_VAL(_intern(VAR, tk_package));
return (V == OBJNULL) ? NULL : object2string(V);
}
char *
Tcl_GetVar2(Tcl_Interp *interp, char *name1, char *name2, int flags)
{
if (name2 && *name2) {
char *res;
char s[strlen(name1) + strlen(name2) + 8]; /* __GNUC__ */
sprintf(s, "(AREF %s %s)", name1, name2);
Tcl_GlobalEval(interp, s);
return interp->result;
}
return Tcl_GetVar(interp, name1, flags);
}
char *
Tcl_SetVar(Tcl_Interp *interp, char *var, char *val, int flags)
{
char VAR[strlen(var)+1]; /* __GNUC__ */
upcase(var, VAR);
/* Eval the following expression: (setq var val) */
SYM_VAL(_intern(VAR, tk_package)) = make_simple_string(val);
/* Tcl_ChangeValue(var); in tcl-trace.c */
return val;
}
char *
Tcl_SetVar2(Tcl_Interp *interp, char *name1, char *name2, char *val,
int flags)
{
if (name2 && *name2) {
char *res;
char s[strlen(name1) + strlen(name2) + 16]; /* __GNUC__ */
sprintf(s, "(SETF (AREF %s %s) %s)", name1, name2);
Tcl_GlobalEval(interp, s);
return interp->result;
}
return Tcl_SetVar(interp, name1, val, flags);
}
/*****************************************************************************
*
* Tcl command management
*
*****************************************************************************/
int
Tcl_DeleteCommand(Tcl_Interp *interp, char *cmdName)
{
cl_object V = _intern(cmdName, tk_package);
if (SYM_FUN(V) == Cnil) return -1;
SYM_FUN(V) = Cnil; /* Undefine "cmdName" */
SYM_VAL(V) = OBJNULL; /* Undefine "cmdName" */
return 0;
}
/* ECL should use lowercase symbols as default!!!
In such case we could read with:
STRING_INPUT_STREAM(s, strm);
@read(3, (cl_object)&strm, Cnil, OBJNULL);
result = VALUES(0);
@read(3, (cl_object)&strm, Cnil, OBJNULL);
if (VALUES(0) != OBJNULL) {
result = CONS(result, Cnil);
for (p = &CDR(result) ; ; p = &(CDR(*p))) {
*p = CONS(VALUES(0), Cnil);
@read(3, (cl_object)&strm, Cnil, OBJNULL);
if (VALUES(0) == OBJNULL) break;
}
}
*/
static cl_object
parse_from_string(struct string *s, char **ep)
{
if (isdigit(s->st_self[0])) {
int n;
cl_object num = parse_number(s->st_self, s->st_fillp, &n, 10);
*ep = s->st_self + n;
return num;
}
else {
*ep = s->st_self + s->st_fillp;
(cl_object)s = copy_simple_string(s);
s->st_self[s->st_fillp] = '\0';
return (cl_object)s;
}
}
/* We must return strings since commands like 'text index 1.0+1c' return
indexes (e.g. 1.1) which should not be converted to numbers*/
static cl_object
TkResult2Lisp(Tcl_Interp *interp)
{
register char *s = interp->result;
register cl_object result = Cnil, *p;
extern cl_object Tk_root_window;
if (strcmp(s, ".") == 0) return Tk_root_window;
if (*s) {
int i;
char *e;
struct stream strm;
struct string string;
string.t = (short)t_string;
string.m = FALSE;
string.st_hasfillp = FALSE;
string.st_adjustable = FALSE;
string.st_displaced = Cnil;
string.st_self = s;
e = strchr(s, ' ');
if (e == NULL) {
string.st_dim = (string.st_fillp = strlen(s))+1;
result = copy_simple_string(&string);
} else {
/* Result was a list of values, build a proper list */
string.st_dim = (string.st_fillp = e-s)+1;
*e = '\0';
result = CONS(copy_simple_string(&string), Cnil);
for (p = &CDR(result) ; ; p = &(CDR(*p))) {
s = e+1;
string.st_self = s;
e = strchr(s, ' ');
if (e == NULL) {
string.st_dim = (string.st_fillp = strlen(s))+1;
*p = CONS(copy_simple_string(&string), Cnil);
break;
}
string.st_dim = (string.st_fillp = e-s)+1;
*e = '\0';
*p = CONS(copy_simple_string(&string), Cnil);
}
}
}
Tcl_ResetResult(interp);
return result;
}
#ifdef NEW
static cl_object
TkResult2Lisp(Tcl_Interp *interp)
{
register char *s = interp->result;
register cl_object result = Cnil, *p;
extern cl_object Tk_root_window;
if (strcmp(s, ".") == 0) return Tk_root_window;
if (*s) {
int i;
char *e;
struct stream strm;
struct string string;
string.t = (short)t_string;
string.m = FALSE;
string.st_hasfillp = FALSE;
string.st_adjustable = FALSE;
string.st_displaced = Cnil;
string.st_self = s;
e = strchr(s, ' ');
if (e == NULL) {
string.st_dim = (string.st_fillp = strlen(s))+1;
result = parse_from_string(&string, &e);
} else {
/* Result was a list of values, build a proper list */
string.st_dim = (string.st_fillp = e-s)+1;
result = CONS(parse_from_string(&string, &e), Cnil);
for (p = &CDR(result) ; ; p = &(CDR(*p))) {
s = e+1;
string.st_self = s;
e = strchr(s, ' ');
if (e == NULL) {
string.st_dim = (string.st_fillp = strlen(s))+1;
*p = CONS(parse_from_string(&string, &e), Cnil);
break;
}
string.st_dim = (string.st_fillp = e-s)+1;
*p = CONS(parse_from_string(&string, &e), Cnil);
}
}
}
Tcl_ResetResult(interp);
return result;
}
#endif
tclMethodDispatch(cl_narg narg, cl_object env, ...)
{
va_list args;
cl_object W = CAR(env);
char *argv[narg];
int i;
Tcl_CmdProc *proc = (Tcl_CmdProc *)fix(SLOT(W, 0));
ClientData clientData = (ClientData)fix(SLOT(W, 1));
argv[0] = SLOT(W, 2)->symbol.name->string.self; /* command name */
va_start(args, env);
for (i = 1; i < narg; i++)
argv[i] = object2string(va_arg(args, cl_object));
/* if previous result was a symbol, proc could not write to interp->result
* so we must clear it
*/
Tcl_ResetResult(ECL_interp);
if ((*proc)(clientData, ECL_interp, narg, argv) == TCL_ERROR)
VALUES(0) = (cl_object)FEerror(ECL_interp->result, 0);
else
VALUES(0) = TkResult2Lisp(ECL_interp);
return(1);
}
void
Tcl_CreateCommand(Tcl_Interp *interp, char *cmdName, Tcl_CmdProc *proc,
ClientData clientData,
Tcl_CmdDeleteProc *deleteProc)
{
cl_object SYM, sym, W;
char CMDNAME[strlen(cmdName)+1]; /* __GNUC__ */
sym = _intern(cmdName, tk_package);
/* Define a variable whose name is the command name */
upcase(cmdName, CMDNAME);
SYM = _intern(CMDNAME, tk_package);
SYM_VAL(SYM) = sym; /* evaluating to lower case symbol */
@si::make-structure(4, TkWidgetType, MAKE_FIXNUM(proc),
MAKE_FIXNUM(clientData), sym);
W = VALUES(0);
/* Define a function whose name is the command name */
SYM_FUN(sym) = (cl_object)make_cclosure(tclMethodDispatch, CONS(W, Cnil), NULL);
SYM_FUN(SYM) = SYM_FUN(sym);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetCommandInfo --
*
* Returns various information about a Tcl command.
*
* Results:
* If cmdName exists in interp, then *infoPtr is modified to
* hold information about cmdName and 1 is returned. If the
* command doesn't exist then 0 is returned and *infoPtr isn't
* modified.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetCommandInfo(Tcl_Interp *interp, /* Interpreter in which to look
* for command. */
char *cmdName, /* Name of desired command. */
Tcl_CmdInfo *infoPtr) /* Where to store information about
* command. */
{
cl_object v = _intern(cmdName, tk_package);
if (!Null(si_structure_subtypep(cl_type_of(SYM_VAL(v)), TkWidgetType)))
return 0;
infoPtr->proc = (Tcl_CmdProc *)fix(SLOT(SYM_VAL(v), 0));
infoPtr->clientData = (ClientData)fix(SLOT(SYM_VAL(v), 1));
infoPtr->deleteProc = NULL;
infoPtr->deleteData = NULL;
return 1;
}
/*****************************************************************************
*
* Tcl interpreter management
*
*****************************************************************************/
Tcl_Interp *
Tcl_CreateInterp()
{
register Interp *iPtr = (Interp *) ckalloc(sizeof(Interp));
iPtr->result = iPtr->resultSpace;
iPtr->freeProc = 0;
iPtr->errorLine = 0;
iPtr->resultSpace[0] = 0;
iPtr->appendResult = NULL;
iPtr->appendAvl = 0;
iPtr->appendUsed = 0;
strcpy(iPtr->pdFormat, "%g");
return (Tcl_Interp *) iPtr;
}
void
Tcl_DeleteInterp(Tcl_Interp *interp)
{
Interp *iPtr = (Interp *) interp;
if (iPtr->appendResult != NULL) {
ckfree(iPtr->appendResult);
}
ckfree((char *) iPtr);
}
init_tk()
{
#ifdef CLOS
TkWidgetType = define a class with name: _intern("WIDGET", tk_package);
#else
TkWidgetType = _intern("WIDGET", tk_package);
#endif
string_stream = ecl_make_string_output_stream(64);
ecl_register_static_root(&string_stream);
Tcl_InitHashTable(&VarTable, TCL_STRING_KEYS);
}
/*
* Dummies
*/
int
Tcl_Init(Tcl_Interp *interp)
{}
void
Tcl_CallWhenDeleted(
Tcl_Interp *interp, /* Interpreter to watch. */
Tcl_InterpDeleteProc *proc, /* Procedure to call when interpreter
* is about to be deleted. */
ClientData clientData) /* One-word value to pass to proc. */
{}
void
Tcl_DontCallWhenDeleted(interp, proc, clientData)
Tcl_Interp *interp; /* Interpreter to watch. */
Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter
* is about to be deleted. */
ClientData clientData; /* One-word value to pass to proc. */
{}
int
Tcl_SetCommandInfo(interp, cmdName, infoPtr)
Tcl_Interp *interp; /* Interpreter in which to look
* for command. */
char *cmdName; /* Name of desired command. */
Tcl_CmdInfo *infoPtr; /* Where to store information about
* command. */
{}
Tcl_Trace
Tcl_CreateTrace(interp, level, proc, clientData)
Tcl_Interp *interp; /* Interpreter in which to create the trace. */
int level; /* Only call proc for commands at nesting level
* <= level (1 => top level). */
Tcl_CmdTraceProc *proc; /* Procedure to call before executing each
* command. */
ClientData clientData; /* Arbitrary one-word value to pass to proc. */
{}
void
Tcl_DeleteTrace(interp, trace)
Tcl_Interp *interp; /* Interpreter that contains trace. */
Tcl_Trace trace; /* Token for trace (returned previously by
* Tcl_CreateTrace). */
{}
void
Tcl_AddErrorInfo(interp, message)
Tcl_Interp *interp; /* Interpreter to which error information
* pertains. */
char *message; /* Message to record. */
{}
int
Tcl_SetRecursionLimit(interp, depth)
Tcl_Interp *interp; /* Interpreter whose nesting limit
* is to be set. */
int depth; /* New value for maximimum depth. */
{}
/*----------------------------------------------------------------------
* from tclVar.c
*----------------------------------------------------------------------
*/
int
Tcl_TraceVar(interp, varName, flags, proc, clientData)
Tcl_Interp *interp; /* Interpreter in which variable is
* to be traced. */
char *varName; /* Name of variable; may end with "(index)"
* to signify an array reference. */
int flags; /* OR-ed collection of bits, including any
* of TCL_TRACE_READS, TCL_TRACE_WRITES,
* TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are
* invoked upon varName. */
ClientData clientData; /* Arbitrary argument to pass to proc. */
{
Tcl_HashEntry *entry;
int new;
struct VarTrace *data;
entry = Tcl_CreateHashEntry(&VarTable, varName, &new);
/* Create the value associated to the "var" key */
data= (struct VarTrace *) ckalloc((unsigned) sizeof (struct VarTrace));
data->flags = flags & ~TCL_TRACE_UNSETS; /* Unset has no meaning in ECL */
data->traceProc = proc;
data->clientData = clientData;
data->nextPtr = (VarTrace *) (new ? NULL : Tcl_GetHashValue(entry));
/* Put it in table */
Tcl_SetHashValue(entry, (ClientData) data);
return TCL_OK;
}
int
Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData)
Tcl_Interp *interp; /* Interpreter in which variable is
* to be traced. */
char *part1; /* Name of scalar variable or array. */
char *part2; /* Name of element within array; NULL means
* trace applies to scalar variable or array
* as-a-whole. */
int flags; /* OR-ed collection of bits, including any
* of TCL_TRACE_READS, TCL_TRACE_WRITES,
* TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are
* invoked upon varName. */
ClientData clientData; /* Arbitrary argument to pass to proc. */
{
if (*part2) {
}
return Tcl_TraceVar(interp, part1, flags, proc, clientData);
}
void
Tcl_UntraceVar(interp, varName, flags, proc, clientData)
Tcl_Interp *interp; /* Interpreter containing traced variable. */
char *varName; /* Name of variable; may end with "(index)"
* to signify an array reference. */
int flags; /* OR-ed collection of bits describing
* current trace, including any of
* TCL_TRACE_READS, TCL_TRACE_WRITES,
* TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */
ClientData clientData; /* Arbitrary argument to pass to proc. */
{
Tcl_HashEntry *entry;
register VarTrace *p, *prev;
if (entry = Tcl_FindHashEntry(&VarTable, varName)) {
/* Variable is traced. Try to find correponding trace function */
flags &= ~TCL_TRACE_UNSETS; /* Unset has no meaning for us */
p = (struct VarTrace *) Tcl_GetHashValue(entry);
for (prev=NULL; p ; prev=p, p=p->nextPtr) {
if (p->traceProc == proc && p->flags == flags && p->clientData == clientData)
break;
}
if (p) {
if (prev == NULL) {
if (p->nextPtr)
Tcl_SetHashValue(entry, (ClientData *) p->nextPtr);
else
Tcl_DeleteHashEntry(entry);
}
else
prev->nextPtr = p->nextPtr;
ckfree(p);
}
}
}
void
Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData)
Tcl_Interp *interp; /* Interpreter containing traced variable. */
char *part1; /* Name of variable or array. */
char *part2; /* Name of element within array; NULL means
* trace applies to scalar variable or array
* as-a-whole. */
int flags; /* OR-ed collection of bits describing
* current trace, including any of
* TCL_TRACE_READS, TCL_TRACE_WRITES,
* TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */
ClientData clientData; /* Arbitrary argument to pass to proc. */
{
if (part2 && *part2) {
char *s = malloc(strlen(part1) + strlen(part2) + 3);
sprintf(s, "%s{%s}", part1, part2);
Tcl_UntraceVar(interp, s, flags, proc, clientData);
free(s);
}
else
Tcl_UntraceVar(interp, part1, flags, proc, clientData);
}
/****
*
* Tcl_ChangeValue
*
* This function is called by Lisp when a there's a global variable change
* (using a tk-setq). "var" is a C string indicating the name of this
* variable. If this variable is traced, call the C functions associated to it.
*
****/
#define TRACING (1<<20)
void Tcl_ChangeValue(char *var)
{
Tcl_HashEntry *entry;
register VarTrace *data, *p;
extern int Tk_initialized;
if (!Tk_initialized) return;
if (entry = Tcl_FindHashEntry(&VarTable, var)) {
/* Variable is traced. Call all the associated traces */
data = (struct VarTrace *) Tcl_GetHashValue(entry);
for (p = data; p ; p = p->nextPtr) {
/* Invoke trace procedure if not already active */
if (p->flags & TRACING)
continue;
p->flags |= TRACING;
(*p->traceProc)(p->clientData, ECL_interp, var, "", p->flags);
/* Unset our flag */
p->flags &= ~TRACING;
}
}
}

210
src/c/tkMain.d
View file

@ -1,210 +0,0 @@
/*
* tkMain.c -- Initialization of Tk
*
* This code initializes the Tk library. It corresponds to a part of the
* file main.c of the wish interpreter.
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 13-May-1993 10:59
* Last file update: 10-Feb-1995 22:23
*
*
* Code used here was originally copyrigthed as shown below:
* Copyright 1990-1992 Regents of the University of California.
*
*
* Copyright (C) 1993,1994,1995 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
*
* Modified for ECL by Giuseppe Attardi [attardi@di.unipi.it]
*
*/
#include "ecl.h"
#include "tk.h"
/*
* Command used to initialize ECL/tk:
*/
static char initCmd[] =
"(tk::tk-init)";
/*
* Global variables used by the main program:
*/
static Tk_Window w; /* The main window for the application. If
* NULL then the application no longer
* exists. */
Tcl_Interp *ECL_interp = NULL; /* Interpreter for this application. */
int Tk_initialized = FALSE; /* TRUE when Tk is fully initialized */
cl_object Tk_root_window;
/*
* Forward declarations for procedures defined later in this file:
*/
static void DelayedMap _ANSI_ARGS_((ClientData clientData));
static void StructureProc _ANSI_ARGS_((ClientData clientData,
XEvent *eventPtr));
extern StdinResume();
extern cl_object tk_package;
/*
*----------------------------------------------------------------------
*
* Tk_main
*
*----------------------------------------------------------------------
*/
void
Tk_main(int synchronize, char *name, char *fileName, char *Xdisplay,
char *geometry)
{
Tk_3DBorder border;
ECL_interp = Tcl_CreateInterp();
/*
* Parse command-line arguments.
*/
Tcl_SetVar(ECL_interp, "*geometry*", geometry ? geometry : "",
TCL_GLOBAL_ONLY);
/*
* Initialize the Tk application and arrange to map the main window
* after the startup script has been executed, if any. This way
* the script can withdraw the window so it isn't ever mapped
* at all.
*/
w = Tk_CreateMainWindow(ECL_interp, Xdisplay, name, "ECL/Tk");
if (w == NULL) {
fprintf(stderr, "%s\n", ECL_interp->result);
exit(1);
}
Tcl_SetVar(ECL_interp, "*root*", ".", TCL_GLOBAL_ONLY);
Tk_root_window = _intern("*ROOT*", tk_package);
Tk_CreateEventHandler(w, StructureNotifyMask, StructureProc,
(ClientData) NULL);
Tk_DoWhenIdle(DelayedMap, (ClientData) NULL);
if (synchronize) {
XSynchronize(Tk_Display(w), True);
}
Tk_GeometryRequest(w, 200, 200);
border = Tk_Get3DBorder(ECL_interp, w, None, "#cccccc");
if (border == NULL) {
Tcl_SetResult(ECL_interp, (char *) NULL, TCL_STATIC);
Tk_SetWindowBackground(w, WhitePixelOfScreen(Tk_Screen(w)));
}
else {
Tk_SetBackgroundFromBorder(w, border);
}
XSetForeground(Tk_Display(w), DefaultGCOfScreen(Tk_Screen(w)),
BlackPixelOfScreen(Tk_Screen(w)));
Tk_initialized = 1; /* Ok, it's fully initialized */
/*
* Set up a handler for stdin, for resuming read when input
* becomes available
*/
Tk_CreateFileHandler(0, TK_READABLE, (Tk_FileProc *)StdinResume,
(ClientData) 0);
StdinEnableEvents(); /* check for events when idle */
/*
* Set the geometry of the main window, if requested.
*/
if (geometry != NULL) {
if (TCL_OK != Tcl_VarEval(ECL_interp, "(wm 'geometry *root* '",
geometry, ")", NULL))
fprintf(stderr, "**** Warning: %s\n", ECL_interp->result);
}
/*
* Execute ECL/Tk's initialization script, followed by the script specified
* on the command line, if any.
*/
Tcl_GlobalEval(ECL_interp, initCmd);
}
/*
*----------------------------------------------------------------------
*
* StructureProc --
*
* This procedure is invoked whenever a structure-related event
* occurs on the main window. If the window is deleted, the
* procedure modifies "w" to record that fact.
*
* Results:
* None.
*
* Side effects:
* Variable "w" may get set to NULL.
*
*----------------------------------------------------------------------
*/
static void
StructureProc(ClientData clientData, /* Information about window. */
XEvent *eventPtr) /* Information about event. */
{
if (eventPtr->type == DestroyNotify)
w = NULL;
}
/*
*----------------------------------------------------------------------
*
* DelayedMap --
*
* This procedure is invoked by the event dispatcher once the
* startup script has been processed. It waits for all other
* pending idle handlers to be processed (so that all the
* geometry information will be correct), then maps the
* application's main window.
*
* Results:
* None.
*
* Side effects:
* The main window gets mapped.
*
*----------------------------------------------------------------------
*/
static void
DelayedMap(ClientData clientData)
{
while (Tk_DoOneEvent(TK_IDLE_EVENTS) != 0) {
/* Empty loop body. */
}
if (w == NULL) {
return;
}
Tk_MapWindow(w);
}

3
src/h/config.h.in
View file

@ -134,9 +134,6 @@ typedef unsigned @CL_FIXNUM_TYPE@ cl_hashkey;
/* Program Development Environment */
#undef PDE
/* Tcl/Tk library */
#undef TK
/* Allow loading dynamically linked code */
#undef ENABLE_DLOPEN