diff options
Diffstat (limited to 'generic')
-rw-r--r-- | generic/tcl.decls | 10 | ||||
-rw-r--r-- | generic/tclBasic.c | 116 | ||||
-rw-r--r-- | generic/tclCmdIL.c | 60 | ||||
-rw-r--r-- | generic/tclDecls.h | 21 | ||||
-rw-r--r-- | generic/tclStubInit.c | 4 |
5 files changed, 204 insertions, 7 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls index fc27323..14c014b 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tcl.decls,v 1.47 2001/05/15 21:30:46 hobbs Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.48 2001/05/30 08:57:06 dkf Exp $ library tcl @@ -1519,6 +1519,14 @@ declare 433 generic { declare 434 generic { Tcl_UniChar * Tcl_GetUnicodeFromObj (Tcl_Obj *objPtr, int *lengthPtr) } +declare 435 generic { + int Tcl_GetMathFuncInfo(Tcl_Interp *interp, CONST char *name, + int *numArgsPtr, Tcl_ValueType **argTypesPtr, + Tcl_MathProc **procPtr, ClientData *clientDataPtr) +} +declare 436 generic { + Tcl_Obj * Tcl_ListMathFuncs(Tcl_Interp *interp, CONST char *pattern) +} ############################################################################## diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 960b856..f27625a 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.32 2001/05/17 02:13:02 hobbs Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.33 2001/05/30 08:57:06 dkf Exp $ */ #include "tclInt.h" @@ -2606,6 +2606,120 @@ Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData) /* *---------------------------------------------------------------------- * + * Tcl_GetMathFuncInfo -- + * + * Discovers how a particular math function was created in a given + * interpreter. + * + * Results: + * TCL_OK if it succeeds, TCL_ERROR else (leaving an error message + * in the interpreter result if that happens.) + * + * Side effects: + * If this function succeeds, the variables pointed to by the + * numArgsPtr and argTypePtr arguments will be updated to detail the + * arguments allowed by the function. The variable pointed to by the + * procPtr argument will be set to NULL if the function is a builtin + * function, and will be set to the address of the C function used to + * implement the math function otherwise (in which case the variable + * pointed to by the clientDataPtr argument will also be updated.) + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetMathFuncInfo(interp, name, numArgsPtr, argTypesPtr, procPtr, + clientDataPtr) + Tcl_Interp *interp; + CONST char *name; + int *numArgsPtr; + Tcl_ValueType **argTypesPtr; + Tcl_MathProc **procPtr; + ClientData *clientDataPtr; +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + MathFunc *mathFuncPtr; + Tcl_ValueType *argTypes; + int i,numArgs; + + hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, name); + if (hPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "math function \"", name, "\" not known in this interpreter", + (char *) NULL); + return TCL_ERROR; + } + mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); + + *numArgsPtr = numArgs = mathFuncPtr->numArgs; + if (numArgs == 0) { + /* Avoid doing zero-sized allocs... */ + numArgs = 1; + } + *argTypesPtr = argTypes = + (Tcl_ValueType *)ckalloc(numArgs * sizeof(Tcl_ValueType)); + for (i = 0; i < mathFuncPtr->numArgs; i++) { + argTypes[i] = mathFuncPtr->argTypes[i]; + } + + if (mathFuncPtr->builtinFuncIndex == -1) { + *procPtr = (Tcl_MathProc *) NULL; + } else { + *procPtr = mathFuncPtr->proc; + *clientDataPtr = mathFuncPtr->clientData; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ListMathFuncs -- + * + * Produces a list of all the math functions defined in a given + * interpreter. + * + * Results: + * A pointer to a Tcl_Obj structure with a reference count of zero, + * or NULL in the case of an error (in which case a suitable error + * message will be left in the interpreter result.) + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_ListMathFuncs(interp, pattern) + Tcl_Interp *interp; + CONST char *pattern; +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *resultList = Tcl_NewObj(); + register Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + CONST char *name; + + for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &hSearch); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { + name = Tcl_GetHashKey(&iPtr->mathFuncTable, hPtr); + if ((pattern == NULL || Tcl_StringMatch(name, pattern)) && + /* I don't expect this to fail, but... */ + Tcl_ListObjAppendElement(interp, resultList, + Tcl_NewStringObj(name,-1)) != TCL_OK) { + Tcl_DecrRefCount(resultList); + return NULL; + } + } + return resultList; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_EvalObjEx -- * * Execute Tcl commands stored in a Tcl object. These commands are diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 74c3e76..833d8a3 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdIL.c,v 1.30 2001/04/27 22:11:51 kennykb Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.31 2001/05/30 08:57:06 dkf Exp $ */ #include "tclInt.h" @@ -102,6 +102,9 @@ static int InfoDefaultCmd _ANSI_ARGS_((ClientData dummy, static int InfoExistsCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +static int InfoFunctionsCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); static int InfoGlobalsCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); @@ -365,14 +368,14 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv) { static char *subCmds[] = { "args", "body", "cmdcount", "commands", - "complete", "default", "exists", "globals", + "complete", "default", "exists", "functions", "globals", "hostname", "level", "library", "loaded", "locals", "nameofexecutable", "patchlevel", "procs", "script", "sharedlibextension", "tclversion", "vars", (char *) NULL}; enum ISubCmdIdx { IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx, - ICompleteIdx, IDefaultIdx, IExistsIdx, IGlobalsIdx, + ICompleteIdx, IDefaultIdx, IExistsIdx, IFunctionsIdx, IGlobalsIdx, IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx, ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx, IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx @@ -412,6 +415,9 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv) case IExistsIdx: result = InfoExistsCmd(clientData, interp, objc, objv); break; + case IFunctionsIdx: + result = InfoFunctionsCmd(clientData, interp, objc, objv); + break; case IGlobalsIdx: result = InfoGlobalsCmd(clientData, interp, objc, objv); break; @@ -928,6 +934,54 @@ InfoExistsCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * + * InfoFunctionsCmd -- + * + * Called to implement the "info functions" command that returns the + * list of math functions matching an optional pattern. Handles the + * following syntax: + * + * info functions ?pattern? + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoFunctionsCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + char *pattern; + Tcl_Obj *listPtr; + + if (objc == 2) { + pattern = NULL; + } else if (objc == 3) { + pattern = Tcl_GetString(objv[2]); + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + return TCL_ERROR; + } + + listPtr = Tcl_ListMathFuncs(interp, pattern); + if (listPtr == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * InfoGlobalsCmd -- * * Called to implement the "info globals" command that returns the list diff --git a/generic/tclDecls.h b/generic/tclDecls.h index b1d3ee8..b2a6031 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDecls.h,v 1.49 2001/05/15 21:30:46 hobbs Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.50 2001/05/30 08:57:06 dkf Exp $ */ #ifndef _TCLDECLS @@ -1366,6 +1366,15 @@ EXTERN Tcl_ThreadId Tcl_GetChannelThread _ANSI_ARGS_(( /* 434 */ EXTERN Tcl_UniChar * Tcl_GetUnicodeFromObj _ANSI_ARGS_((Tcl_Obj * objPtr, int * lengthPtr)); +/* 435 */ +EXTERN int Tcl_GetMathFuncInfo _ANSI_ARGS_((Tcl_Interp * interp, + CONST char * name, int * numArgsPtr, + Tcl_ValueType ** argTypesPtr, + Tcl_MathProc ** procPtr, + ClientData * clientDataPtr)); +/* 436 */ +EXTERN Tcl_Obj * Tcl_ListMathFuncs _ANSI_ARGS_((Tcl_Interp * interp, + CONST char * pattern)); typedef struct TclStubHooks { struct TclPlatStubs *tclPlatStubs; @@ -1868,6 +1877,8 @@ typedef struct TclStubs { int (*tcl_AttemptSetObjLength) _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 432 */ Tcl_ThreadId (*tcl_GetChannelThread) _ANSI_ARGS_((Tcl_Channel channel)); /* 433 */ Tcl_UniChar * (*tcl_GetUnicodeFromObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int * lengthPtr)); /* 434 */ + int (*tcl_GetMathFuncInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, int * numArgsPtr, Tcl_ValueType ** argTypesPtr, Tcl_MathProc ** procPtr, ClientData * clientDataPtr)); /* 435 */ + Tcl_Obj * (*tcl_ListMathFuncs) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * pattern)); /* 436 */ } TclStubs; #ifdef __cplusplus @@ -3656,6 +3667,14 @@ extern TclStubs *tclStubsPtr; #define Tcl_GetUnicodeFromObj \ (tclStubsPtr->tcl_GetUnicodeFromObj) /* 434 */ #endif +#ifndef Tcl_GetMathFuncInfo +#define Tcl_GetMathFuncInfo \ + (tclStubsPtr->tcl_GetMathFuncInfo) /* 435 */ +#endif +#ifndef Tcl_ListMathFuncs +#define Tcl_ListMathFuncs \ + (tclStubsPtr->tcl_ListMathFuncs) /* 436 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 0ce8ea7..f4a9909 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStubInit.c,v 1.49 2001/05/15 21:30:46 hobbs Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.50 2001/05/30 08:57:06 dkf Exp $ */ #include "tclInt.h" @@ -838,6 +838,8 @@ TclStubs tclStubs = { Tcl_AttemptSetObjLength, /* 432 */ Tcl_GetChannelThread, /* 433 */ Tcl_GetUnicodeFromObj, /* 434 */ + Tcl_GetMathFuncInfo, /* 435 */ + Tcl_ListMathFuncs, /* 436 */ }; /* !END!: Do not edit above this line. */ |