/* * * t c l - l i b . c - A library remplacement for simulating * a Tcl interpreter in Scheme * * 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: 3-Sep-1999 20:59 (eg) * */ #include "stk.h" #include "module.h" #include "gc.h" #ifdef USE_TK # include "tk-glue.h" #else # include "tclInt.h" #endif #ifdef USE_TK #define BUFF_SIZE 100 /****************************************************************************** * * Eval functions * ******************************************************************************/ int Tcl_GlobalEval(interp, s) Tcl_Interp *interp; char *s; { char buffer[BUFF_SIZE+3], *ptr = buffer; SCM result; /* * If the callback is not surrounded by parenthesis, add them. We * don't have parenthesis when the callback is a closure. In this * case, the callback is simply #p12345. Note that this allow Tk to * add some parameters to the callback when needed (on bindings, or * scrollbars for instance). 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 == '\0') return TCL_OK; if (*s != '(') { /* Build the command to evaluate by adding a pair of parenthesis */ int len = strlen(s); if (len > BUFF_SIZE) ptr = (char *) must_malloc((size_t) len+3); sprintf(ptr, "(%s)", s); s = ptr; } result = STk_internal_eval_string(s, ERR_TCL_BACKGROUND, MOD_ENV(STk_Tk_module)); Tcl_ResetResult(interp); if (ptr != buffer) free(ptr); if (result != EVAL_ERROR) { SCM dumb; Tcl_SetResult(interp, STk_stringify(STk_convert_for_Tcl(result, &dumb), 0), TCL_DYNAMIC); /* * Store also the "true" result in STk_last_Tk_result * Warning: This pointer inot GC protected. We have to use it very soon * This is a kludge (used in text window) */ STk_last_Tk_result = result; return (result == Sym_break) ? TCL_BREAK : TCL_OK; } return TCL_ERROR; } int Tcl_Eval(interp, s) /* very simplist. */ Tcl_Interp *interp; /* But do we need something more clever? */ char *s; { return Tcl_GlobalEval(interp, s); } /* *---------------------------------------------------------------------- * * Tcl_VarEval -- * * Given a variable number of string arguments, concatenate them * all together and execute the result as a Tcl command. * * Results: * A standard Tcl return result. An error message or other * result may be left in interp->result. * * Side effects: * Depends on what was done by the command. * *---------------------------------------------------------------------- */ /* VARARGS2 */ /* ARGSUSED */ int Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1) { va_list argList; Tcl_DString buf; char *string; Tcl_Interp *interp; int result; /* * Copy the strings one after the other into a single larger * string. Use stack-allocated space for small commands, but if * the command gets too large than call ckalloc to create the * space. */ interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); Tcl_DStringInit(&buf); while (1) { string = va_arg(argList, char *); if (string == NULL) { break; } Tcl_DStringAppend(&buf, string, -1); } va_end(argList); result = Tcl_Eval(interp, Tcl_DStringValue(&buf)); Tcl_DStringFree(&buf); return result; } /****************************************************************************** * * Variable accesses (GetVar, GetVar2, SetVar, SetVar2) * ******************************************************************************/ char *Tcl_GetVar(interp, var, flags) Tcl_Interp *interp; /* not used */ char *var; int flags; { /*FIXME Debug("Usage of Tcl_GetVar for ", STk_makestring(var)); */ return STk_tcl_getvar(var, "#f"); } char *Tcl_GetVar2(interp, name1, name2, flags) Tcl_Interp *interp; /* not used */ char *name1, *name2; int flags; { /*FIXME Debug("Usage of Tcl_GetVar2 for ", STk_makestring(name1)); */ return STk_tcl_getvar2(name1, name2, "#f"); } char *Tcl_SetVar(interp, var, val, flags) Tcl_Interp *interp; char *var, *val; int flags; { /*FIXME Debug("Usage of Tcl_SetVar for ", STk_makestring(var)); */ return STk_tcl_setvar(var, val, flags, "#f"); } char *Tcl_SetVar2(interp, name1, name2, val, flags) Tcl_Interp *interp; char *name1, *name2, *val; int flags; { /*FIXME Debug("Usage of Tcl_SetVar for ", STk_makestring(name1)); */ return STk_tcl_setvar2(name1, name2, val, flags, "#f"); } /****************************************************************************** * * Tcl command management * ******************************************************************************/ int STk_internal_Tcl_DeleteCommand(interp, cmdName) Tcl_Interp *interp; char *cmdName; { struct Tk_command *W; Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hPtr; /* the internal DeleteCommand do all the job (except setting cmdName to * UNBOUND, because this implies to use intern which can allocate a cell) * Consequently, GC calls this function, whereas Tk call the true * DeleteCommand */ hPtr = Tcl_FindHashEntry(&iPtr->globalNsPtr->cmdTable, cmdName); if (hPtr == NULL) return -1; W = (struct Tk_command *) Tcl_GetHashValue(hPtr); if (W->deleted) return -1; /* Execute the delete handler */ if (W->delproc != NULL) (*W->delproc)(W->deldata); /* Note: W will be freed by the GC */ Tcl_DeleteHashEntry(hPtr); /* Delete the command from the callbacks hash table */ STk_delete_callback(cmdName); /* Remember that the command has been deleted */ W->deleted = 1; return 0; } int Tcl_DeleteCommand(interp, cmdName) Tcl_Interp *interp; char *cmdName; { int result; if ((result = STk_internal_Tcl_DeleteCommand(interp, cmdName))) return result; /* Undefine "cmdName" by doing a (set! cmdname #) */ STk_define_variable(cmdName, UNBOUND, STk_Tk_module); return 0; } /* * Tcl_DeleteCommandFromToken -- * * Removes the given command from the given interpreter. This procedure * resembles Tcl_DeleteCommand, but takes a Tcl_Command token instead * of a command name for efficiency. */ int Tcl_DeleteCommandFromToken(interp, cmd) Tcl_Interp *interp; /* Token for command interpreter returned by * a previous call to Tcl_CreateInterp. */ Tcl_Command cmd; /* Token for command to delete. */ { /* In STk this function is less efficient than the Tcl one since it * searches the name of the given command and call Tcl_DeleteCommand * However, the time penalty should be lower than in Tcl here. */ return Tcl_DeleteCommand(interp, Tcl_GetCommandName(interp, cmd)); } /* *---------------------------------------------------------------------- * * Tcl_CreateCommand -- * * Define a new command in a command table. * * Results: * The return value is a token for the command, which can * be used in future calls to Tcl_NameOfCommand. * * Side effects: * If a command named cmdName already exists for interp, it is * deleted. *---------------------------------------------------------------------- */ Tcl_Command Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) Tcl_Interp *interp; /* Token for command interpreter (returned * by a previous call to Tcl_CreateInterp). */ char *cmdName; /* Name of command. */ Tcl_CmdProc *proc; /* Command procedure to associate with * cmdName. */ ClientData clientData; /* Arbitrary one-word value to pass to proc. */ Tcl_CmdDeleteProc *deleteProc; /* If not NULL, gives a procedure to call when * this command is deleted. */ { struct Tk_command * W; Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hPtr; int new; SCM z; /* * There are two things to do here. * - We must create a new variable and associate the newly * created Tk object to it. This is the Scheme part. * - We must store the cmd in a hashtable contained in the interp data * structure. This is necessary to delete all the command associated * to the interpreter. This is important at least for the "send" * command which un-register the interpreter from the X server. * */ /* Initialize the Tk_command structure */ W = (struct Tk_command *)must_malloc(sizeof(struct Tk_command)+strlen(cmdName)); W->ptr = clientData; W->fct = proc; W->delproc = deleteProc; W->deldata = clientData; W->deleted = 0; W->objproc = 0; strcpy(W->Id, cmdName); /* Register the command in the Tcl command hash table */ if (Tcl_FindHashEntry(&iPtr->globalNsPtr->cmdTable, cmdName)) { /* Command already exists: delete the old one */ Tcl_DeleteCommand(interp, cmdName); /* not efficient but safer */ } hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable, cmdName, &new); Tcl_SetHashValue(hPtr, W); /* Define a Tk-command cell for this new command */ NEWCELL(z, tc_tkcommand); z->storage_as.tk.data = W; z->storage_as.tk.l_data = Ntruth; /* Define a variable whose name is the command name */ STk_define_variable(cmdName, z, STk_Tk_module); return (Tcl_Command) W; } /* *---------------------------------------------------------------------- * * Tcl_GetCommandName -- * * Given a token returned by Tcl_CreateCommand, this procedure * returns the current name of the command (which may have changed * due to renaming). * * Results: * The return value is the name of the given command. * * Side effects: * None. * *---------------------------------------------------------------------- */ char * Tcl_GetCommandName(interp, command) Tcl_Interp *interp; /* Interpreter containing the command. */ Tcl_Command command; /* Token for the command, returned by a * previous call to Tcl_CreateCommand. * The command must not have been deleted. */ { return ((struct Tk_command *) command)->Id; } /* *---------------------------------------------------------------------- * * 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(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. */ { SCM v; struct Tk_command *p; v = STk_lookup_variable(cmdName, STk_Tk_module); if (NTKCOMMP(v)) return 0; p = v->storage_as.tk.data; infoPtr->proc = p->fct; infoPtr->clientData = p->ptr; infoPtr->deleteProc = p->delproc;; infoPtr->deleteData = NULL; return 1; } /****************************************************************************** * * Tcl interpreter management * ******************************************************************************/ Tcl_Interp *Tcl_CreateInterp() { register Interp *iPtr = (Interp *) ckalloc(sizeof(Interp)); int i; iPtr->result = iPtr->resultSpace; iPtr->freeProc = 0; iPtr->errorLine = 0; iPtr->resultSpace[0] = 0; for (i = 0; i < NUM_REGEXPS; i++) { iPtr->patterns[i] = NULL; iPtr->patLengths[i] = -1; iPtr->regexps[i] = NULL; } iPtr->appendResult = NULL; iPtr->appendAvl = 0; iPtr->appendUsed = 0; iPtr->flags = 0; /* strcpy(iPtr->pdFormat, "%g"); No more needed for 8.0 */ iPtr->assocData = (Tcl_HashTable *) NULL; /* See Tcl_CreateCommand for this table utility */ iPtr->globalNsPtr = (Namespace*) STk_must_malloc(sizeof(Namespace)); Tcl_InitHashTable(&iPtr->globalNsPtr->cmdTable, TCL_STRING_KEYS); /* Protect the Tcl_Obj result */ Tcl_ResetObjResult(iPtr); STk_gc_protect((SCM*) &(iPtr->objResultPtr)); return (Tcl_Interp *) iPtr; } /* *---------------------------------------------------------------------- * * Tcl_SetAssocData -- * * Creates a named association between user-specified data, a delete * function and this interpreter. If the association already exists * the data is overwritten with the new data. The delete function will * be invoked when the interpreter is deleted. * * Results: * None. * * Side effects: * Sets the associated data, creates the association if needed. * *---------------------------------------------------------------------- */ void Tcl_SetAssocData(interp, name, proc, clientData) Tcl_Interp *interp; /* Interpreter to associate with. */ char *name; /* Name for association. */ Tcl_InterpDeleteProc *proc; /* Proc to call when interpreter is * about to be deleted. */ ClientData clientData; /* One-word value to pass to proc. */ { Interp *iPtr = (Interp *) interp; AssocData *dPtr; Tcl_HashEntry *hPtr; int new; if (iPtr->assocData == (Tcl_HashTable *) NULL) { if (iPtr->flags & DELETED) { /* * Don't create new entries after interpreter deletion * has started; it isn't even safe to muck with the * interpreter right now */ return; } iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); } hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new); if (new == 0) { dPtr = (AssocData *) Tcl_GetHashValue(hPtr); } else { dPtr = (AssocData *) ckalloc(sizeof(AssocData)); } dPtr->proc = proc; dPtr->clientData = clientData; Tcl_SetHashValue(hPtr, dPtr); } /* *---------------------------------------------------------------------- * * Tcl_DeleteAssocData -- * * Deletes a named association of user-specified data with * the specified interpreter. * * Results: * None. * * Side effects: * Deletes the association. * *---------------------------------------------------------------------- */ void Tcl_DeleteAssocData(interp, name) Tcl_Interp *interp; /* Interpreter to associate with. */ char *name; /* Name of association. */ { Interp *iPtr = (Interp *) interp; AssocData *dPtr; Tcl_HashEntry *hPtr; if (iPtr->assocData == (Tcl_HashTable *) NULL) { return; } hPtr = Tcl_FindHashEntry(iPtr->assocData, name); if (hPtr == (Tcl_HashEntry *) NULL) { return; } dPtr = (AssocData *) Tcl_GetHashValue(hPtr); ckfree((char *) dPtr); Tcl_DeleteHashEntry(hPtr); } /* *---------------------------------------------------------------------- * * Tcl_GetAssocData -- * * Returns the client data associated with this name in the * specified interpreter. * * Results: * The client data in the AssocData record denoted by the named * association, or NULL. * * Side effects: * None. * *---------------------------------------------------------------------- */ ClientData Tcl_GetAssocData(interp, name, procPtr) Tcl_Interp *interp; /* Interpreter associated with. */ char *name; /* Name of association. */ Tcl_InterpDeleteProc **procPtr; /* Pointer to place to store address * of current deletion callback. */ { Interp *iPtr = (Interp *) interp; AssocData *dPtr; Tcl_HashEntry *hPtr; if (iPtr->assocData == (Tcl_HashTable *) NULL) { return (ClientData) NULL; } hPtr = Tcl_FindHashEntry(iPtr->assocData, name); if (hPtr == (Tcl_HashEntry *) NULL) { return (ClientData) NULL; } dPtr = (AssocData *) Tcl_GetHashValue(hPtr); if (procPtr != (Tcl_InterpDeleteProc **) NULL) { *procPtr = dPtr->proc; } return dPtr->clientData; } /* *---------------------------------------------------------------------- * * Tcl_InterpDeleted -- * * Returns nonzero if the interpreter has been deleted with a call * to Tcl_DeleteInterp. * * Results: * Nonzero if the interpreter is deleted, zero otherwise. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_InterpDeleted(interp) Tcl_Interp *interp; { return (((Interp *) interp)->flags & DELETED) ? 1 : 0; } /* *---------------------------------------------------------------------- * * Tcl_DeleteInterp -- * * Delete an interpreter and free up all of the resources associated * with it. * * Results: * None. * * Side effects: * The interpreter is destroyed. The caller should never again * use the interp token. * *---------------------------------------------------------------------- */ void Tcl_DeleteInterp(interp) Tcl_Interp *interp; { Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hPtr; Tcl_HashSearch search; struct Tk_command *W; if (!iPtr || (iPtr->flags & DELETED)) return; /* Mark the interpreter as deleted. No further evals will be allowed. */ iPtr->flags |= DELETED; /* Delete result space */ if (iPtr->appendResult != NULL) { ckfree(iPtr->appendResult); } /* delete hash table of Tk commands (see Tcl_CreateCommand) */ for (hPtr = Tcl_FirstHashEntry(&iPtr->globalNsPtr->cmdTable, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { W = (struct Tk_command *) Tcl_GetHashValue(hPtr); Tcl_DeleteCommand(interp, W->Id); } Tcl_DeleteHashTable(&iPtr->globalNsPtr->cmdTable); /* Unprotect the Tcl_Obj result */ STk_gc_unprotect((SCM*) &(iPtr->objResultPtr)); ckfree((char *) iPtr); } /* *---------------------------------------------------------------------- * * Tcl_GetOpenFile -- * * Given a name of a channel registered in the given interpreter, * returns a FILE * for it. * * Results: * A standard Tcl result. If the channel is registered in the given * interpreter and it is managed by the "file" channel driver, and * it is open for the requested mode, then the output parameter * filePtr is set to a FILE * for the underlying file. On error, the * filePtr is not set, TCL_ERROR is returned and an error message is * left in interp->result. * * Side effects: * May invoke fdopen to create the FILE * for the requested file. * *---------------------------------------------------------------------- */ int Tcl_GetOpenFile(interp, string, forWriting, checkUsage, filePtr) Tcl_Interp *interp; /* Interpreter in which to find file. */ char *string; /* String that identifies file. */ int forWriting; /* 1 means the file is going to be used * for writing, 0 means for reading. */ int checkUsage; /* 1 means verify that the file was opened * in a mode that allows the access specified * by "forWriting". Ignored, we always * check that the channel is open for the * requested mode. */ ClientData *filePtr; /* Store pointer to FILE structure here. */ { SCM port; if ((string[0] == '#') && (string[1] == 'f') && (string[2] == 'i') && (string[3] == 'l') && string[4] == 'e') { char *end; port = (SCM) strtoul(string+5, &end, 16); if ((end != string+5) && (*end == 0)) { /* Verify the given address is a port */ if (STk_valid_address(port) && (IPORTP(port) || OPORTP(port))) { /* Verify the port usage */ if (checkUsage && (PORT_FLAGS(port) & PORT_CLOSED)) { Tcl_AppendResult(interp, "\"", string, "\" is closed", (char *) NULL); return TCL_ERROR; } if (forWriting) { if (checkUsage && !OPORTP(port)) { Tcl_AppendResult(interp, "\"", string, "\" wasn't opened for writing", (char *) NULL); return TCL_ERROR; } } else { if (!IPORTP(port)) { Tcl_AppendResult(interp, "\"", string, "\" wasn't opened for reading", (char *) NULL); return TCL_ERROR; } } /* File is correct; return it in filePtr */ *filePtr = (ClientData) PORT_FILE(port); return TCL_OK; } } } Tcl_AppendResult(interp, "Bad file specification \"", string, "\"", (char *) NULL); return TCL_ERROR; } #endif /****************************************************************************** * * Tcl channels simulation. * * Current version is very minimal. It should probably be extended to be * more Tcl compatible, since Tcl model is very neat. * ******************************************************************************/ Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp, char *fileName, char *modeString, int permissions) { FILE *f = fopen(fileName, modeString); if (f == NULL) { if (interp != (Tcl_Interp *) NULL) { Tcl_AppendResult(interp, "couldn't open \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); } } return (Tcl_Channel) f; } int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan) { return fclose((FILE *) chan); } int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead) { clearerr((FILE*) chan); return fread(bufPtr, 1, (size_t) toRead, (FILE*) chan); } int Tcl_Write(Tcl_Channel chan, char *s, int slen) { int len = (slen < 0) ? strlen(s) : slen; return fwrite(s, 1, (size_t) len, (FILE*) chan); } int Tcl_Seek(Tcl_Channel chan, int offset, int mode) { int res; if ((res=fseek((FILE*) chan, (long) offset, mode)) != -1) return (int) ftell((FILE*) chan); return res; } int Tcl_Flush(Tcl_Channel chan) { return fflush((FILE *) chan); } int Tcl_Eof(Tcl_Channel chan) /* Does this channel have EOF? */ { return feof((FILE *) chan); } int Tcl_SetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, char *optionName, char *newValue) { /* Do nothing */ return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_IsSafe -- * * Determines whether an interpreter is safe * *---------------------------------------------------------------------- */ int Tcl_IsSafe(interp) Tcl_Interp *interp; /* Is this interpreter "safe" ? */ { return STk_is_safe; /* STk is always unsafe for now, but this could change ... */ } /* *---------------------------------------------------------------------- * * Tcl_HideCommand -- * * Makes a command hidden so that it cannot be invoked from within * an interpreter, only from within an ancestor. * *---------------------------------------------------------------------- */ int Tcl_HideCommand(interp, cmdName, hiddenCmdName) Tcl_Interp *interp; /* Interpreter in which to hide command. */ char *cmdName; /* Name of hidden command. */ char *hiddenCmdName; /* Name of to-be-hidden command. */ { /* Easy job */ return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_WrongNumArgs -- * * This procedure generates a "wrong # args" error message in an * interpreter. It is used as a utility function by many command * procedures. * * Results: * None. * * Side effects: * An error message is generated in interp's result object to * indicate that a command was invoked with the wrong number of * arguments. The message has the form * wrong # args: should be "foo bar additional stuff" * where "foo" and "bar" are the initial objects in objv (objc * determines how many of these are printed) and "additional stuff" * is the contents of the message argument. * *---------------------------------------------------------------------- */ void Tcl_WrongNumArgs(interp, objc, objv, message) Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments to print * from objv. */ Tcl_Obj *CONST objv[]; /* Initial argument objects, which * should be included in the error * message. */ char *message; /* Error message to print after the * leading objects in objv. */ { Tcl_Obj *objPtr; int i; #ifdef STk_CODE int stk_hack = (objc == 2); #endif objPtr = Tcl_GetObjResult(interp); #ifdef STk_CODE Tcl_AppendToObj(objPtr, "wrong # args: should be (", -1); for (i = 0; i < objc; i++) { if (stk_hack && i == 1) { /* VERY VERY HACKY: place a quote in front of the second element * of the message. This is a special case for messages such as * wrong # args: should be (.but 'configure ....) * But this code is so frequent. */ Tcl_AppendStringsToObj(objPtr, "'", Tcl_GetStringFromObj(objv[i], (int *) NULL), " ", (char *) NULL); } else { Tcl_AppendStringsToObj(objPtr, Tcl_GetStringFromObj(objv[i], (int *) NULL), " ", (char *) NULL); } } Tcl_AppendStringsToObj(objPtr, message, ")", (char *) NULL); #else Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1); for (i = 0; i < objc; i++) { Tcl_AppendStringsToObj(objPtr, Tcl_GetStringFromObj(objv[i], (int *) NULL), " ", (char *) NULL); } Tcl_AppendStringsToObj(objPtr, message, "\"", (char *) NULL); #endif }