From 6a89806ee62b84b96bafb2d86c0726a9408fbe0f Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 22 Aug 2025 11:45:24 +0000 Subject: Move [link] into C. --- generic/tclInt.h | 4 +++ generic/tclInterp.c | 20 +++++------ generic/tclOO.c | 14 ++++++++ generic/tclOOBasic.c | 92 +++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclOOInt.h | 2 ++ generic/tclOOScript.h | 25 -------------- tools/tclOOScript.tcl | 51 ---------------------------- 7 files changed, 120 insertions(+), 88 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 096d5e7..9252eb8 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3282,6 +3282,10 @@ MODULE_SCOPE void TclAdvanceContinuations(int *line, Tcl_Size **next, Tcl_Size loc); MODULE_SCOPE void TclAdvanceLines(int *line, const char *start, const char *end); +MODULE_SCOPE int TclAliasCreate(Tcl_Interp *interp, + Tcl_Interp *childInterp, Tcl_Interp *parentInterp, + Tcl_Obj *namePtr, Tcl_Obj *targetPtr, Tcl_Size objc, + Tcl_Obj *const objv[]); MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr, const unsigned char *bytes, Tcl_Size len); MODULE_SCOPE void TclAppendUtfToUtf(Tcl_Obj *objPtr, diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 061ddcf..77d06f6 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -221,10 +221,6 @@ enum LimitHandlerFlags { * Prototypes for local static functions: */ -static int AliasCreate(Tcl_Interp *interp, - Tcl_Interp *childInterp, Tcl_Interp *parentInterp, - Tcl_Obj *namePtr, Tcl_Obj *targetPtr, Tcl_Size objc, - Tcl_Obj *const objv[]); static int AliasDelete(Tcl_Interp *interp, Tcl_Interp *childInterp, Tcl_Obj *namePtr); static int AliasDescribe(Tcl_Interp *interp, @@ -701,7 +697,7 @@ NRInterpCmd( return TCL_ERROR; } - return AliasCreate(interp, childInterp, parentInterp, objv[3], + return TclAliasCreate(interp, childInterp, parentInterp, objv[3], objv[5], objc - 6, objv + 6); } @@ -1232,7 +1228,7 @@ Tcl_CreateAlias( targetObjPtr = Tcl_NewStringObj(targetCmd, -1); Tcl_IncrRefCount(targetObjPtr); - result = AliasCreate(childInterp, childInterp, targetInterp, childObjPtr, + result = TclAliasCreate(childInterp, childInterp, targetInterp, childObjPtr, targetObjPtr, argc, objv); for (i = 0; i < argc; i++) { @@ -1279,7 +1275,7 @@ Tcl_CreateAliasObj( targetObjPtr = Tcl_NewStringObj(targetCmd, -1); Tcl_IncrRefCount(targetObjPtr); - result = AliasCreate(childInterp, childInterp, targetInterp, childObjPtr, + result = TclAliasCreate(childInterp, childInterp, targetInterp, childObjPtr, targetObjPtr, objc, objv); Tcl_DecrRefCount(childObjPtr); @@ -1452,7 +1448,7 @@ TclPreventAliasLoop( /* *---------------------------------------------------------------------- * - * AliasCreate -- + * TclAliasCreate -- * * Helper function to do the work to actually create an alias. * @@ -1466,8 +1462,8 @@ TclPreventAliasLoop( *---------------------------------------------------------------------- */ -static int -AliasCreate( +int +TclAliasCreate( Tcl_Interp *interp, /* Interp for error reporting. */ Tcl_Interp *childInterp, /* Interp where alias cmd will live or from * which alias will be deleted. */ @@ -2468,7 +2464,7 @@ ChildCreate( TclNewLiteralStringObj(clockObj, "clock"); Tcl_IncrRefCount(clockObj); - status = AliasCreate(interp, childInterp, parentInterp, clockObj, + status = TclAliasCreate(interp, childInterp, parentInterp, clockObj, clockObj, 0, NULL); Tcl_DecrRefCount(clockObj); if (status != TCL_OK) { @@ -2558,7 +2554,7 @@ NRChildCmd( return AliasDelete(interp, childInterp, objv[2]); } } else { - return AliasCreate(interp, childInterp, interp, objv[2], + return TclAliasCreate(interp, childInterp, interp, objv[2], objv[3], objc - 4, objv + 4); } } diff --git a/generic/tclOO.c b/generic/tclOO.c index e0cde38..d7dea8d 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -445,6 +445,8 @@ InitFoundation( TclOOCallbackObjCmd, NULL, NULL, 0); CreateCmdInNS(interp, fPtr->helpersNs, "classvariable", TclOOClassVariableObjCmd, NULL, NULL, 0); + CreateCmdInNS(interp, fPtr->helpersNs, "link", + TclOOLinkObjCmd, NULL, NULL, 0); CreateCmdInNS(interp, fPtr->helpersNs, "next", NULL, TclOONextObjCmd, TclCompileObjectNextCmd, CMD_COMPILES_EXPANDED); CreateCmdInNS(interp, fPtr->helpersNs, "nextto", @@ -817,6 +819,7 @@ AllocObject( oPtr->myclassCommand = TclNRCreateCommandInNs(interp, "myclass", oPtr->namespacePtr, TclOOMyClassObjCmd, MyClassNRObjCmd, oPtr, MyClassDeleted); + oPtr->linkedCmdsList = NULL; return oPtr; } @@ -861,6 +864,17 @@ MyDeleted( { Object *oPtr = (Object *) clientData; + if (oPtr->linkedCmdsList) { + Tcl_Size linkc, i; + Tcl_Obj **linkv; + TclListObjGetElements(NULL, oPtr->linkedCmdsList, &linkc, &linkv); + for (i=0 ; ifPtr->interp, TclGetString(link)); + } + Tcl_DecrRefCount(oPtr->linkedCmdsList); + oPtr->linkedCmdsList = NULL; + } oPtr->myCommand = NULL; } diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 18dd5e9..6884db6 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -1014,6 +1014,98 @@ TclOO_Object_VarName( /* * ---------------------------------------------------------------------- * + * TclOOLinkObjCmd -- + * + * Implementation of the [link] command, that makes a command that + * invokes a method on the current object. The name of the command and + * the name of the method match by default. Note that this command is + * only ever to be used inside the body of a procedure-like method, + * and is typically intended for constructors. + * + * ---------------------------------------------------------------------- + */ +int +TclOOLinkObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + // Set up common bits. + CallFrame *framePtr = ((Interp *) interp)->varFramePtr; + if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s may only be called from inside a method", + TclGetString(objv[0]))); + OO_ERROR(interp, CONTEXT_REQUIRED); + return TCL_ERROR; + } + CallContext *context = (CallContext *) framePtr->clientData; + Object *oPtr = context->oPtr; + if (!oPtr->myCommand) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot link to non-existent callback handle")); + OO_ERROR(interp, MY_GONE); + return TCL_ERROR; + } + Tcl_Obj *myCmd = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, oPtr->myCommand, myCmd); + if (!oPtr->linkedCmdsList) { + oPtr->linkedCmdsList = Tcl_NewListObj(0, NULL); + Tcl_IncrRefCount(oPtr->linkedCmdsList); + } + + // For each argument + for (int i=1; ioPtr->namespacePtr->fullName, srcStr); + } + + // Make the alias command + if (TclAliasCreate(interp, interp, interp, src, myCmd, 1, &dst) != TCL_OK) { + Tcl_BounceRefCount(myCmd); + Tcl_BounceRefCount(src); + return TCL_ERROR; + } + + // Remember the alias for cleanup if necessary + Tcl_ListObjAppendElement(NULL, oPtr->linkedCmdsList, src); + } + Tcl_BounceRefCount(myCmd); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * * TclOONextObjCmd, TclOONextToObjCmd -- * * Implementation of the [next] and [nextto] commands. Note that these diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 7ea5999..777c7fa 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -255,6 +255,7 @@ struct Object { PropertyStorage properties; /* Information relating to the lists of * properties that this object *claims* to * support. */ + Tcl_Obj *linkedCmdsList; /* List of names of linked commands. */ }; enum ObjectFlags { @@ -521,6 +522,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclOOCallbackObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOClassVariableObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOCopyObjectCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODelegateNameObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOOLinkObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOONextObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOONextToObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOSelfObjCmd; diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 4a69bc8..79379d3 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -27,31 +27,6 @@ static const char *tclOOSetupScript = /* !BEGIN!: Do not edit below this line. */ "::namespace eval ::oo {\n" -"\tproc Helpers::link {args} {\n" -"\t\tset ns [uplevel 1 {::namespace current}]\n" -"\t\tforeach link $args {\n" -"\t\t\tif {[llength $link] == 2} {\n" -"\t\t\t\tlassign $link src dst\n" -"\t\t\t} elseif {[llength $link] == 1} {\n" -"\t\t\t\tlassign $link src\n" -"\t\t\t\tset dst $src\n" -"\t\t\t} else {\n" -"\t\t\t\treturn -code error -errorcode {TCL OO CMDLINK_FORMAT} \\\n" -"\t\t\t\t\t\"bad link description; must only have one or two elements\"\n" -"\t\t\t}\n" -"\t\t\tif {![string match ::* $src]} {\n" -"\t\t\t\tset src [string cat $ns :: $src]\n" -"\t\t\t}\n" -"\t\t\tinterp alias {} $src {} ${ns}::my $dst\n" -"\t\t\ttrace add command ${ns}::my delete [list \\\n" -"\t\t\t\t::oo::UnlinkLinkedCommand $src]\n" -"\t\t}\n" -"\t}\n" -"\tproc UnlinkLinkedCommand {cmd args} {\n" -"\t\tif {[namespace which $cmd] ne {}} {\n" -"\t\t\trename $cmd {}\n" -"\t\t}\n" -"\t}\n" "\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n" "\t\tset originDelegate [DelegateName $originObject]\n" "\t\tset targetDelegate [DelegateName $targetObject]\n" diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index e480aac..8bb214a 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -12,57 +12,6 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. ::namespace eval ::oo { - - # - # Commands that are made available to objects by default. - # - - # ------------------------------------------------------------------ - # - # link -- - # - # Make a command that invokes a method on the current object. - # The name of the command and the name of the method match by - # default. - # - # ------------------------------------------------------------------ - - proc Helpers::link {args} { - set ns [uplevel 1 {::namespace current}] - foreach link $args { - if {[llength $link] == 2} { - lassign $link src dst - } elseif {[llength $link] == 1} { - lassign $link src - set dst $src - } else { - return -code error -errorcode {TCL OO CMDLINK_FORMAT} \ - "bad link description; must only have one or two elements" - } - if {![string match ::* $src]} { - set src [string cat $ns :: $src] - } - interp alias {} $src {} ${ns}::my $dst - trace add command ${ns}::my delete [list \ - ::oo::UnlinkLinkedCommand $src] - } - } - - # ---------------------------------------------------------------------- - # - # UnlinkLinkedCommand -- - # - # Callback used to remove linked command when the underlying mechanism - # that supports it is deleted. - # - # ---------------------------------------------------------------------- - - proc UnlinkLinkedCommand {cmd args} { - if {[namespace which $cmd] ne {}} { - rename $cmd {} - } - } - # ---------------------------------------------------------------------- # # UpdateClassDelegatesAfterClone -- -- cgit v0.12