Attachment "lambda2.patch" to
ticket [939190ffff]
added by
msofer
2004-04-22 05:46:02.
? generic/tclObj.c.ORIG
? unix/ERR
? unix/tclsh-head
? unix/tclsh-noAsync
? unix/tclsh-noStart
Index: generic/tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBasic.c,v
retrieving revision 1.99
diff -u -r1.99 tclBasic.c
--- generic/tclBasic.c 6 Apr 2004 22:25:48 -0000 1.99
+++ generic/tclBasic.c 21 Apr 2004 22:37:50 -0000
@@ -50,6 +50,10 @@
* The built-in commands, and the procedures that implement them:
*/
+EXTERN int TclAutoCleaningProcObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp * interp, int objc,
+ Tcl_Obj *CONST objv[]));
+
static CmdInfo builtInCmds[] = {
/*
* Commands in the generic core. Note that at least one of the proc or
@@ -489,6 +493,14 @@
iPtr->flags |= EXPR_INITIALIZED;
/*
+ * Create the Lambda command.
+ */
+
+ Tcl_CreateObjCommand(interp, "::tcl::unsupported::AutoCleaningProc",
+ TclAutoCleaningProcObjCmd, NULL,NULL);
+
+
+ /*
* Do Multiple/Safe Interps Tcl init stuff
*/
@@ -2711,6 +2723,10 @@
cmdPtr->refCount--;
if (cmdPtr->refCount <= 0) {
ckfree((char *) cmdPtr);
+ } else if ((cmdPtr->flags & CMD_AUTOCLEAN)
+ && cmdPtr->refCount == 1) {
+ Tcl_DeleteCommandFromToken(cmdPtr->nsPtr->interp,
+ (Tcl_Command)cmdPtr);
}
}
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.152
diff -u -r1.152 tclInt.h
--- generic/tclInt.h 7 Apr 2004 22:04:29 -0000 1.152
+++ generic/tclInt.h 21 Apr 2004 22:37:51 -0000
@@ -1080,6 +1080,10 @@
* underway for a rename/delete change.
* See the two flags below for which is
* currently being processed.
+ * CMD_AUTOCLEAN 1 means this command should delete itself
+ * when its reference count reaches 1 - ie,
+ * when the only reference is in its namespace's
+ * hash table.
* CMD_HAS_EXEC_TRACES - 1 means that this command has at least
* one execution trace (as opposed to simple
* delete/rename traces) in its tracePtr list.
@@ -1092,6 +1096,7 @@
#define CMD_IS_DELETED 0x1
#define CMD_TRACE_ACTIVE 0x2
#define CMD_HAS_EXEC_TRACES 0x4
+#define CMD_AUTOCLEAN 0x8
/*
*----------------------------------------------------------------
Index: generic/tclProc.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclProc.c,v
retrieving revision 1.50
diff -u -r1.50 tclProc.c
--- generic/tclProc.c 9 Mar 2004 12:59:05 -0000 1.50
+++ generic/tclProc.c 21 Apr 2004 22:37:51 -0000
@@ -42,6 +42,47 @@
ProcBodySetFromAny /* SetFromAny procedure */
};
+
+int
+TclAutoCleaningProcObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ Command *cmdPtr;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name args body");
+ return TCL_ERROR;
+ }
+
+ cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]);
+ if (cmdPtr != NULL) {
+ /* the lambda exists already: exit. */
+ return TCL_OK;
+ }
+
+
+ if (Tcl_ProcObjCmd(dummy, interp, objc, objv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Now convert the name obj to cmdNameType, and set the
+ * CMD_AUTOCLEAN flag in the Command.
+ */
+
+ cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]);
+ if (cmdPtr == NULL) {
+ /* FIXME: error message? Should never happen ...*/
+ return TCL_ERROR;
+ }
+
+ cmdPtr->flags |= CMD_AUTOCLEAN;
+ return TCL_OK;
+}
+
/*
*----------------------------------------------------------------------
*
Index: library/init.tcl
===================================================================
RCS file: /cvsroot/tcl/tcl/library/init.tcl,v
retrieving revision 1.60
diff -u -r1.60 init.tcl
--- library/init.tcl 17 Mar 2004 18:14:14 -0000 1.60
+++ library/init.tcl 21 Apr 2004 22:37:51 -0000
@@ -167,10 +167,24 @@
global auto_noexec auto_noload env unknown_pending tcl_interactive
global errorCode errorInfo
+ set cmd [lindex $args 0]
+
+ # If the command is in the ::tcl::lambda namespace, try to create
+ # a lambda expression.
+
+ if {[namespace qualifiers $cmd] eq "::tcl::lambda"} {
+ set ret [catch {uplevel 1 [linsert $args 0 ::tcl::lambda::Create]} result]
+ if {$ret == 0} {
+ return $result
+ } else {
+ return -code $ret -errorcode $errorCode $result
+ }
+ }
+
+
# If the command word has the form "namespace inscope ns cmd"
# then concatenate its arguments onto the end and evaluate it.
- set cmd [lindex $args 0]
if {[regexp "^:*namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} {
set arglist [lrange $args 1 end]
set ret [catch {uplevel 1 ::$cmd $arglist} result]
@@ -732,3 +746,26 @@
}
return
}
+
+# Prepare the lambda machinery
+
+namespace eval ::tcl::lambda {
+ proc Create {name args} {
+ set locName [namespace tail $name]
+ if {[llength $locName] != 2} {
+ error "FIXME: error message?"
+ }
+
+ set argList [lindex $locName 0]
+ set body [lindex $locName 1]
+ ::tcl::unsupported::AutoCleaningProc $name $argList $body
+ uplevel 1 [linsert $args 0 $name]
+ }
+}
+
+proc lambda {argList body} {
+ set name [list ::tcl::lambda:: $argList $body]
+ ::tcl::unsupported::AutoCleaningProc $name $argList $body
+ set name
+}
+
