Index: generic/predefined.h =================================================================== diff -u -re8f814e896b7aac8326f9abef3a5e759b2a4ed18 -rf71845baf5b995318b585981109bdf114d95eb2f --- generic/predefined.h (.../predefined.h) (revision e8f814e896b7aac8326f9abef3a5e759b2a4ed18) +++ generic/predefined.h (.../predefined.h) (revision f71845baf5b995318b585981109bdf114d95eb2f) @@ -21,7 +21,8 @@ "::xotcl::Class method unknown {args} {\n" "eval my create $args}\n" "::xotcl::Object method init args {}\n" -"::xotcl::Object method objectparameter {} {;}\n" +"::xotcl::Object method objectparameter {} {\n" +"return \"\"}\n" "::xotcl::Class create ::xotcl::ParameterType\n" "foreach cmd [info command ::xotcl::cmd::ParameterType::*] {\n" "::xotcl::alias ::xotcl::ParameterType [namespace tail $cmd] $cmd}\n" Index: generic/predefined.xotcl =================================================================== diff -u -re8f814e896b7aac8326f9abef3a5e759b2a4ed18 -rf71845baf5b995318b585981109bdf114d95eb2f --- generic/predefined.xotcl (.../predefined.xotcl) (revision e8f814e896b7aac8326f9abef3a5e759b2a4ed18) +++ generic/predefined.xotcl (.../predefined.xotcl) (revision f71845baf5b995318b585981109bdf114d95eb2f) @@ -84,7 +84,10 @@ # provide a placeholder for the bootup process. The real definition # is based on slots, which are not available at this point. - ::xotcl::Object method objectparameter {} {;} + ::xotcl::Object method objectparameter {} { + #puts stderr "XXXX-objectparameter for [self] - INITIAL" + return "" + } # # create class and object for nonpositional argument processing @@ -318,6 +321,7 @@ # Provide the a slot based mechanism for building an object # configuration interface from slot definitions ::xotcl::Object method objectparameter {} { + #puts stderr "XXXX-objectparameter for [self]" set parameterdefinitions [list] # don't call [my info slotobjects], since filters on [self] # modifying the result (such as in the regression test) will cause Index: generic/xotcl.c =================================================================== diff -u -r761e656f18173eaa964679329035db9464c9f77d -rf71845baf5b995318b585981109bdf114d95eb2f --- generic/xotcl.c (.../xotcl.c) (revision 761e656f18173eaa964679329035db9464c9f77d) +++ generic/xotcl.c (.../xotcl.c) (revision f71845baf5b995318b585981109bdf114d95eb2f) @@ -48,14 +48,17 @@ #include "xotclAccessInt.h" #ifdef COMPILE_XOTCL_STUBS +# if defined(PRE86) extern XotclStubs xotclStubs; +# else +MODULE_SCOPE const XotclStubs * const xotclConstStubPtr; +# endif #endif #ifdef XOTCL_MEM_COUNT int xotclMemCountInterpCounter = 0; #endif - /* * Tcl_Obj Types for XOTcl Objects */ @@ -858,9 +861,9 @@ */ /* todo more generic */ -XOTCLINLINE static Tcl_ObjType * -GetCmdNameType(Tcl_ObjType *cmdType) { - static Tcl_ObjType *tclCmdNameType = NULL; +XOTCLINLINE static CONST86 Tcl_ObjType * +GetCmdNameType(Tcl_ObjType CONST86 *cmdType) { + static Tcl_ObjType CONST86 *tclCmdNameType = NULL; if (tclCmdNameType == NULL) { static XOTclMutex initMutex = 0; @@ -874,7 +877,7 @@ static int IsXOTclTclObj(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclObject **obj) { - Tcl_ObjType *cmdType = objPtr->typePtr; + Tcl_ObjType CONST86 *cmdType = objPtr->typePtr; if (cmdType == GetCmdNameType(cmdType)) { Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objPtr); if (cmd) { @@ -1534,7 +1537,7 @@ /* Case 3: Does the variable exist in the per-object namespace? */ *varPtr = (Tcl_Var)LookupVarFromTable(Tcl_Namespace_varTable(nsPtr), name, NULL); - if(*varPtr == NULL) { + if (*varPtr == NULL) { /* We failed to find the variable so far, therefore we create it * here in the namespace. Note that the cases (1), (2) and (3) * TCL_CONTINUE care for variable creation if necessary. @@ -4632,10 +4635,13 @@ # include # endif +#if defined(PRE86) +# define Tcl_GetErrorLine(interp) (interp)->errorLine +#endif + static void MakeProcError( - Tcl_Interp *interp, /* The interpreter in which the procedure was - * called. */ + Tcl_Interp *interp, /* The interpreter in which the procedure was called. */ Tcl_Obj *procNameObj) /* Name of the procedure. Used for error * messages and trace information. */ { @@ -4646,7 +4652,7 @@ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (procedure \"%.*s%s\" line %d)", (overflow ? limit : nameLen), procName, - (overflow ? "..." : ""), interp->errorLine)); + (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } /* @@ -4666,7 +4672,7 @@ Namespace *nsPtr = procPtr->cmdPtr->nsPtr; CallFrame *framePtr; int result; - static Tcl_ObjType *byteCodeType = NULL; + static Tcl_ObjType CONST86 *byteCodeType = NULL; if (byteCodeType == NULL) { static XOTclMutex initMutex = 0; @@ -4918,16 +4924,65 @@ /* * method dispatch */ +#if defined(NRE) +static int +FinalizeProcMethod(ClientData data[], Tcl_Interp *interp, int result) { + parseContext *pcPtr = data[0]; + XOTclCallStackContent *cscPtr = data[1]; + XOTclObject *obj = cscPtr->self; + + fprintf(stderr, "FinalizeProcMethod result %d, csc %p, pcPtr %p, obj %p\n", + result, cscPtr, pcPtr, obj); +# if defined(TCL85STACK_TRACE) + fprintf(stderr, "POP OBJECT_FRAME (implicit) frame %p csc %p obj %s obj refcount %d %d\n", NULL, csc, + objectName(obj), + obj->id ? Tcl_Command_refCount(obj->id) : -100, + obj->refCount + ); +# endif +#if 0 +#ifdef DISPATCH_TRACE + printExit(interp, "invokeProcMethod", objc, objv, result); + /* fprintf(stderr, " returnCode %d xotcl rc %d\n", + Tcl_Interp_returnCode(interp), result);*/ +#endif +#endif + +#if 0 + /* for now, we have no methodname etc.... so we deactivete post checks temporarly */ + opt = obj->opt; + if (opt && obj->teardown && (opt->checkoptions & CHECK_POST)) { + result = AssertionCheck(interp, obj, cl, methodName, CHECK_POST); + } +#endif + + if (pcPtr) { + fprintf(stderr, "FinalizeProcMethod calls pop\n"); + parseContextRelease(pcPtr); + TclStackFree(interp, pcPtr); + } + + fprintf(stderr, "FinalizeProcMethod calls pop\n"); + CallStackPop(interp, cscPtr); + TclStackFree(interp, cscPtr); + + return result; +} +#endif + /* invoke a method implemented as a proc/instproc (with assertion checking) */ static int invokeProcMethod(ClientData cp, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], char *methodName, XOTclObject *obj, XOTclClass *cl, Tcl_Command cmdPtr, XOTclCallStackContent *csc) { int result, releasePc = 0; XOTclObjectOpt *opt = obj->opt; - parseContext pc; - +#if defined(NRE) + parseContext *pcPtr = NULL; +#else + parseContext pc, *pcPtr = &pc; +#endif #if defined(PRE85) XOTcl_FrameDecls; #endif @@ -5001,11 +5056,7 @@ * latter is callable from the outside (e.g. from XOTcl). This new * interface allows us to setup the XOTcl callframe before the * bytecode of the method body (provisioned by PushProcCallFrame) - * is executed. On the medium range, we do not need the xotcl - * callframe when we stop supporting Tcl 8.4 (we should simply use - * the calldata field in the callstack), which should be managed - * here or in PushProcCallFrame. At the same time, we could do the - * non-pos-arg handling here as well. + * is executed for tcl 8.4 versions. */ #if !defined(PRE85) /*fprintf(stderr, "\tproc=%s cp=%p %d\n", Tcl_GetCommandName(interp, cmd),cp, isTclProc);*/ @@ -5021,10 +5072,13 @@ ((XOTclProcContext *)Tcl_Command_deleteData(cmdPtr))->paramDefs : NULL; if (paramDefs) { - result = ProcessMethodArguments(&pc, interp, obj, 1, paramDefs, methodName, objc, objv); +#if defined(NRE) + pcPtr = (parseContext *) TclStackAlloc(interp, sizeof(parseContext)); +#endif + result = ProcessMethodArguments(pcPtr, interp, obj, 1, paramDefs, methodName, objc, objv); if (result == TCL_OK) { releasePc = 1; - result = PushProcCallFrame(cp, interp, pc.objc, pc.full_objv, csc); + result = PushProcCallFrame(cp, interp, pcPtr->objc, pcPtr->full_objv, csc); } } else { result = PushProcCallFrame(cp, interp, objc, objv, csc); @@ -5034,6 +5088,12 @@ result = PushProcCallFrame(cp, interp, objc, objv, csc); # endif + if (result != TCL_OK) { +#if defined(NRE) + if (pcPtr) TclStackFree(interp, pcPtr); +#endif + } + /* * The stack frame is pushed, we could do something here before * running the byte code of the body. @@ -5042,12 +5102,17 @@ #if !defined(TCL85STACK) RUNTIME_STATE(interp)->cs.top->currentFramePtr = (Tcl_CallFrame *) Tcl_Interp_varFramePtr(interp); #endif +#if !defined(NRE) result = TclObjInterpProcCore(interp, objv[0], 1, &MakeProcError); if (releasePc) { parseContextRelease(&pc); } - } else { - result = TCL_ERROR; +#else + fprintf(stderr, "CALL TclNRInterpProcCore %s.%s\n", objectName(obj), ObjStr(objv[0])); + Tcl_NRAddCallback(interp, FinalizeProcMethod, releasePc ? pcPtr : NULL, csc, NULL, NULL); + result = TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError); + fprintf(stderr, "CALL TclNRInterpProcCore DONE\n"); +#endif } # if defined(TCL85STACK_TRACE) fprintf(stderr, "POP OBJECT_FRAME (implicit) frame %p csc %p obj %s obj refcount %d %d\n", NULL, csc, @@ -5060,20 +5125,19 @@ result = (*Tcl_Command_objProc(cmdPtr))(cp, interp, objc, objv); #endif -#ifdef DISPATCH_TRACE +#if defined(PRE86) +# ifdef DISPATCH_TRACE printExit(interp, "invokeProcMethod", objc, objv, result); /* fprintf(stderr, " returnCode %d xotcl rc %d\n", Tcl_Interp_returnCode(interp), result);*/ -#endif +# endif - /* fprintf(stderr, "dispatch returned %d rst = %d\n", result, rst->returnCode);*/ - opt = obj->opt; if (opt && obj->teardown && (opt->checkoptions & CHECK_POST)) { result = AssertionCheck(interp, obj, cl, methodName, CHECK_POST); } - +#endif finish: return result; } @@ -5125,7 +5189,11 @@ printCall(interp, "invokeCmdMethod cmd", objc, objv); fprintf(stderr, "\tcmd=%s\n", Tcl_GetCommandName(interp, cmdPtr)); #endif +#if 1 || !defined(NRE) result = (*Tcl_Command_objProc(cmdPtr))(cp, interp, objc, objv); +#else + result = Tcl_NRCallObjProc(interp, Tcl_Command_objProc(cmdPtr), cp, objc, objv); +#endif #ifdef DISPATCH_TRACE printExit(interp, "invokeCmdMethod cmd", objc, objv, result); #endif @@ -5178,19 +5246,20 @@ Tcl_Command cmd, XOTclObject *obj, XOTclClass *cl, char *methodName, int frameType) { ClientData cp = Tcl_Command_objClientData(cmd); - XOTclCallStackContent csc, *cscPtr = &csc; + XOTclCallStackContent *cscPtr; register Tcl_ObjCmdProc *proc = Tcl_Command_objProc(cmd); int result; assert (!obj->teardown); - /* before, we had a logic like the following: - if (!obj->teardown) { - return TCL_OK; - } */ - /*fprintf(stderr, "InvokeMethod method '%s' cmd %p cp=%p objc=%d\n",methodName,cmd, cp, objc);*/ if (proc == TclObjInterpProc) { +#if defined(NRE) + cscPtr = (XOTclCallStackContent *) TclStackAlloc(interp, sizeof(XOTclCallStackContent)); +#else + XOTclCallStackContent csc; + cscPtr = &csc; +#endif /* * invoke a Tcl-defined method */ @@ -5201,10 +5270,14 @@ return TCL_ERROR; #endif result = invokeProcMethod(cp, interp, objc, objv, methodName, obj, cl, cmd, cscPtr); +#if !defined(NRE) CallStackPop(interp, cscPtr); +#endif return result; } else if (cp) { + XOTclCallStackContent csc; + cscPtr = &csc; /* some cmd with client data */ if (proc == XOTclObjDispatch) { @@ -8336,7 +8409,11 @@ XOTcl_PushFrame(interp, obj); } if (tcd->objProc) { - result = (tcd->objProc)(tcd->clientData, interp, objc, objv); +#if 1 || !defined(NRE) + result = (*tcd->objProc)(tcd->clientData, interp, objc, objv); +#else + result = Tcl_NRCallObjProc(interp, tcd->objProc, tcd->clientData, objc, objv); +#endif } else if (IsXOTclTclObj(interp, tcd->cmdName, (XOTclObject**)&clientData)) { /*fprintf(stderr, "XOTcl object %s, objc=%d\n", ObjStr(tcd->cmdName), objc);*/ result = XOTclObjDispatch(clientData, interp, objc, objv); @@ -8538,9 +8615,14 @@ /*fprintf(stderr, "objscopedMethod obj=%p, ptr=%p\n", obj, tcd->objProc);*/ XOTcl_PushFrame(interp, obj); - result = (tcd->objProc)(tcd->clientData, interp, objc, objv); - XOTcl_PopFrame(interp, obj); +#if 1 || !defined(NRE) + result = (*tcd->objProc)(tcd->clientData, interp, objc, objv); +#else + result = Tcl_NRCallObjProc(interp, tcd->objProc, tcd->clientData, objc, objv); +#endif + + XOTcl_PopFrame(interp, obj); return result; } @@ -8557,7 +8639,7 @@ static dashArgType isDashArg(Tcl_Interp *interp, Tcl_Obj *obj, char **methodName, int *objc, Tcl_Obj **objv[]) { char *flag; - static Tcl_ObjType *listType = NULL; + static Tcl_ObjType CONST86 *listType = NULL; assert(obj); @@ -9643,7 +9725,7 @@ if (result != TCL_OK) { fprintf(stderr, "User defined exit handler contains errors!\n" "Error in line %d: %s\nExecution interrupted.\n", - interp->errorLine, ObjStr(Tcl_GetObjResult(interp))); + Tcl_GetErrorLine(interp), ObjStr(Tcl_GetObjResult(interp))); } for (os = RUNTIME_STATE(interp)->rootClasses; os; os = os->nextPtr) { @@ -10541,7 +10623,9 @@ if (result == TCL_OK) { rawConfArgs = Tcl_GetObjResult(interp); INCR_REF_COUNT(rawConfArgs); - +#if !defined(PRE86) + fprintf(stderr, "the result of OBJECTPARAMETER was %s, now parse it...\n", ObjStr(rawConfArgs)); +#endif /* Parse the string representation to obtain the internal representation */ result = ParamDefsParse(interp, methodName, rawConfArgs, XOTCL_ARG_OBJECT_PARAMETER, parsedParamPtr); if (result == TCL_OK && RUNTIME_STATE(interp)->cacheInterface) { @@ -10599,8 +10683,8 @@ for (i = 1, paramPtr = paramDefs->paramsPtr; i < paramDefs->nrParams; i++, paramPtr++) { newValue = pc.full_objv[i]; - /*fprintf(stderr, "newValue of %s = %p '%s'\n", ObjStr(paramPtr->objName), - newValue, newValue ? ObjStr(newValue) : "(null)"); */ + /* fprintf(stderr, "newValue of %s = %p '%s'\n", ObjStr(paramPtr->nameObj), + newValue, newValue ? ObjStr(newValue) : "(null)"); */ if (newValue == XOTclGlobalObjects[XOTE___UNKNOWN__]) { /* nothing to do here */ @@ -11012,7 +11096,7 @@ } if (result == TCL_ERROR) { char msg[32 + TCL_INTEGER_SPACE]; - sprintf(msg, "\n (\"uplevel\" body line %d)", interp->errorLine); + sprintf(msg, "\n (\"uplevel\" body line %d)", Tcl_GetErrorLine(interp)); Tcl_AddObjErrorInfo(interp, msg, -1); } @@ -12605,7 +12689,11 @@ #ifndef AOL_SERVER /* the AOL server uses a different package loading mechanism */ # ifdef COMPILE_XOTCL_STUBS +# if defined(PRE86) Tcl_PkgProvideEx(interp, "XOTcl", PACKAGE_VERSION, (ClientData)&xotclStubs); +# else + Tcl_PkgProvideEx(interp, "XOTcl", PACKAGE_VERSION, (ClientData)&xotclConstStubPtr); +# endif # else Tcl_PkgProvide(interp, "XOTcl", PACKAGE_VERSION); # endif Index: generic/xotcl.h =================================================================== diff -u -ra6087540279fa5a9110728605795620ecd43e10e -rf71845baf5b995318b585981109bdf114d95eb2f --- generic/xotcl.h (.../xotcl.h) (revision a6087540279fa5a9110728605795620ecd43e10e) +++ generic/xotcl.h (.../xotcl.h) (revision f71845baf5b995318b585981109bdf114d95eb2f) @@ -76,12 +76,15 @@ #define CONFIGURE_ARGS_TRACE 1 */ -/* +/* some features #define TCL85STACK 1 #define CANONICAL_ARGS 1 */ + +#if !defined(PRE86) #define CANONICAL_ARGS 1 #define TCL85STACK 1 +#endif #if defined(PARSE_TRACE_FULL) # define PARSE_TRACE 1 @@ -117,6 +120,17 @@ # define PRE85 #endif +#if TCL_MAJOR_VERSION==8 && TCL_MINOR_VERSION<6 +# define PRE86 +#endif + +#if defined(PRE86) +# define CONST86 +# else +/*# define NRE*/ +#endif + + #if !defined(FORWARD_COMPATIBLE) # if defined(PRE85) # define FORWARD_COMPATIBLE 1 Index: generic/xotclStubInit.c =================================================================== diff -u -ra4d1fd30453e4e87467b02ed749fb4007d46a5e0 -rf71845baf5b995318b585981109bdf114d95eb2f --- generic/xotclStubInit.c (.../xotclStubInit.c) (revision a4d1fd30453e4e87467b02ed749fb4007d46a5e0) +++ generic/xotclStubInit.c (.../xotclStubInit.c) (revision f71845baf5b995318b585981109bdf114d95eb2f) @@ -83,3 +83,6 @@ }; /* !END!: Do not edit above this line. */ + +MODULE_SCOPE const XotclStubs * const xotclConstStubPtr; +const XotclStubs * const xotclConstStubPtr = &xotclStubs; Index: generic/xotclStubLib.c =================================================================== diff -u -r2111020b49da8ce57758e51accf0b6073037f0d2 -rf71845baf5b995318b585981109bdf114d95eb2f --- generic/xotclStubLib.c (.../xotclStubLib.c) (revision 2111020b49da8ce57758e51accf0b6073037f0d2) +++ generic/xotclStubLib.c (.../xotclStubLib.c) (revision f71845baf5b995318b585981109bdf114d95eb2f) @@ -19,7 +19,7 @@ */ #ifndef USE_TCL_STUBS -#define USE_TCL_STUBS +# define USE_TCL_STUBS #endif #undef USE_TCL_STUB_PROCS @@ -29,14 +29,21 @@ */ #ifndef USE_XOTCL_STUBS -#define USE_XOTCL_STUBS +# define USE_XOTCL_STUBS #endif #include "xotclInt.h" -XotclStubs *xotclStubsPtr = NULL; -XotclIntStubs *xotclIntStubsPtr = NULL; +#if defined(PRE86) +extern XotclStubs *xotclStubsPtr; +#else +MODULE_SCOPE const XotclStubs *xotclStubsPtr; +MODULE_SCOPE const XotclIntStubs *xotclIntStubsPtr; +#endif +CONST86 XotclStubs *xotclStubsPtr = NULL; +CONST86 XotclIntStubs *xotclIntStubsPtr = NULL; + /* *---------------------------------------------------------------------- * @@ -56,30 +63,40 @@ */ CONST char * -Xotcl_InitStubs (interp, version, exact) - Tcl_Interp *interp; - CONST char *version; - int exact; -{ +Xotcl_InitStubs (Tcl_Interp *interp, CONST char *version, int exact) { CONST char *actualVersion; + const char *packageName = "XOTcl"; + ClientData clientData = NULL; actualVersion = Tcl_PkgRequireEx(interp, "XOTcl", version, exact, - (ClientData *) &xotclStubsPtr); + &clientData); - if (actualVersion == NULL) { - xotclStubsPtr = NULL; + if (clientData == NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "Error loading ", packageName, " package; ", + "package not present or incomplete", NULL); return NULL; - } + } else { + CONST86 XotclStubs * const stubsPtr = clientData; + CONST86 XotclIntStubs * const intStubsPtr = stubsPtr->hooks ? + stubsPtr->hooks->xotclIntStubs : NULL; - if (xotclStubsPtr == NULL) { + if (actualVersion == NULL) { return NULL; - } + } - if (xotclStubsPtr->hooks) { - xotclIntStubsPtr = xotclStubsPtr->hooks->xotclIntStubs; - } else { - xotclIntStubsPtr = NULL; - } + if (!stubsPtr || !intStubsPtr) { + static char *errMsg = "missing stub table pointer"; + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "Error loading ", packageName, " package", + " (requested version '", version, "', loaded version '", + actualVersion, "'): ", errMsg, NULL); + return NULL; + } - return actualVersion; + xotclStubsPtr = stubsPtr; + xotclIntStubsPtr = intStubsPtr; + + return actualVersion; + } }