Index: generic/xotcl.c =================================================================== diff -u -rde505f4134eb384a34270081e0889818577ef4ef -r57fe47fb1da11243f88679d61d3b3b172258525a --- generic/xotcl.c (.../xotcl.c) (revision de505f4134eb384a34270081e0889818577ef4ef) +++ generic/xotcl.c (.../xotcl.c) (revision 57fe47fb1da11243f88679d61d3b3b172258525a) @@ -153,6 +153,7 @@ ClientData clientData[10]; Tcl_Obj *objv[10]; int lastobjc; + int objc; } parseContext; typedef argDefinition interfaceDefinition[10]; @@ -5416,7 +5417,38 @@ #if !defined(PRE85) /*fprintf(stderr,"\tproc=%s cp=%p %d\n", Tcl_GetCommandName(interp, cmd),cp, isTclProc);*/ +# if defined(CANONICAL_ARGS) + { + parseContext pc; + int rc; + Tcl_Obj *ov[100]; /* TODO: maybe make me dynamic, or better, put procName on ov[0] in pc */ + + rc = canonicalNonpositionalArgs(&pc, interp, objc, objv); + + if (rc == TCL_CONTINUE) { + result = PushProcCallFrame(cp, interp, objc, objv, /*isLambda*/ 0); + } else { + int i, j; + ov[0] = objv[0]; + for (i=0, j=1; i < pc.objc+1; i++) { + if (pc.objv[i]) { + ov[j++] = pc.objv[i]; + } + } + /*fprintf(stderr, "pc.objc = %d provided objc %d\n",pc.objc+1,objc);*/ +#if 0 + for(j=0; jcs.top->currentFramePtr = (Tcl_CallFrame *) Tcl_Interp_varFramePtr(interp); @@ -5896,9 +5928,11 @@ Tcl_AppendStringsToObj(resultBody, "::eval ::xotcl::interpretNonpositionalArgs $args\n", (char *) NULL); #else +# if !defined(CANONICAL_ARGS) if (nonposArgs) Tcl_AppendStringsToObj(resultBody, "::xotcl::interpretNonpositionalArgs {*}$args\n", (char *) NULL); +# endif #endif Tcl_AppendStringsToObj(resultBody, ObjStr(body), (char *) NULL); return resultBody; @@ -6146,7 +6180,7 @@ static int parseNonposArgs(Tcl_Interp *interp, char *procName, Tcl_Obj *npArgs, Tcl_Obj *ordinaryArgs, - Tcl_HashTable **nonposArgsTable, int *haveNonposArgs) { + Tcl_HashTable **nonposArgsTable, int *haveNonposArgs, argDefinition **parsedIfPtr) { int rc, i, nonposArgsDefc, ordinaryArgsDefc; Tcl_Obj **nonposArgsDefv, **ordinaryArgsDefv; argDefinition *interface, *ifPtr; @@ -6204,6 +6238,7 @@ nonposArg = (XOTclNonposArgs*)ckalloc(sizeof(XOTclNonposArgs)); nonposArg->slotObj = NULL; nonposArg->ifd = interface; + *parsedIfPtr = interface; /* TODO only for CANONICAL_ARGS */ Tcl_SetHashValue(hPtr, (ClientData)nonposArg); } else { @@ -6223,6 +6258,7 @@ Tcl_Obj *ov[4], **argsv; Tcl_HashEntry *hPtr = NULL; char *procName = ObjStr(name); + argDefinition *parsedIfPtr; if (*nonposArgsTable && (hPtr = XOTcl_FindHashEntry(*nonposArgsTable, procName))) { NonposArgsDeleteHashEntry(hPtr); @@ -6260,15 +6296,30 @@ INCR_REF_COUNT(ordinaryArgs); INCR_REF_COUNT(nonposArgs); result = parseNonposArgs(interp, procName, nonposArgs, ordinaryArgs, - nonposArgsTable, &haveNonposArgs); + nonposArgsTable, &haveNonposArgs, &parsedIfPtr); DECR_REF_COUNT(ordinaryArgs); DECR_REF_COUNT(nonposArgs); if (result != TCL_OK) return result; } if (haveNonposArgs) { +# if defined(CANONICAL_ARGS) + argDefinition *aPtr; + Tcl_Obj *argList = Tcl_NewListObj(0, NULL); + for (aPtr = parsedIfPtr; aPtr->name; aPtr++) { + if (*aPtr->name == '-') { + Tcl_ListObjAppendElement(interp, argList, Tcl_NewStringObj(aPtr->name+1,-1)); + } else { + Tcl_ListObjAppendElement(interp, argList, Tcl_NewStringObj(aPtr->name,-1)); + } + } + ov[2] = argList; + fprintf(stderr, "final arglist = <%s>\n",ObjStr(argList)); + /* TODO: check for memleak of argList */ +#else ov[2] = XOTclGlobalObjects[XOTE_ARGS]; +#endif ov[3] = addPrefixToBody(body, 1); } else { /* no nonpos arguments */ ov[2] = args; @@ -8770,8 +8821,10 @@ 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)) { - pos = totalargs; + pos = -1; remainder += 3; + } else if (pos < 0) { + pos --; } if (element == remainder || abs(pos) > totalargs) { return XOTclVarErrMsg(interp, "forward: invalid index specified in argument ", @@ -8782,7 +8835,8 @@ } element = ++remainder; - if (pos<0) pos = totalargs + pos; + /* 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; @@ -8801,7 +8855,7 @@ *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);*/ + 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: '", @@ -8949,14 +9003,15 @@ int totalargs = objc + tcd->nr_args + 3; ALLOC_ON_STACK(Tcl_Obj*, totalargs, OV); ALLOC_ON_STACK(int, totalargs, objvmap); - /*fprintf(stderr,"+++ forwardMethod standard case \n");*/ + /*fprintf(stderr,"+++ forwardMethod standard case, allocated %d args\n",totalargs);*/ ov = &OV[1]; if (tcd->needobjmap) { memset(objvmap, -1, sizeof(int)*totalargs); } #if 0 + memset(objvmap, -1, sizeof(int)*totalargs); fprintf(stderr,"command %s (%p) objc=%d, subcommand=%d, args=%p, nrargs\n", ObjStr(objv[0]), tcd, objc, tcd->nr_subcommands, @@ -8987,8 +9042,8 @@ } } } - /* - fprintf(stderr, "objc=%d, tcd->nr_subcommands=%d size=%d\n", + + /*fprintf(stderr, "objc=%d, tcd->nr_subcommands=%d size=%d\n", objc, tcd->nr_subcommands, objc+ 2 );*/ if (objc-inputarg>0) { @@ -8998,17 +9053,30 @@ } else { /*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; + for (j=0; jneedobjmap) + if (tcd->needobjmap) { + for (j=0; j %s\n", pos, ObjStr(tmp)); */ + /*fprintf(stderr,"...setting at %d -> %s\n", pos, ObjStr(tmp));*/ ov[pos] = tmp; objvmap[pos] = -1; } + } if (tcd->prefix) { /* prepend a prefix for the subcommands to avoid name clashes */ @@ -9044,7 +9113,7 @@ #if 0 for(j=0; jlastobjc = aPtr->name ? o : o-1; + pc->objc = i; /* Process to end of interface;*/ while (aPtr->name) { @@ -12305,7 +12375,79 @@ } #endif +#if defined(CANONICAL_ARGS) int +canonicalNonpositionalArgs(parseContext *pcPtr, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *object = GetSelfObj(interp); + XOTclClass *class = GetSelfClass(interp); + Tcl_HashTable *nonposArgsTable = class ? class->nonposArgsTable : object->nonposArgsTable; + char *procName = (char *)GetSelfProc(interp); + XOTclNonposArgs *nonposArgs = NonposArgsGet(nonposArgsTable, procName); + Tcl_Obj *proc; + argDefinition CONST *aPtr; + parseContext pc; + int i, rc; + + if (!nonposArgs) {return TCL_CONTINUE;} + + proc = Tcl_NewStringObj(procName, -1); + INCR_REF_COUNT(proc); + rc = parseObjv(interp, objc, objv, proc, nonposArgs->ifd, pcPtr); + DECR_REF_COUNT(proc); + + if (rc != TCL_OK) + return rc; + + for (aPtr = nonposArgs->ifd, i=0; aPtr->name; aPtr++, i++) { + char *argName = aPtr->name; + if (*argName == '-') argName++; + /*fprintf(stderr, "got for arg %s (%d) => %p %p, default %s\n", + aPtr->name, aPtr->required, + pcPtr->clientData[i], pcPtr->objv[i], + aPtr->defaultValue ? ObjStr(aPtr->defaultValue) : "NONE");*/ + + if (pcPtr->objv[i]) { + /* got a value, already checked by objv parser */ + /*fprintf(stderr, "setting passed value for %s to '%s'\n",argName,ObjStr(pcPtr->objv[i]));*/ + if (aPtr->converter == convertToSwitch) { + int bool; + Tcl_GetBooleanFromObj(interp, aPtr->defaultValue, &bool); + pcPtr->objv[i] = Tcl_NewBooleanObj(!bool); /* TODO check for leak? */ + } + } else { + /* no valued passed, check if default is available */ + if (aPtr->defaultValue) { + pcPtr->objv[i] = aPtr->defaultValue; + /* TODO: default value is not jet checked; should be in arg parsing */ + /*fprintf(stderr,"=== setting default value '%s' for var '%s'\n",ObjStr(aPtr->defaultValue),argName);*/ + } else if (aPtr->required) { + return XOTclVarErrMsg(interp, "method ",procName, ": required argument '", + argName, "' is missing", (char *) NULL); + } else { + /* we will have to unset later */ + /* XXX */ + pcPtr->objv[i] = XOTclGlobalObjects[XOTE___UNKNOWN]; /* TODO other symbol ? */ + } + } + } + + aPtr--; + /* TODO handle "args" */ + if (aPtr->converter == convertToNothing) { + /* "args" is always defined as non-required and with convertToNoting */ + int elts = objc - pcPtr->lastobjc; + /*fprintf(stderr, "args last objc=%d, objc=%d, elts=%d\n", pc.lastobjc, objc, elts);*/ + /*Tcl_SetVar2Ex(interp, aPtr->name, NULL, Tcl_NewListObj(elts,objv+pc.lastobjc), 0);*/ + } else { + /* Tcl_UnsetVar2(interp, "args", NULL, 0); */ + } + + return TCL_OK; +} + +#else + +int XOTclInterpretNonpositionalArgsCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { XOTclObject *object = GetSelfObj(interp); @@ -12376,8 +12518,8 @@ return TCL_OK; } +#endif - /* create a slave interp that calls XOTcl Init */ static int XOTcl_InterpObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { @@ -13026,8 +13168,10 @@ #endif Tcl_CreateObjCommand(interp, "::xotcl::initProcNS", XOTclInitProcNSCmd, 0, 0); #endif +#if !defined(CANONICAL_ARGS) Tcl_CreateObjCommand(interp, "::xotcl::interpretNonpositionalArgs", XOTclInterpretNonpositionalArgsCmd, 0, 0); +#endif Tcl_CreateObjCommand(interp, "::xotcl::interp", XOTcl_InterpObjCmd, 0, 0); Tcl_CreateObjCommand(interp, "::xotcl::namespace_copyvars", XOTcl_NSCopyVars, 0, 0); Tcl_CreateObjCommand(interp, "::xotcl::namespace_copycmds", XOTcl_NSCopyCmds, 0, 0); Index: generic/xotcl.h =================================================================== diff -u -recc8a110c338877202b900868da32eb8dcd561ad -r57fe47fb1da11243f88679d61d3b3b172258525a --- generic/xotcl.h (.../xotcl.h) (revision ecc8a110c338877202b900868da32eb8dcd561ad) +++ generic/xotcl.h (.../xotcl.h) (revision 57fe47fb1da11243f88679d61d3b3b172258525a) @@ -82,6 +82,9 @@ #define PARSE_TRACE_FULL 1 */ +/* +#define CANONICAL_ARGS 1 +*/ #if defined PARSE_TRACE_FULL # define PARSE_TRACE 1 Index: library/serialize/Serializer.xotcl =================================================================== diff -u -r321a21cbb0beec854bfc651e167c32ded2707a3a -r57fe47fb1da11243f88679d61d3b3b172258525a --- library/serialize/Serializer.xotcl (.../Serializer.xotcl) (revision 321a21cbb0beec854bfc651e167c32ded2707a3a) +++ library/serialize/Serializer.xotcl (.../Serializer.xotcl) (revision 57fe47fb1da11243f88679d61d3b3b172258525a) @@ -426,7 +426,6 @@ } Serializer instproc deepSerialize o { # assumes $o to be fully qualified -puts stderr CALL-allChildren my serialize-objects [my allChildren $o] 1 } Serializer instproc serializeMethod {object kind name} { Index: tests/forwardtest.xotcl =================================================================== diff -u -rc72f9f638677608fab1502cd696c8f2d6b2952f9 -r57fe47fb1da11243f88679d61d3b3b172258525a --- tests/forwardtest.xotcl (.../forwardtest.xotcl) (revision c72f9f638677608fab1502cd696c8f2d6b2952f9) +++ tests/forwardtest.xotcl (.../forwardtest.xotcl) (revision 57fe47fb1da11243f88679d61d3b3b172258525a) @@ -195,6 +195,25 @@ ? {obj @list} [list x 1 y 2 z] ? {obj @list a b c} [list x 1 y 2 z a b c] +# adding some test cases which cover the interactions +# between %@POS and %1 substitutions +# + +obj forward @end-13 list {%@end 13} %1 %self +? {obj @end-13 1 2 3 } [list 1 ::obj 2 3 13] + +obj forward @end-13 list %1 {%@end 13} %self +? {obj @end-13 1 2 3 } [list 1 ::obj 2 3 13] + +obj forward @end-13 list {%@end 13} %1 %1 %1 %self +? {obj @end-13 1 2 3 } [list 1 1 1 ::obj 2 3 13] + +obj forward @end-13 list {%@-1 13} %1 %self +? {obj @end-13 1 2 3 } [list 1 ::obj 2 13 3] + +obj forward @end-13 list {%@1 13} %1 %self +? {obj @end-13 1 2 3 } [list 13 1 ::obj 2 3] + ############################################### # substitution depending on number of arguments ############################################### @@ -320,4 +339,4 @@ ? {C t ::c1 {[my xx]}} ::c1 ? {C t ::c1 {[my info class]}} ::C ? {C t ::c1 {[my istype C]}} 1 -? {C t ::c1 {[my istype ::C]}} 1 \ No newline at end of file +? {C t ::c1 {[my istype ::C]}} 1