diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tclBasic.c | 3 | ||||
| -rw-r--r-- | generic/tclInt.h | 5 | ||||
| -rw-r--r-- | generic/tclProc.c | 273 |
3 files changed, 263 insertions, 18 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index cfd7e90..42f07a6 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -13,7 +13,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.188 2006/02/01 18:27:43 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.189 2006/02/01 19:26:01 dgp Exp $ */ #include "tclInt.h" @@ -105,6 +105,7 @@ static CmdInfo builtInCmds[] = { */ {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, 1}, + {"apply", Tcl_ApplyObjCmd, NULL, 1}, {"array", Tcl_ArrayObjCmd, NULL, 1}, {"binary", Tcl_BinaryObjCmd, NULL, 1}, {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, 1}, diff --git a/generic/tclInt.h b/generic/tclInt.h index 0dbb1bd..64dbfec 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -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: tclInt.h,v 1.266 2006/02/01 18:27:46 dgp Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.267 2006/02/01 19:26:02 dgp Exp $ */ #ifndef _TCLINT @@ -2246,6 +2246,9 @@ MODULE_SCOPE int Tcl_AfterObjCmd(ClientData clientData, MODULE_SCOPE int Tcl_AppendObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); +MODULE_SCOPE int Tcl_ApplyObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_ArrayObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); diff --git a/generic/tclProc.c b/generic/tclProc.c index 9308b81..c2dab7e 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -6,11 +6,12 @@ * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1998 Sun Microsystems, Inc. + * Copyright (c) 2004-2006 Miguel Sofer * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclProc.c,v 1.84 2006/01/23 11:01:59 msofer Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.85 2006/02/01 19:26:02 dgp Exp $ */ #include "tclInt.h" @@ -20,6 +21,8 @@ * Prototypes for static functions in this file */ +static int ObjInterpProcEx(ClientData clientData,register Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[], int skip); static void ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); static void ProcBodyFree(Tcl_Obj *objPtr); static int ProcessProcResultCode(Tcl_Interp *interp, @@ -131,6 +134,9 @@ Tcl_ProcObjCmd( if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3], &procPtr) != TCL_OK) { + Tcl_AddErrorInfo(interp, "\n (creating proc \""); + Tcl_AddErrorInfo(interp, procName); + Tcl_AddErrorInfo(interp, "\")"); return TCL_ERROR; } @@ -372,8 +378,7 @@ TclCreateProc( } if ((fieldCount == 0) || (*fieldValues[0] == 0)) { ckfree((char *) fieldValues); - Tcl_AppendResult(interp, "procedure \"", procName, - "\" has argument with no name", NULL); + Tcl_AppendResult(interp, "argument with no name", NULL); goto procError; } @@ -397,16 +402,16 @@ TclCreateProc( } while (*q != '\0'); q--; if (*q == ')') { /* we have an array element */ - Tcl_AppendResult(interp, "procedure \"", procName, - "\" has formal parameter \"", fieldValues[0], - "\" that is an array element", NULL); + Tcl_AppendResult(interp, "formal parameter \"", + fieldValues[0], + "\" is an array element", NULL); ckfree((char *) fieldValues); goto procError; } } else if ((*p == ':') && (*(p+1) == ':')) { - Tcl_AppendResult(interp, "procedure \"", procName, - "\" has formal parameter \"", fieldValues[0], - "\" that is not a simple name", NULL); + Tcl_AppendResult(interp, "formal parameter \"", + fieldValues[0], + "\" is not a simple name", NULL); ckfree((char *) fieldValues); goto procError; } @@ -1113,6 +1118,22 @@ TclObjInterpProc( * procedure. */ Tcl_Obj *CONST objv[]) /* Argument value objects. */ { + + return ObjInterpProcEx(clientData, interp, objc, objv, /*skip*/ 1); +} + +static int +ObjInterpProcEx( + ClientData clientData, /* Record describing procedure to be + * interpreted. */ + register Tcl_Interp *interp,/* Interpreter in which procedure was + * invoked. */ + int objc, /* Count of number of arguments to this + * procedure. */ + Tcl_Obj *CONST objv[], /* Argument value objects. */ + int skip) /* Number of initial arguments to be skipped, + * ie, words in the "command name" */ +{ register Proc *procPtr = (Proc *) clientData; Namespace *nsPtr = procPtr->cmdPtr->nsPtr; CallFrame *framePtr, **framePtrPtr; @@ -1121,6 +1142,7 @@ TclObjInterpProc( char *procName; int nameLen, localCt, numArgs, argCt, i, imax, result; Var *compiledLocals; + Tcl_Obj *CONST *argObjs; /* * Get the procedure's name. @@ -1183,7 +1205,8 @@ TclObjInterpProc( */ numArgs = procPtr->numArgs; - argCt = objc-1; /* set it to the number of args to the proc */ + argCt = objc-skip; /* set it to the number of args to the proc */ + argObjs = &objv[skip]; varPtr = framePtr->compiledLocals; localPtr = procPtr->firstLocalPtr; if (numArgs == 0) { @@ -1194,13 +1217,13 @@ TclObjInterpProc( } } imax = ((argCt < numArgs - 1)? argCt : (numArgs - 1)); - for (i = 1; i <= imax; i++) { + for (i = 0; i < imax; i++) { /* * "Normal" arguments; last formal is special, depends on it being * 'args'. */ - Tcl_Obj *objPtr = objv[i]; + Tcl_Obj *objPtr = argObjs[i]; varPtr->value.objPtr = objPtr; Tcl_IncrRefCount(objPtr); /* local var is a reference */ @@ -1214,7 +1237,7 @@ TclObjInterpProc( varPtr++; localPtr = localPtr->nextPtr; } - for (; i < numArgs; i++) { + for (; i < (numArgs - 1); i++) { /* * This loop is entered if argCt < (numArgs-1). Set default values; * last formal is special. @@ -1245,11 +1268,11 @@ TclObjInterpProc( */ if (localPtr->flags & VAR_IS_ARGS) { - Tcl_Obj *listPtr = Tcl_NewListObj(objc-numArgs, &(objv[numArgs])); + Tcl_Obj *listPtr = Tcl_NewListObj(argCt-i, &(argObjs[i])); varPtr->value.objPtr = listPtr; Tcl_IncrRefCount(listPtr); /* local var is a reference */ } else if (argCt == numArgs) { - Tcl_Obj *objPtr = objv[numArgs]; + Tcl_Obj *objPtr = argObjs[i]; varPtr->value.objPtr = objPtr; Tcl_IncrRefCount(objPtr); /* local var is a reference */ } else if ((argCt < numArgs) && (localPtr->defValuePtr != NULL)) { @@ -1279,7 +1302,7 @@ TclObjInterpProc( #ifdef AVOID_HACKS_FOR_ITCL desiredObjs[0] = objv[0]; #else - desiredObjs[0] = Tcl_NewListObj(1, objv); + desiredObjs[0] = Tcl_NewListObj(skip, objv); #endif /* AVOID_HACKS_FOR_ITCL */ localPtr = procPtr->firstLocalPtr; @@ -1866,6 +1889,224 @@ TclCompileNoOp( } /* + * LAMBDA and APPLY implementation + * + */ + +static void DupLambdaInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, + Tcl_Obj *copyPtr)); +static void FreeLambdaInternalRep _ANSI_ARGS_(( + Tcl_Obj *objPtr)); +static int SetLambdaFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); + +Tcl_ObjType lambdaType = { + "lambda", /* name */ + FreeLambdaInternalRep, /* freeIntRepProc */ + DupLambdaInternalRep, /* dupIntRepProc */ + (Tcl_UpdateStringProc *) NULL, /* updateStringProc */ + SetLambdaFromAny /* setFromAnyProc */ +}; + +/* + * a Lambda Tcl_Obj has the form + * + * ptr1 is a *Proc: pointer to a proc structure + * ptr2 is a *Tcl_Obj: the lambda's namespace + */ + +static void +DupLambdaInternalRep(srcPtr, copyPtr) + Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +{ + Proc *procPtr = (Proc *) srcPtr->internalRep.twoPtrValue.ptr1; + Tcl_Obj *nsObjPtr = (Tcl_Obj *) srcPtr->internalRep.twoPtrValue.ptr2; + + copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) procPtr; + copyPtr->internalRep.twoPtrValue.ptr2 = (VOID *) nsObjPtr; + + procPtr->refCount++; + Tcl_IncrRefCount(nsObjPtr); + copyPtr->typePtr = &lambdaType; +} + +static void +FreeLambdaInternalRep(objPtr) + register Tcl_Obj *objPtr; /* CmdName object with internal + * representation to free. */ +{ + Proc *procPtr = (Proc *) objPtr->internalRep.twoPtrValue.ptr1; + Tcl_Obj *nsObjPtr = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2; + + procPtr->refCount--; + if (procPtr->refCount == 0) { + TclProcCleanupProc(procPtr); + } + TclDecrRefCount(nsObjPtr); +} + + +static int +SetLambdaFromAny(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* The object to convert. */ +{ + char *name; + Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv, *errPtr; + int objc; + Proc *procPtr; + int result; + + /* + * Convert objPtr to list type first; if it cannot be + * converted, or if its length is not 2, then it cannot + * be converted to lambdaType. + */ + + result = Tcl_ListObjGetElements(interp, objPtr, &objc, &objv); + if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) { + errPtr = Tcl_NewStringObj("can't interpret \"",-1); + Tcl_IncrRefCount(errPtr); + Tcl_AppendObjToObj(errPtr, objPtr); + Tcl_AppendToObj(errPtr, "\" as a lambda expression", -1); + Tcl_SetObjResult(interp, errPtr); + Tcl_DecrRefCount(errPtr); + return TCL_ERROR; + } + + argsPtr = objv[0]; + bodyPtr = objv[1]; + + /* + * Create and initialize the Proc struct. The cmdPtr field is + * set to NULL to signal that this is an anonymous function. + */ + + name = TclGetString(objPtr); + + if (TclCreateProc(interp, /*ignored nsPtr*/ NULL, name, argsPtr, + bodyPtr, &procPtr) != TCL_OK) { + Tcl_AddErrorInfo(interp, "\n (parsing lambda expression \""); + Tcl_AddErrorInfo(interp, name); + Tcl_AddErrorInfo(interp, "\")"); + return TCL_ERROR; + } + procPtr->refCount++; + procPtr->cmdPtr = (Command *) NULL; + + /* + * Set the namespace for this lambda: given by objv[2] understood + * as a global reference, or else global per default. + */ + + nsObjPtr = Tcl_NewStringObj("::", 2); + Tcl_IncrRefCount(nsObjPtr); + + if (objc == 3) { + Tcl_AppendObjToObj(nsObjPtr, objv[2]); + } + + + /* + * Free the list internalrep of objPtr - this will free argsPtr, but + * bodyPtr retains a reference from the Proc structure. Then finish + * the conversion to lambdaType. + */ + + objPtr->typePtr->freeIntRepProc(objPtr); + + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) procPtr; + objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) nsObjPtr; + objPtr->typePtr = &lambdaType; + return TCL_OK; +} + +int +Tcl_ApplyObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + Proc *procPtr = NULL; + Tcl_Obj *lambdaPtr, *nsObjPtr, *errPtr; + int result; + Command cmd; + Tcl_Namespace *nsPtr; + +#define JOE_EXTENSION 0 +#if JOE_EXTENSION + Tcl_Obj *elemPtr; + int numElem; +#endif + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "lambdaExpr ?arg1 arg2 ...?"); + return TCL_ERROR; + } + + /* + * Set lambdaPtr, convert it to lambdaType in the current + * interp if necessary. + */ + + lambdaPtr = objv[1]; + if (lambdaPtr->typePtr == &lambdaType) { + procPtr = (Proc *) lambdaPtr->internalRep.twoPtrValue.ptr1; + +#if JOE_EXTENSION +/* + * Joe English's suggestion to allow cmdNames to function as lambdas. Requires + * also making tclCmdNameType non-static in tclObj.c + * + */ + } else if ((lambdaPtr->typePtr == &tclCmdNameType) + || (TCL_OK == (Tcl_ListObjGetElements(interp, lambdaPtr, &numElem, &elemPtr)) + && (numElem == 1))) { + return Tcl_EvalObjv(interp, objc-1, objv+1, 0); +#endif + } + + if ((procPtr == NULL) || (procPtr->iPtr != iPtr)) { + result = SetLambdaFromAny(interp, lambdaPtr); + if (result != TCL_OK) { + return result; + } + procPtr = (Proc *) lambdaPtr->internalRep.twoPtrValue.ptr1; + } + procPtr->cmdPtr = &cmd; + + /* + * Find the namespace where this lambda should run, and + * push a call frame for that namespace. Note that + * TclObjInterpProc() will pop it. + */ + + nsObjPtr = (Tcl_Obj *) lambdaPtr->internalRep.twoPtrValue.ptr2; + result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); + if (result != TCL_OK) { + return result; + } + if (nsPtr == (Tcl_Namespace *) NULL) { + errPtr = Tcl_NewStringObj("cannot find namespace \"",-1); + Tcl_IncrRefCount(errPtr); + Tcl_AppendObjToObj(errPtr, nsObjPtr); + Tcl_AppendToObj(errPtr, "\"", -1); + Tcl_SetObjResult(interp, errPtr); + Tcl_DecrRefCount(errPtr); + return TCL_ERROR; + } + + /* + cmd = *((Command *) Tcl_GetCommandFromObj(interp, objv[0])); + */ + cmd.nsPtr = (Namespace *) nsPtr; + + return ObjInterpProcEx((ClientData) procPtr, interp, objc, objv, 2); +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 |