761 lines
20 KiB
C
761 lines
20 KiB
C
/*
|
|
*
|
|
* t c l - o b j . c - Implementation of the (crazy) Tcl_obj functions
|
|
* in the Scheme interpreeter
|
|
*
|
|
* 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-obj.c 1.8 Mon, 28 Dec 1998 23:05:11 +0100 eg $
|
|
*
|
|
* Author: Erick Gallesio [eg@unice.fr]
|
|
* Creation date: 8-Jul-1997 10:33
|
|
* Last file update: 27-Dec-1998 20:47
|
|
*
|
|
*/
|
|
|
|
#include "stk.h"
|
|
#ifdef USE_TK
|
|
# include "tk-glue.h"
|
|
#else
|
|
# include "tcl-glue.h"
|
|
#endif
|
|
|
|
|
|
void Tcl_ResetObjResult(Interp *interp)
|
|
{
|
|
interp->objResultPtr = STk_create_tcl_object(NULL);
|
|
}
|
|
|
|
|
|
#ifdef USE_TK
|
|
/*
|
|
*----------------------------------------------------------------------
|
|
*
|
|
* Tcl_CreateObjCommand --
|
|
*
|
|
* Define a new object-based command in a command table.
|
|
*
|
|
*----------------------------------------------------------------------
|
|
*/
|
|
|
|
Tcl_Command
|
|
Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc)
|
|
Tcl_Interp *interp; /* Token for command interpreter (returned
|
|
* by previous call to Tcl_CreateInterp). */
|
|
char *cmdName; /* Name of command. If it contains namespace
|
|
* qualifiers, the new command is put in the
|
|
* specified namespace; otherwise it is put
|
|
* in the global namespace. */
|
|
Tcl_ObjCmdProc *proc; /* Object-based procedure to associate with
|
|
* name. */
|
|
ClientData clientData; /* Arbitrary value to pass to object
|
|
* procedure. */
|
|
Tcl_CmdDeleteProc *deleteProc;
|
|
/* If not NULL, gives a procedure to call
|
|
* when this command is deleted. */
|
|
{
|
|
struct Tk_command *res;
|
|
|
|
res = (struct Tk_command *) Tcl_CreateCommand(interp,
|
|
cmdName,
|
|
(Tcl_CmdProc *) proc,
|
|
clientData,
|
|
deleteProc);
|
|
res->objproc = 1;
|
|
return (Tcl_Command) res;
|
|
}
|
|
#endif
|
|
|
|
/*****************************************************************************/
|
|
/* Lists */
|
|
|
|
|
|
Tcl_Obj *
|
|
Tcl_NewListObj(objc, objv)
|
|
int objc; /* Count of objects referenced by objv. */
|
|
Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */
|
|
{
|
|
register SCM res;
|
|
int i;
|
|
|
|
res = NIL;
|
|
if (objc > 0) {
|
|
for (i = 0; i < objc; i++)
|
|
res = Cons((SCM) objv[i], res);
|
|
res = Reverse(res);
|
|
}
|
|
|
|
return STk_create_tcl_object(res);
|
|
}
|
|
|
|
int
|
|
Tcl_ListObjLength(interp, listPtr, intPtr)
|
|
Tcl_Interp *interp; /* Used to report errors if not NULL. */
|
|
register Tcl_Obj *listPtr; /* List object whose #elements to return. */
|
|
register int *intPtr; /* The resulting int is stored here. */
|
|
{
|
|
SCM data = TCLOBJDATA((SCM) listPtr);
|
|
|
|
if (!data)
|
|
TCLOBJDATA((SCM) listPtr) = NIL;
|
|
else
|
|
if (NCONSP(data) && NNULLP(data))
|
|
TCLOBJDATA((SCM) listPtr) = LIST1(data);
|
|
*intPtr = STk_llength(data);
|
|
return TCL_OK;
|
|
}
|
|
|
|
|
|
|
|
int
|
|
Tcl_ListObjAppendElement(interp, listPtr, objPtr)
|
|
Tcl_Interp *interp; /* Used to report errors if not NULL. */
|
|
Tcl_Obj *listPtr; /* List object to append objPtr to. */
|
|
Tcl_Obj *objPtr; /* Object to append to listPtr's list. */
|
|
{
|
|
SCM data;
|
|
SCM list = (SCM) listPtr;
|
|
SCM obj = (SCM) objPtr;
|
|
|
|
|
|
data = TCLOBJDATA(list);
|
|
|
|
if (!data || NULLP(data))
|
|
data = LIST1(obj);
|
|
else
|
|
if (CONSP(data))
|
|
data = STk_append2(data, LIST1(obj));
|
|
else
|
|
data = Cons(data, LIST1(obj));
|
|
|
|
TCLOBJDATA(list) = data;
|
|
|
|
return TCL_OK;
|
|
}
|
|
|
|
|
|
|
|
int
|
|
Tcl_ListObjReplace(interp, listPtr, first, count, objc, objv)
|
|
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
|
Tcl_Obj *listPtr; /* List object whose elements to replace. */
|
|
int first; /* Index of first element to replace. */
|
|
int count; /* Number of elements to replace. */
|
|
int objc; /* Number of objects to insert. */
|
|
Tcl_Obj *CONST objv[]; /* An array of objc pointers to Tcl objects
|
|
* to insert. */
|
|
{
|
|
SCM data = TCLOBJDATA((SCM) listPtr);
|
|
int len;
|
|
Tcl_Obj *objs;
|
|
|
|
if (!data)
|
|
data = NIL;
|
|
else
|
|
if (NCONSP(data) && NNULLP(data))
|
|
data = LIST1(data);
|
|
|
|
len = STk_llength(data);
|
|
objs = Tcl_NewListObj(objc, objv);
|
|
|
|
if (first < 0) first = 0;
|
|
if (first >= len) {
|
|
data = STk_append2(data, TCLOBJDATA((SCM) objs));
|
|
/* Tcl_DecrRefCount(objs); */
|
|
}
|
|
else {
|
|
panic("Problem in Tcl_ListObjReplace");
|
|
}
|
|
return 0; /* never reached */
|
|
}
|
|
|
|
int
|
|
Tcl_ListObjIndex(interp, listPtr, index, objPtrPtr)
|
|
Tcl_Interp *interp; /* Used to report errors if not NULL. */
|
|
register Tcl_Obj *listPtr; /* List object to index into. */
|
|
register int index; /* Index of element to return. */
|
|
Tcl_Obj **objPtrPtr; /* The resulting Tcl_Obj* is stored here. */
|
|
{
|
|
SCM data = TCLOBJDATA((SCM) listPtr);
|
|
int len;
|
|
|
|
if (!data)
|
|
data = NIL;
|
|
else
|
|
if (NCONSP(data) && NNULLP(data))
|
|
data = LIST1(data);
|
|
|
|
len = STk_llength(data);
|
|
if ((index < 0) || (index >= len)) {
|
|
/* FIXME: Est ce intelligent de retourner NULL? pourquoi pas NIL? */
|
|
*objPtrPtr = NULL;
|
|
} else {
|
|
*objPtrPtr = STk_create_tcl_object(STk_list_ref(data, STk_makeinteger(index)));
|
|
}
|
|
return TCL_OK;
|
|
}
|
|
|
|
/* This function uses a malloced array for returning the Tcl_Obj pointers
|
|
* This is not fully compatible with Tcl, but This function is used only
|
|
* for parsing the new font name scheme.
|
|
* Should be rewritten if used elsewhere (in particular with long lists)
|
|
*/
|
|
int
|
|
Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr)
|
|
Tcl_Interp *interp; /* Used to report errors if not NULL. */
|
|
register Tcl_Obj *listPtr; /* List object for which an element array
|
|
* is to be returned. */
|
|
int *objcPtr; /* Where to store the count of objects
|
|
* referenced by objv. */
|
|
Tcl_Obj ***objvPtr; /* Where to store the pointer to an array
|
|
* of pointers to the list's objects. */
|
|
{
|
|
static Tcl_Obj *obj[100];
|
|
int i, len;
|
|
SCM data = TCLOBJDATA((SCM) listPtr);
|
|
|
|
if (!data)
|
|
data = NIL;
|
|
else
|
|
if (STRINGP(data))
|
|
/* We have a string and we want to look at it as a list */
|
|
data = STk_convert_Tcl_string2list(CHARS(data));
|
|
else
|
|
if (NCONSP(data) && NNULLP(data))
|
|
data = LIST1(data);
|
|
|
|
len = STk_llength(data);
|
|
if (len > 100)
|
|
panic("Too much data in Tcl_ListObjGetElements\n");
|
|
|
|
for (i = 0; i < len; i++, data=CDR(data))
|
|
obj[i] = STk_create_tcl_object(CAR(data));
|
|
|
|
*objcPtr = len;
|
|
*objvPtr = obj;
|
|
|
|
return TCL_OK;
|
|
}
|
|
|
|
/*****************************************************************************/
|
|
/* Strings */
|
|
|
|
void Tcl_InitStringRep(Tcl_Obj *objPtr, char *bytePtr, int len)
|
|
{
|
|
TCLOBJDATA((SCM) objPtr) = STk_makestrg(len, bytePtr);
|
|
}
|
|
|
|
Tcl_Obj *
|
|
Tcl_NewStringObj(bytes, length)
|
|
register char *bytes; /* Points to the first of the length bytes
|
|
* used to initialize the new object. */
|
|
register int length; /* The number of bytes to copy from "bytes"
|
|
* when initializing the new object. If
|
|
* negative, use bytes up to the first
|
|
* NULL byte. */
|
|
{
|
|
if (length < 0) length = strlen(bytes);
|
|
return STk_create_tcl_object(STk_makestrg(length, bytes));
|
|
}
|
|
|
|
void
|
|
Tcl_AppendToObj(objPtr, bytes, length)
|
|
register Tcl_Obj *objPtr; /* Points to the object to append to. */
|
|
char *bytes; /* Points to the bytes to append to the
|
|
* object. */
|
|
register int length; /* The number of bytes to append from
|
|
* "bytes". If < 0, then append all bytes
|
|
* up to NULL byte. */
|
|
{
|
|
SCM str = TCLOBJDATA((SCM) objPtr);
|
|
char *s;
|
|
int len;
|
|
|
|
if (!str || NULLP(str))
|
|
str = STk_makestring("");
|
|
else
|
|
if (NSTRINGP(str))
|
|
Err("internal error (Tcl_AppendToObj only accepts strings). It was", str);
|
|
|
|
if (length < 0) length = strlen(bytes);
|
|
len = STRSIZE(str) + length;
|
|
s = STk_must_malloc((size_t) len + 1); /* +1 for the null */
|
|
|
|
sprintf(s, "%s%s", CHARS(str), bytes);
|
|
TCLOBJDATA((SCM) objPtr) = STk_makestrg(len, s);
|
|
free(s);
|
|
}
|
|
|
|
|
|
char *
|
|
Tcl_GetStringFromObj(objPtr, lengthPtr)
|
|
register Tcl_Obj *objPtr; /* Object whose string rep byte pointer
|
|
* should be returned. */
|
|
register int *lengthPtr; /* If non-NULL, the location where the
|
|
* string rep's byte array length should be
|
|
* stored. If NULL, no length is stored. */
|
|
{
|
|
SCM s = TCLOBJDATA((SCM) objPtr);
|
|
|
|
if (!s)
|
|
s = STk_makestring("");
|
|
else
|
|
if (NSTRINGP(s)) {
|
|
SCM dumb;
|
|
char *string;
|
|
|
|
string = STk_convert_for_Tcl(s, &dumb);
|
|
s = STk_makestring(string);
|
|
}
|
|
|
|
if (lengthPtr) *lengthPtr = STRSIZE(s);
|
|
return CHARS(s);
|
|
}
|
|
|
|
void
|
|
Tcl_SetStringObj(objPtr, bytes, length)
|
|
register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
|
|
char *bytes; /* Points to the first of the length bytes
|
|
* used to initialize the object. */
|
|
register int length; /* The number of bytes to copy from "bytes"
|
|
* when initializing the object. If
|
|
* negative, use bytes up to the first
|
|
* NULL byte.*/
|
|
{
|
|
if (length < 0) length = strlen(bytes);
|
|
TCLOBJDATA((SCM) objPtr) = STk_makestrg(length, bytes);
|
|
/* old string will be automatically garbaged */
|
|
}
|
|
|
|
void
|
|
Tcl_AppendStringsToObj TCL_VARARGS_DEF(Tcl_Obj *,arg1)
|
|
{
|
|
va_list argList;
|
|
register Tcl_Obj *objPtr;
|
|
int newLength, oldLength;
|
|
register char *string, *dst;
|
|
#ifdef STk_CODE
|
|
SCM data;
|
|
#endif
|
|
|
|
objPtr = (Tcl_Obj *) TCL_VARARGS_START(Tcl_Obj *,arg1,argList);
|
|
|
|
#ifdef STk_CODE
|
|
data = TCLOBJDATA((SCM) objPtr);
|
|
|
|
if (!data)
|
|
TCLOBJDATA((SCM) objPtr) = data = STk_makestring("");
|
|
else
|
|
if (NSTRINGP(data)) {
|
|
SCM newdata;
|
|
|
|
STk_convert_for_Tcl(data, &newdata);
|
|
TCLOBJDATA((SCM) objPtr) = data = newdata;
|
|
}
|
|
#else
|
|
if (objPtr->typePtr != &tclStringType) {
|
|
ConvertToStringType(objPtr);
|
|
}
|
|
#endif
|
|
|
|
/*
|
|
* Figure out how much space is needed for all the strings, and
|
|
* expand the string representation if it isn't big enough. If no
|
|
* bytes would be appended, just return.
|
|
*/
|
|
|
|
#ifdef STk_CODE
|
|
newLength = oldLength = STRSIZE(data);
|
|
#else
|
|
newLength = oldLength = objPtr->length;
|
|
#endif
|
|
while (1) {
|
|
string = va_arg(argList, char *);
|
|
if (string == NULL) {
|
|
break;
|
|
}
|
|
newLength += strlen(string);
|
|
}
|
|
if (newLength == oldLength) {
|
|
return;
|
|
}
|
|
|
|
#ifdef STk_CODE
|
|
CHARS(data) = (char *) STk_must_realloc(CHARS(data),(size_t)newLength+1);
|
|
#else
|
|
if ((long)newLength > objPtr->internalRep.longValue) {
|
|
/*
|
|
* There isn't currently enough space in the string
|
|
* representation so allocate additional space. If the current
|
|
* string representation isn't empty (i.e. it looks like we're
|
|
* doing a series of appends) then overallocate the space so
|
|
* that we won't have to do as much reallocation in the future.
|
|
*/
|
|
|
|
Tcl_SetObjLength(objPtr,
|
|
(objPtr->length == 0) ? newLength : 2*newLength);
|
|
}
|
|
#endif
|
|
|
|
/*
|
|
* Make a second pass through the arguments, appending all the
|
|
* strings to the object.
|
|
*/
|
|
|
|
TCL_VARARGS_START(Tcl_Obj *,arg1,argList);
|
|
#ifdef STk_CODE
|
|
dst = CHARS(data) + oldLength;
|
|
#else
|
|
dst = objPtr->bytes + oldLength;
|
|
#endif
|
|
while (1) {
|
|
string = va_arg(argList, char *);
|
|
if (string == NULL) {
|
|
break;
|
|
}
|
|
while (*string != 0) {
|
|
*dst = *string;
|
|
dst++;
|
|
string++;
|
|
}
|
|
}
|
|
|
|
/*
|
|
* Add a null byte to terminate the string. However, be careful:
|
|
* it's possible that the object is totally empty (if it was empty
|
|
* originally and there was nothing to append). In this case dst is
|
|
* NULL; just leave everything alone.
|
|
*/
|
|
|
|
if (dst != NULL) {
|
|
*dst = 0;
|
|
}
|
|
#ifdef STk_CODE
|
|
STRSIZE(data) = newLength;
|
|
#else
|
|
objPtr->length = newLength;
|
|
#endif
|
|
va_end(argList);
|
|
}
|
|
|
|
|
|
/*****************************************************************************/
|
|
/* Doubles */
|
|
|
|
void
|
|
Tcl_SetDoubleObj(objPtr, dblValue)
|
|
register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
|
|
register double dblValue; /* Double used to set the object's value. */
|
|
{
|
|
TCLOBJDATA((SCM) objPtr) = STk_makenumber(dblValue);
|
|
}
|
|
|
|
int
|
|
Tcl_GetDoubleFromObj(interp, objPtr, dblPtr)
|
|
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
|
register Tcl_Obj *objPtr; /* The object from which to get a double. */
|
|
register double *dblPtr; /* Place to store resulting double. */
|
|
{
|
|
SCM data = TCLOBJDATA((SCM) objPtr);
|
|
|
|
if (!data)
|
|
data = STk_makenumber((double) 0.0);
|
|
|
|
if (INTEGERP(data) || BIGNUMP(data))
|
|
data = STk_exact2inexact(data);
|
|
if (FLONUMP(data)) {
|
|
*dblPtr = FLONM(data);
|
|
return TCL_OK;
|
|
}
|
|
else {
|
|
if (interp != NULL) {
|
|
Tcl_ResetResult(interp);
|
|
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
|
"expected floating-point number", -1);
|
|
}
|
|
return TCL_ERROR;
|
|
}
|
|
}
|
|
|
|
|
|
|
|
/*****************************************************************************/
|
|
/* Longs */
|
|
|
|
void
|
|
Tcl_SetLongObj(objPtr, longValue)
|
|
register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
|
|
register long longValue; /* Long integer used to initialize the
|
|
* object's value. */
|
|
{
|
|
TCLOBJDATA((SCM) objPtr) = STk_makeinteger(longValue);
|
|
}
|
|
|
|
int
|
|
Tcl_GetLongFromObj(interp, objPtr, longPtr)
|
|
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
|
register Tcl_Obj *objPtr; /* The object from which to get a long. */
|
|
register long *longPtr; /* Place to store resulting long. */
|
|
{
|
|
SCM data = TCLOBJDATA((SCM) objPtr);
|
|
|
|
if (!data)
|
|
*longPtr = 0L;
|
|
else
|
|
*longPtr = STk_integer_value_no_overflow(data);
|
|
|
|
if (*longPtr == LONG_MIN) {
|
|
Tcl_ResetResult(interp);
|
|
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
|
"expected integer number", -1);
|
|
return TCL_ERROR;
|
|
}
|
|
else
|
|
return TCL_OK;
|
|
}
|
|
|
|
/*****************************************************************************/
|
|
/* Integers (as longs in STk) */
|
|
|
|
Tcl_Obj *
|
|
Tcl_NewIntObj(intValue)
|
|
register int intValue; /* Int used to initialize the new object. */
|
|
{
|
|
return STk_create_tcl_object(STk_makeinteger(intValue));
|
|
}
|
|
|
|
|
|
void
|
|
Tcl_SetIntObj(objPtr, intValue)
|
|
register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
|
|
register int intValue; /* Int integer used to initialize the
|
|
* object's value. */
|
|
{
|
|
TCLOBJDATA((SCM) objPtr) = STk_makeinteger(intValue);
|
|
}
|
|
|
|
int
|
|
Tcl_GetIntFromObj(interp, objPtr, intPtr)
|
|
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
|
register Tcl_Obj *objPtr; /* The object from which to get a int. */
|
|
register int *intPtr; /* Place to store resulting int. */
|
|
{
|
|
SCM data = TCLOBJDATA((SCM) objPtr);
|
|
|
|
if (!data)
|
|
*intPtr = 0;
|
|
else
|
|
*intPtr = STk_integer_value_no_overflow(data);
|
|
|
|
if (*intPtr == LONG_MIN) {
|
|
Tcl_ResetResult(interp);
|
|
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
|
"expected integer number", -1);
|
|
return TCL_ERROR;
|
|
}
|
|
else
|
|
return TCL_OK;
|
|
}
|
|
|
|
/*****************************************************************************/
|
|
/* Booleans */
|
|
void
|
|
Tcl_SetBooleanObj(objPtr, boolValue)
|
|
register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
|
|
register int boolValue; /* Boolean used to set object's value. */
|
|
{
|
|
TCLOBJDATA((SCM) objPtr) = boolValue? Truth: Ntruth;
|
|
}
|
|
|
|
int
|
|
Tcl_GetBooleanFromObj(interp, objPtr, boolPtr)
|
|
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
|
register Tcl_Obj *objPtr; /* The object from which to get boolean. */
|
|
register int *boolPtr; /* Place to store resulting boolean. */
|
|
{
|
|
SCM data = TCLOBJDATA((SCM) objPtr);
|
|
|
|
/* Accept various form of boolean "yes" 1 #t */
|
|
if (!data)
|
|
*boolPtr = 0;
|
|
else
|
|
if (STRINGP(data))
|
|
Tcl_GetBoolean(interp, CHARS(data), boolPtr);
|
|
else
|
|
if (INTEGERP(data))
|
|
*boolPtr = STk_integer_value_no_overflow(data) != 0;
|
|
else
|
|
*boolPtr = (data != Ntruth);
|
|
return TCL_OK;
|
|
}
|
|
|
|
Tcl_Obj *
|
|
Tcl_NewBooleanObj(boolValue)
|
|
register int boolValue; /* Boolean used to initialize new object. */
|
|
{
|
|
return STk_create_tcl_object(boolValue? Truth: Ntruth);
|
|
}
|
|
|
|
|
|
/*****************************************************************************/
|
|
/* Indexes */
|
|
int
|
|
Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr)
|
|
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
|
|
Tcl_Obj *objPtr; /* Object containing the string to lookup. */
|
|
char **tablePtr; /* Array of strings to compare against the
|
|
* value of objPtr; last entry must be NULL
|
|
* and there must not be duplicate entries. */
|
|
char *msg; /* Identifying word to use in error messages. */
|
|
int flags; /* 0 or TCL_EXACT */
|
|
int *indexPtr; /* Place to store resulting integer index. */
|
|
{
|
|
int index, length, i, numAbbrev;
|
|
char *key, *p1, *p2, **entryPtr;
|
|
Tcl_Obj *resultPtr;
|
|
|
|
#ifndef STk_CODE
|
|
/*
|
|
* See if there is a valid cached result from a previous lookup.
|
|
*/
|
|
|
|
if ((objPtr->typePtr == &tclIndexType)
|
|
&& (objPtr->internalRep.twoPtrValue.ptr1 == (VOID *) tablePtr)) {
|
|
*indexPtr = (int) objPtr->internalRep.twoPtrValue.ptr2;
|
|
return TCL_OK;
|
|
}
|
|
#endif
|
|
/*
|
|
* Lookup the value of the object in the table. Accept unique
|
|
* abbreviations unless TCL_EXACT is set in flags.
|
|
*/
|
|
|
|
key = Tcl_GetStringFromObj(objPtr, &length);
|
|
index = -1;
|
|
numAbbrev = 0;
|
|
for (entryPtr = tablePtr, i = 0; *entryPtr != NULL; entryPtr++, i++) {
|
|
for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) {
|
|
if (*p1 == 0) {
|
|
index = i;
|
|
goto done;
|
|
}
|
|
}
|
|
if (*p1 == 0) {
|
|
/*
|
|
* The value is an abbreviation for this entry. Continue
|
|
* checking other entries to make sure it's unique. If we
|
|
* get more than one unique abbreviation, keep searching to
|
|
* see if there is an exact match, but remember the number
|
|
* of unique abbreviations and don't allow either.
|
|
*/
|
|
|
|
numAbbrev++;
|
|
index = i;
|
|
}
|
|
}
|
|
if ((flags & TCL_EXACT) || (numAbbrev != 1)) {
|
|
goto error;
|
|
}
|
|
|
|
done:
|
|
#ifndef STk_CODE
|
|
if ((objPtr->typePtr != NULL)
|
|
&& (objPtr->typePtr->freeIntRepProc != NULL)) {
|
|
objPtr->typePtr->freeIntRepProc(objPtr);
|
|
}
|
|
objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) tablePtr;
|
|
objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) index;
|
|
objPtr->typePtr = &tclIndexType;
|
|
#endif
|
|
*indexPtr = index;
|
|
return TCL_OK;
|
|
|
|
error:
|
|
if (interp != NULL) {
|
|
resultPtr = Tcl_GetObjResult(interp);
|
|
Tcl_AppendStringsToObj(resultPtr,
|
|
(numAbbrev > 1) ? "ambiguous " : "bad ", msg, " \"",
|
|
key, "\": must be ", *tablePtr, (char *) NULL);
|
|
for (entryPtr = tablePtr+1; *entryPtr != NULL; entryPtr++) {
|
|
if (entryPtr[1] == NULL) {
|
|
Tcl_AppendStringsToObj(resultPtr, ", or ", *entryPtr,
|
|
(char *) NULL);
|
|
} else {
|
|
Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr,
|
|
(char *) NULL);
|
|
}
|
|
}
|
|
}
|
|
return TCL_ERROR;
|
|
}
|
|
|
|
#ifdef USE_TK
|
|
/*****************************************************************************/
|
|
/* Eval */
|
|
|
|
/*
|
|
* Tcl_EvalObj --
|
|
*
|
|
* Execute Tcl commands stored in a Tcl object.
|
|
*/
|
|
|
|
int
|
|
Tcl_EvalObj(interp, objPtr)
|
|
Tcl_Interp *interp; /* Token for command interpreter
|
|
* (returned by a previous call to
|
|
* Tcl_CreateInterp). */
|
|
Tcl_Obj *objPtr; /* Pointer to object containing
|
|
* commands to execute. */
|
|
{
|
|
SCM cmd = TCLOBJDATA((SCM) objPtr);
|
|
|
|
panic("ON est dans TclEvalObj");
|
|
getchar();
|
|
#ifdef FIXME_FIXME
|
|
if (cmd) {
|
|
SCM expr = STk_convert_tcl_list_to_scheme(cmd);
|
|
Jmp_Buf jb, *prev_jb = Top_jmp_buf;
|
|
long prev_context = Error_context;
|
|
SCM result;
|
|
int k;
|
|
|
|
/* save normal error jmpbuf so that eval error don't lead to toplevel */
|
|
/* If in a "catch", keep the ERR_IGNORED bit set */
|
|
if ((k = setjmp(jb.j)) == 0) {
|
|
Top_jmp_buf = &jb;
|
|
Error_context = (Error_context & ERR_IGNORED) | ERR_TCL_BACKGROUND;
|
|
result = STk_eval(expr, NIL);
|
|
}
|
|
|
|
Top_jmp_buf = prev_jb;;e
|
|
Error_context = prev_context;
|
|
|
|
if (k == 0) {
|
|
Tcl_SetObjResult(interp, STk_create_tcl_object(result));
|
|
return TCL_OK;
|
|
}
|
|
/* if we are here, an error has occured during the string reading
|
|
* Two cases:
|
|
* - we are in a catch. Do a longjump to the catch to signal it a fail
|
|
* - otherwise error has already signaled, just return EVAL_ERROR
|
|
*/
|
|
if (Error_context & ERR_IGNORED) longjmp(Top_jmp_buf->j, k);
|
|
return TCL_ERROR;
|
|
}
|
|
#endif
|
|
return TCL_OK;
|
|
}
|
|
#endif
|