Index: doc/index.html =================================================================== diff -u -r666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0 -r477c12e1b0f192ab18de415e30001ea151d7ddda --- doc/index.html (.../index.html) (revision 666f7ad2cb2562f3d62fc9aea54efb9b0826f6b0) +++ doc/index.html (.../index.html) (revision 477c12e1b0f192ab18de415e30001ea151d7ddda) @@ -23,7 +23,7 @@

Index: generic/gentclAPI.decls =================================================================== diff -u -rb708f296be8c5cbd3e4daa959713483dbdfdfd82 -r477c12e1b0f192ab18de415e30001ea151d7ddda --- generic/gentclAPI.decls (.../gentclAPI.decls) (revision b708f296be8c5cbd3e4daa959713483dbdfdfd82) +++ generic/gentclAPI.decls (.../gentclAPI.decls) (revision 477c12e1b0f192ab18de415e30001ea151d7ddda) @@ -33,6 +33,7 @@ {-argName "rootMetaClass" -required 1 -type tclobj} } xotclCmd deprecated XOTclDeprecatedCmd { + {-argName "what" -required 1} {-argName "oldCmd" -required 1} {-argName "newCmd" -required 0} } Index: generic/predefined.h =================================================================== diff -u -rb708f296be8c5cbd3e4daa959713483dbdfdfd82 -r477c12e1b0f192ab18de415e30001ea151d7ddda --- generic/predefined.h (.../predefined.h) (revision b708f296be8c5cbd3e4daa959713483dbdfdfd82) +++ generic/predefined.h (.../predefined.h) (revision 477c12e1b0f192ab18de415e30001ea151d7ddda) @@ -58,7 +58,6 @@ "foreach cmd [info command ::xotcl::cmd::ClassInfo::*] {\n" "set cmdName [namespace tail $cmd]\n" "if {$cmdName in [list \"instfilter\" \"instforward\" \"instmixin\" \"instparams\"]} continue\n" -"puts stderr \"adding ::xotcl::alias ::xotcl2::classInfo $cmdName $cmd\"\n" "::xotcl::alias ::xotcl2::classInfo $cmdName $cmd}\n" "unset cmd\n" "Object forward info -onerror ::xotcl::infoError -verbose ::xotcl2::objectInfo %1 {%@2 %self}\n" @@ -195,8 +194,8 @@ "::xotcl::dispatch ${.domain} ::xotcl::cmd::Class::forward \\\n" "{*}[expr {${.per-object} ? \"-per-object\" : \"\"}] ${.name} \\\n" "-verbose \\\n" -"-default [${.manager} defaultmethods] ${.manager} %1 %self \\\n" -"{*}[expr {[info exists .forward-per-object] ? \"-per-object\" : \"\"}] \\\n" +"${.manager} [list %1 [${.manager} defaultmethods]] %self \\\n" +"\"%-per-object [info exists .forward-per-object]\" \\\n" "%proc}}\n" "::xotcl::MetaSlot create ::xotcl::InfoSlot\n" "createBootstrapAttributeSlots ::xotcl::InfoSlot {\n" @@ -232,12 +231,12 @@ "::xotcl::alias ::xotcl::InterceptorSlot set ::xotcl::relation ;# for backwards compatibility\n" "::xotcl::alias ::xotcl::InterceptorSlot assign ::xotcl::relation\n" "::xotcl::InterceptorSlot method add {obj -per-object:switch prop value {pos 0}} {\n" -"puts stderr interceptorslot-add-[self args]\n" +"puts stderr interceptorslot-add-obj=$obj,per-object=${per-object},prop=$prop,value=$value,pos=$pos\n" "if {![set .multivalued]} {\n" "error \"Property $prop of ${.domain}->$obj ist not multivalued\"}\n" -"puts stderr \"BEFORE: $obj info $prop -guards => '[$obj info $prop -guards]'\"\n" -"puts stderr \"$obj $prop [linsert [$obj info $prop -guards] $pos $value]\"\n" -"$obj $prop [linsert [$obj info $prop -guards] $pos $value]}\n" +"set perObject [expr {${per-object} ? \"-per-object\" : \"\"}]\n" +"set oldSetting [::xotcl::relation $obj {*}$perObject $prop]\n" +"$obj $prop {*}$perObject [linsert $oldSetting $pos $value]}\n" "proc ::xotcl::register_system_slots {os} {\n" "${os}::Object alloc ${os}::Class::slot\n" "${os}::Object alloc ${os}::Object::slot\n" @@ -247,6 +246,8 @@ "::xotcl::alias ${os}::Object::slot::class assign ::xotcl::relation\n" "::xotcl::InterceptorSlot create ${os}::Object::slot::mixin \\\n" "-type relation\n" +"::xotcl::dispatch ::xotcl2::Class ::xotcl::cmd::Class::forward -- \\\n" +"\"-per-object\" -verbose -default [list get assign] ::xotcl2::Object::slot::mixin add %self %proc\n" "::xotcl::InterceptorSlot create ${os}::Object::slot::filter \\\n" "-elementtype \"\" -type relation}\n" "::xotcl::register_system_slots ::xotcl2\n" Index: generic/predefined.xotcl =================================================================== diff -u -rb708f296be8c5cbd3e4daa959713483dbdfdfd82 -r477c12e1b0f192ab18de415e30001ea151d7ddda --- generic/predefined.xotcl (.../predefined.xotcl) (revision b708f296be8c5cbd3e4daa959713483dbdfdfd82) +++ generic/predefined.xotcl (.../predefined.xotcl) (revision 477c12e1b0f192ab18de415e30001ea151d7ddda) @@ -108,7 +108,6 @@ .method unknown {method obj args} { error "[::xotcl::self] unknown info option \"$method\"; [$obj info info]" } - } ::xotcl::dispatch classInfo -objscope ::eval { @@ -384,13 +383,15 @@ } if {${.domain} ne ""} { ${.domain} invalidateobjectparameter - # since the domain object might be xotcl1 or 2, use dispatch + # since the domain object might be xotcl1 or xotcl2, use dispatch + ::xotcl::dispatch ${.domain} ::xotcl::cmd::Class::forward \ {*}[expr {${.per-object} ? "-per-object" : ""}] ${.name} \ -verbose \ - -default [${.manager} defaultmethods] ${.manager} %1 %self \ - {*}[expr {[info exists .forward-per-object] ? "-per-object" : ""}] \ + ${.manager} [list %1 [${.manager} defaultmethods]] %self \ + "%-per-object [info exists .forward-per-object]" \ %proc + } } @@ -451,13 +452,17 @@ ::xotcl::alias ::xotcl::InterceptorSlot assign ::xotcl::relation ::xotcl::InterceptorSlot method add {obj -per-object:switch prop value {pos 0}} { - puts stderr interceptorslot-add-[self args] + puts stderr interceptorslot-add-obj=$obj,per-object=${per-object},prop=$prop,value=$value,pos=$pos if {![set .multivalued]} { error "Property $prop of ${.domain}->$obj ist not multivalued" } - puts stderr "BEFORE: $obj info $prop -guards => '[$obj info $prop -guards]'" - puts stderr "$obj $prop [linsert [$obj info $prop -guards] $pos $value]" - $obj $prop [linsert [$obj info $prop -guards] $pos $value] + set perObject [expr {${per-object} ? "-per-object" : ""}] + #puts stderr "perObject=$perObject // ${per-object} // ${.per-object}" + set oldSetting [::xotcl::relation $obj {*}$perObject $prop] + #set oldSetting [$obj info $prop -guards] + #puts stderr "BEFORE: $obj info $perObject $prop -guards => '$oldSetting', pos=$pos, value=$value" + #puts stderr "CALL $obj $prop [list [linsert $oldSetting $pos $value]]" + $obj $prop {*}$perObject [linsert $oldSetting $pos $value] } ############################################ @@ -472,10 +477,23 @@ ::xotcl::InfoSlot create ${os}::Object::slot::class -type relation ::xotcl::alias ${os}::Object::slot::class assign ::xotcl::relation + ::xotcl::InterceptorSlot create ${os}::Object::slot::mixin \ -type relation +# ::xotcl::InterceptorSlot create ${os}::Class::slot::mixin \ +# -forward-per-object true \ +# -type relation +# ::xotcl::dispatch ::xotcl2::Class ::xotcl::cmd::Class::forward mixin -verbose -default [list get assign] ::xotcl2::Class::slot::mixin %1 %self %proc + + ::xotcl::dispatch ::xotcl2::Class ::xotcl::cmd::Class::forward -- \ + "-per-object" -verbose -default [list get assign] ::xotcl2::Object::slot::mixin add %self %proc + +# ::xotcl::dispatch ::xotcl2::classInfo ::xotcl::cmd::Object::forward \ +# "-per-object" -verbose ::xotcl2::objectInfo {%@2 %1} + ::xotcl::InterceptorSlot create ${os}::Object::slot::filter \ -elementtype "" -type relation + # ::xotcl::InterceptorSlot create ${os}::Class::slot::object-mixin \ # -type relation # ::xotcl::InterceptorSlot create ${os}::Class::slot::instfilter \ Index: generic/tclAPI.h =================================================================== diff -u -rb708f296be8c5cbd3e4daa959713483dbdfdfd82 -r477c12e1b0f192ab18de415e30001ea151d7ddda --- generic/tclAPI.h (.../tclAPI.h) (revision b708f296be8c5cbd3e4daa959713483dbdfdfd82) +++ generic/tclAPI.h (.../tclAPI.h) (revision 477c12e1b0f192ab18de415e30001ea151d7ddda) @@ -265,7 +265,7 @@ static int XOTclAliasCmd(Tcl_Interp *interp, XOTclObject *object, char *methodName, int withObjscope, int withPer_object, int withProtected, Tcl_Obj *cmdName); static int XOTclConfigureCmd(Tcl_Interp *interp, int configureoption, Tcl_Obj *value); static int XOTclCreateObjectSystemCmd(Tcl_Interp *interp, Tcl_Obj *rootClass, Tcl_Obj *rootMetaClass); -static int XOTclDeprecatedCmd(Tcl_Interp *interp, char *oldCmd, char *newCmd); +static int XOTclDeprecatedCmd(Tcl_Interp *interp, char *what, char *oldCmd, char *newCmd); static int XOTclDispatchCmd(Tcl_Interp *interp, XOTclObject *object, int withObjscope, Tcl_Obj *command, int nobjc, Tcl_Obj *CONST nobjv[]); static int XOTclDotCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int XOTclFinalizeObjCmd(Tcl_Interp *interp); @@ -2036,11 +2036,12 @@ &pc) != TCL_OK) { return TCL_ERROR; } else { - char *oldCmd = (char *)pc.clientData[0]; - char *newCmd = (char *)pc.clientData[1]; + char *what = (char *)pc.clientData[0]; + char *oldCmd = (char *)pc.clientData[1]; + char *newCmd = (char *)pc.clientData[2]; parseContextRelease(&pc); - return XOTclDeprecatedCmd(interp, oldCmd, newCmd); + return XOTclDeprecatedCmd(interp, what, oldCmd, newCmd); } } @@ -2661,7 +2662,8 @@ {"rootClass", 1, 0, convertToTclobj}, {"rootMetaClass", 1, 0, convertToTclobj}} }, -{"::xotcl::deprecated", XOTclDeprecatedCmdStub, 2, { +{"::xotcl::deprecated", XOTclDeprecatedCmdStub, 3, { + {"what", 1, 0, convertToString}, {"oldCmd", 1, 0, convertToString}, {"newCmd", 0, 0, convertToString}} }, Index: generic/xotcl.c =================================================================== diff -u -rb708f296be8c5cbd3e4daa959713483dbdfdfd82 -r477c12e1b0f192ab18de415e30001ea151d7ddda --- generic/xotcl.c (.../xotcl.c) (revision b708f296be8c5cbd3e4daa959713483dbdfdfd82) +++ generic/xotcl.c (.../xotcl.c) (revision 477c12e1b0f192ab18de415e30001ea151d7ddda) @@ -135,6 +135,7 @@ int passthrough; int needobjmap; int verbose; + int hasNonposArgs; int nr_args; Tcl_Obj *args; int objscope; @@ -873,6 +874,19 @@ } /* + * prints a msg to the screen that oldCmd is deprecated + * optinal: give a new cmd + */ +static int +XOTclDeprecatedCmd(Tcl_Interp *interp, char *what, char *oldCmd, char *newCmd) { + fprintf(stderr, "**\n**\n** The %s <%s> is deprecated.\n", what, oldCmd); + if (newCmd) + fprintf(stderr, "** Use <%s> instead.\n", newCmd); + fprintf(stderr, "**\n"); + return TCL_OK; +} + +/* * Tcl_Obj functions for objects */ @@ -3759,6 +3773,9 @@ Tcl_Obj *list = Tcl_NewListObj(0, NULL); XOTclClass *mixinClass; + /*fprintf(stderr, " mixin info m=%p, pattern %s, matchObject %p\n", + m, pattern, matchObject);*/ + while (m) { /* fprintf(stderr, " mixin info m=%p, next=%p, pattern %s, matchObject %p\n", m, m->next, pattern, matchObject);*/ @@ -6476,6 +6493,14 @@ memset(tcd, 0, sizeof(forwardCmdClientData)); if (withDefault) { + Tcl_DString ds, *dsPtr = &ds; + DSTRING_INIT(dsPtr); + Tcl_DStringAppend(dsPtr, "%1 {", 4); + Tcl_DStringAppend(dsPtr, ObjStr(withDefault), -1); + Tcl_DStringAppend(dsPtr, "}", 1); + XOTclDeprecatedCmd(interp, "forward option","-default ...",Tcl_DStringValue(dsPtr)); + DSTRING_FREE(dsPtr); + tcd->subcommands = withDefault; result = Tcl_ListObjLength(interp, withDefault, &tcd->nr_subcommands); INCR_REF_COUNT(tcd->subcommands); @@ -6498,6 +6523,7 @@ char *element = ObjStr(objv[i]); /*fprintf(stderr, "... [%d] forwardprocess element '%s'\n",i,element);*/ tcd->needobjmap |= (*element == '%' && *(element+1) == '@'); + tcd->hasNonposArgs |= (*element == '%' && *(element+1) == '-'); if (tcd->args == NULL) { tcd->args = Tcl_NewListObj(1, &objv[i]); tcd->nr_args++; @@ -8400,52 +8426,60 @@ static int forwardArg(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], - Tcl_Obj *o, forwardCmdClientData *tcd, Tcl_Obj **out, - Tcl_Obj **freeList, int *inputarg, int *mapvalue) { - char *element = ObjStr(o), *p; + Tcl_Obj *forwardArgObj, forwardCmdClientData *tcd, Tcl_Obj **out, + Tcl_Obj **freeList, int *inputArg, int *mapvalue, + int firstPosArg, int *outputincr) { + char *forwardArgString = ObjStr(forwardArgObj), *p; int totalargs = objc + tcd->nr_args - 1; - char c = *element, c1; + char c = *forwardArgString, c1; + + /* per default every forwardArgString from the processed list corresponds to exactly + one forwardArgString in the computed final list */ + *outputincr = 1; + p = forwardArgString; - p = element; + /*fprintf(stderr, "ForwardArg: processing '%s'\n", forwardArgString);*/ - if (c == '%' && *(element+1) == '@') { + if (c == '%' && *(forwardArgString+1) == '@') { char *remainder = NULL; long pos; - element += 2; - pos = strtol(element,&remainder, 0); - /*fprintf(stderr, "strtol('%s) returned %ld '%s'\n", element, pos, remainder);*/ - if (element == remainder && *element == 'e' && !strncmp(element, "end", 3)) { + forwardArgString += 2; + pos = strtol(forwardArgString,&remainder, 0); + /*fprintf(stderr, "strtol('%s) returned %ld '%s'\n", forwardArgString, pos, remainder);*/ + if (forwardArgString == remainder && *forwardArgString == 'e' + && !strncmp(forwardArgString, "end", 3)) { pos = -1; remainder += 3; } else if (pos < 0) { pos --; } - if (element == remainder || abs(pos) > totalargs) { + if (forwardArgString == remainder || abs(pos) > totalargs) { return XOTclVarErrMsg(interp, "forward: invalid index specified in argument ", - ObjStr(o), (char *) NULL); + ObjStr(forwardArgObj), (char *) NULL); } if (!remainder || *remainder != ' ') { - return XOTclVarErrMsg(interp, "forward: invaild syntax in '", ObjStr(o), + return XOTclVarErrMsg(interp, "forward: invaild syntax in '", ObjStr(forwardArgObj), "' use: %@ ",(char *) NULL); } - element = ++remainder; + forwardArgString = ++remainder; /* in case we address from the end, we reduct further to distinguish from -1 (void) */ if (pos<0) pos--; /*fprintf(stderr, "remainder = '%s' pos = %ld\n", remainder, pos);*/ *mapvalue = pos; - element = remainder; - c = *element; + forwardArgString = remainder; + c = *forwardArgString; } - /*fprintf(stderr, "c==%c element = '%s'\n", c, element);*/ + if (c == '%') { Tcl_Obj *list = NULL, **listElements; - int nrArgs = objc-1, nrElements = 0; - c = *++element; - c1 = *(element+1); + int nrArgs = objc-firstPosArg, nrElements = 0; + char *firstActualArgument = nrArgs>0 ? ObjStr(objv[1]) : NULL; + c = *++forwardArgString; + c1 = *(forwardArgString+1); - if (c == 's' && !strcmp(element, "self")) { + if (c == 's' && !strcmp(forwardArgString, "self")) { *out = tcd->obj->cmdName; - } else if (c == 'p' && !strcmp(element, "proc")) { + } else if (c == 'p' && !strcmp(forwardArgString, "proc")) { char *methodName = ObjStr(objv[0]); /* if we dispatch a method via ".", we do not want to see the "." in the %proc, e.g. for the interceptor slots (such as @@ -8456,65 +8490,131 @@ *out = objv[0]; } } else if (c == '1' && (c1 == '\0' || c1 == ' ')) { - /*fprintf(stderr, " nrArgs=%d, subcommands=%d inputarg=%d, objc=%d\n", - nrArgs, tcd->nr_subcommands, *inputarg, objc);*/ + if (c1 != '\0') { - if (Tcl_ListObjIndex(interp, o, 1, &list) != TCL_OK) { - return XOTclVarErrMsg(interp, "forward: %1 must by a valid list, given: '", - ObjStr(o), "'", (char *) NULL); + if (Tcl_ListObjIndex(interp, forwardArgObj, 1, &list) != TCL_OK) { + return XOTclVarErrMsg(interp, "forward: %1 must be followed by a valid list, given: '", + ObjStr(forwardArgObj), "'", (char *) NULL); } if (Tcl_ListObjGetElements(interp, list, &nrElements, &listElements) != TCL_OK) { return XOTclVarErrMsg(interp, "forward: %1 contains invalid list '", ObjStr(list), "'", (char *) NULL); } } else if (tcd->subcommands) { /* deprecated part */ - if (Tcl_ListObjGetElements(interp, tcd->subcommands,&nrElements,&listElements) != TCL_OK) { + if (Tcl_ListObjGetElements(interp, tcd->subcommands, &nrElements, &listElements) != TCL_OK) { return XOTclVarErrMsg(interp, "forward: %1 contains invalid list '", ObjStr(list), "'", (char *) NULL); } } + /*fprintf(stderr, "nrElements=%d, nra=%d firstPos %d objc %d\n", + nrElements ,nrArgs, firstPosArg, objc);*/ + if (nrElements > nrArgs) { /* insert default subcommand depending on number of arguments */ + /*fprintf(stderr, "inserting listElements[%d] '%s'\n", nrArgs, ObjStr(listElements[nrArgs]));*/ *out = listElements[nrArgs]; } else if (objc<=1) { return XOTclObjErrArgCnt(interp, objv[0], NULL, "option"); } else { - *out = objv[1]; - *inputarg = 2; + /*fprintf(stderr, "copying %%1: '%s'\n",ObjStr(objv[firstPosArg]));*/ + *out = objv[firstPosArg]; + *inputArg = firstPosArg+1; } - } else if (c == 'a' && !strncmp(element, "argcl", 4)) { - if (Tcl_ListObjIndex(interp, o, 1, &list) != TCL_OK) { + } else if (c == '-') { + char *firstElementString; + int i, insertRequired, done = 0; + + /*fprintf(stderr, "process flag '%s'\n",firstActualArgument);*/ + if (Tcl_ListObjGetElements(interp, forwardArgObj, &nrElements, &listElements) != TCL_OK) { + return XOTclVarErrMsg(interp, "forward: '", forwardArgString, "' is not a valid list", + (char *) NULL); + } + if (nrElements < 1 || nrElements > 2) { + return XOTclVarErrMsg(interp, "forward: '", forwardArgString, + "' must contain 1 or 2 arguments", + (char *) NULL); + } + firstElementString = ObjStr(listElements[0]); + firstElementString++; /* we skip the dash */ + + if (firstActualArgument && *firstActualArgument == '-') { + /*fprintf(stderr, "we have a flag in first argument '%s'\n",firstActualArgument);*/ + + for (i = 1; i < firstPosArg; i++) { + if (strcmp(firstElementString, ObjStr(objv[i])) == 0) { + fprintf(stderr, "We have a MATCH for '%s' oldInputArg %d\n", forwardArgString, *inputArg); + *out = objv[i]; + /* %1 will start at a different place. Proceed if necessary to firstPosArg */ + if (*inputArg < firstPosArg) { + *inputArg = firstPosArg; + } + done = 1; + break; + } + } + } + + if (!done) { + /* We have a flag in the actual arguments that does not match. + * We proceed to the actual arguments without dashes. + */ + if (*inputArg < firstPosArg) { + *inputArg = firstPosArg; + } + /* + * If the user requested we output the argument also when not + * given in the argument list. + */ + if (nrElements == 2 + && Tcl_GetIntFromObj(interp, listElements[1], &insertRequired) == TCL_OK + && insertRequired) { + /* no match, but insert of flag is required */ + fprintf(stderr, "no match, but insert of %s required\n", firstElementString); + *out = Tcl_NewStringObj(firstElementString,-1); + *outputincr = 1; + goto add_to_freelist; + } else { + /* no match, no insert of flag required, we skip the + * forwarder option and output nothing + */ + fprintf(stderr, "no match, nrElements %d insert req %d\n", nrElements, insertRequired); + *outputincr = 0; + } + } + + } else if (c == 'a' && !strncmp(forwardArgString, "argcl", 4)) { + if (Tcl_ListObjIndex(interp, forwardArgObj, 1, &list) != TCL_OK) { return XOTclVarErrMsg(interp, "forward: %argclindex must by a valid list, given: '", - element, "'", (char *) NULL); + forwardArgString, "'", (char *) NULL); } if (Tcl_ListObjGetElements(interp, list, &nrElements, &listElements) != TCL_OK) { return XOTclVarErrMsg(interp, "forward: %argclindex contains invalid list '", ObjStr(list), "'", (char *) NULL); } if (nrArgs >= nrElements) { return XOTclVarErrMsg(interp, "forward: not enough elements in specified list of ARGC argument ", - element, (char *) NULL); + forwardArgString, (char *) NULL); } *out = listElements[nrArgs]; } else if (c == '%') { - Tcl_Obj *newarg = Tcl_NewStringObj(element,-1); + Tcl_Obj *newarg = Tcl_NewStringObj(forwardArgString,-1); *out = newarg; goto add_to_freelist; } else { /* evaluating given command */ int result; - /*fprintf(stderr, "evaluating '%s'\n", element);*/ - if ((result = Tcl_EvalEx(interp, element, -1, 0)) != TCL_OK) + /*fprintf(stderr, "evaluating '%s'\n", forwardArgString);*/ + if ((result = Tcl_EvalEx(interp, forwardArgString, -1, 0)) != TCL_OK) return result; *out = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); /*fprintf(stderr, "result = '%s'\n", ObjStr(*out));*/ goto add_to_freelist; } } else { - if (p == element) - *out = o; + if (p == forwardArgString) + *out = forwardArgObj; else { - Tcl_Obj *newarg = Tcl_NewStringObj(element,-1); + Tcl_Obj *newarg = Tcl_NewStringObj(forwardArgString,-1); *out = newarg; goto add_to_freelist; } @@ -8579,7 +8679,7 @@ XOTclForwardMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { forwardCmdClientData *tcd = (forwardCmdClientData *)clientData; - int result, j, inputarg = 1, outputarg = 0; + int result, j, inputArg = 1, outputArg = 0; #if defined(TCL85STACK) /* no need to store varFramePtr in call frame for tcl85stack */ #else @@ -8607,7 +8707,7 @@ return result; } else { Tcl_Obj **ov, *freeList=NULL; - int totalargs = objc + tcd->nr_args + 3; + int outputincr, firstPosArg=1, totalargs = objc + tcd->nr_args + 3; ALLOC_ON_STACK(Tcl_Obj*, totalargs, OV); ALLOC_ON_STACK(int, totalargs, objvmap); /*fprintf(stderr, "+++ forwardMethod standard case, allocated %d args\n",totalargs);*/ @@ -8618,24 +8718,36 @@ } /* the first argument is always the command, to which we forward */ - if ((result = forwardArg(interp, objc, objv, tcd->cmdName, tcd, - &ov[outputarg], &freeList, &inputarg, - &objvmap[outputarg])) != TCL_OK) { + &ov[outputArg], &freeList, &inputArg, + &objvmap[outputArg], + firstPosArg, &outputincr)) != TCL_OK) { goto exitforwardmethod; } - outputarg++; + outputArg += outputincr; + /* if we have nonpos args, determine the first pos arg position for %1 */ + if (tcd->hasNonposArgs) { + for (j=outputArg; jargs) { /* copy argument list from definition */ Tcl_Obj **listElements; int nrElements; Tcl_ListObjGetElements(interp, tcd->args, &nrElements, &listElements); - for (j=0; jnr_subcommands=%d size=%d\n", objc, tcd->nr_subcommands, objc+ 2 );*/ - if (objc-inputarg>0) { + if (objc-inputArg>0) { /*fprintf(stderr, " copying remaining %d args starting at [%d]\n", - objc-inputarg, outputarg);*/ - memcpy(ov+outputarg, objv+inputarg, sizeof(Tcl_Obj *)*(objc-inputarg)); + objc-inputArg, outputArg);*/ + memcpy(ov+outputArg, objv+inputArg, sizeof(Tcl_Obj *)*(objc-inputArg)); } else { - /*fprintf(stderr, " nothing to copy, objc=%d, inputarg=%d\n", objc, inputarg);*/ + /*fprintf(stderr, " nothing to copy, objc=%d, inputArg=%d\n", objc, inputArg);*/ } if (tcd->needobjmap) { /* we have to set the adressing relative from the end; -2 means last, -3 element before last, etc. */ - int max = objc + tcd->nr_args - inputarg; + int max = objc + tcd->nr_args - inputArg; for (j=0; j is deprecated.\n", oldCmd); - if (newCmd) - fprintf(stderr, "** Use <%s> instead.\n", newCmd); - fprintf(stderr, "**\n"); - return TCL_OK; -} - static int XOTclDispatchCmd(Tcl_Interp *interp, XOTclObject *object, int withObjscope, Tcl_Obj *command, int nobjc, Tcl_Obj *CONST nobjv[]) { @@ -10921,8 +11020,8 @@ XOTclClassOpt *clopt = NULL, *nclopt = NULL; int i; - fprintf(stderr, "XOTclRelationCmd %s %d rel=%d val='%s'\n", - objectName(object),withPer_object,relationtype,value?ObjStr(value):"NULL"); + /*fprintf(stderr, "XOTclRelationCmd %s %d rel=%d val='%s'\n", + objectName(object),withPer_object,relationtype,value?ObjStr(value):"NULL");*/ if (withPer_object) { switch (relationtype) { @@ -12545,8 +12644,6 @@ static int XOTclObjInfoMixinMethod(Tcl_Interp *interp, XOTclObject *object, int withGuards, int withOrder, char *patternString, XOTclObject *patternObj) { - fprintf(stderr, "XOTclObjInfoMixinMethod'\n"); - if (withOrder) { if (!(object->flags & XOTCL_MIXIN_ORDER_VALID)) MixinComputeDefined(interp, object); Index: tests/slottest.xotcl =================================================================== diff -u -r8f79347327f3c5f73faf86e87ebd6c8306265fbb -r477c12e1b0f192ab18de415e30001ea151d7ddda --- tests/slottest.xotcl (.../slottest.xotcl) (revision 8f79347327f3c5f73faf86e87ebd6c8306265fbb) +++ tests/slottest.xotcl (.../slottest.xotcl) (revision 477c12e1b0f192ab18de415e30001ea151d7ddda) @@ -259,10 +259,8 @@ # } # } +::xotcl::Attribute mixin delete ::xotcl::Slot::Optimizer -#::xotcl::Slot instmixin delete ::xotcl::Slot::Optimizer -::xotcl::Attribute instmixin delete ::xotcl::Slot::Optimizer - Class C1 -parameter {a {b 10} {c "Hello World"}} C1 c1 -a 1 ? {c1 a} 1 @@ -287,7 +285,8 @@ t {c2 a} 1 "new indirect parametercmd" t {c2 a 1} 1 "new indirect parametercmd" -::xotcl::Slot instmixin add ::xotcl::Slot::Optimizer +::xotcl::Slot mixin add ::xotcl::Slot::Optimizer + Class C3 -slots { Attribute create a Attribute create b -default 10