Changes from TIP#15 "Functions to List and Detail Math Functions"

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. */