Index: generic/predefined.h =================================================================== diff -u -r5556c6d63ea6f4d90705386490253530f0272b57 -r0f1d08f0090b3cb676b82f049bae6fe354d331ff --- generic/predefined.h (.../predefined.h) (revision 5556c6d63ea6f4d90705386490253530f0272b57) +++ generic/predefined.h (.../predefined.h) (revision 0f1d08f0090b3cb676b82f049bae6fe354d331ff) @@ -114,7 +114,6 @@ "foreach i [$class info instances] {\n" "if {![$i exists $att]} {::xotcl::setinstvar $i $att $default}}\n" "unset default}}\n" -"puts stderr \"Bootstrapslot for $class calls invalidateobjectparameter\"\n" "$class invalidateobjectparameter}\n" "createBootstrapAttributeSlots ::xotcl::Class {\n" "{__default_superclass ::xotcl::Object}\n" @@ -150,13 +149,11 @@ "lappend methods $m}\n" "error \"Method '$method' unknown for slot [::xotcl::self]; valid are: {[lsort $methods]]}\"}\n" "::xotcl::Slot instproc init {} {\n" -"::xotcl::my instvar name domain manager per-object\n" +"::xotcl::instvar name domain manager per-object\n" "set forwarder [expr {${per-object} ? \"forward\" : \"instforward\"}]\n" "if {$domain eq \"\"} {\n" "set domain [::xotcl::self callingobject]} else {\n" -"puts stderr \"Slot [self] (name $name) init $domain calls invalidateobjectparameter\"\n" -"$domain invalidateobjectparameter\n" -"[my info class] invalidateobjectparameter}\n" +"$domain invalidateobjectparameter}\n" "$domain $forwarder $name -default [$manager defaultmethods] $manager %1 %self %proc}\n" "::xotcl::MetaSlot create ::xotcl::InfoSlot\n" "createBootstrapAttributeSlots ::xotcl::InfoSlot {\n" Index: generic/predefined.xotcl =================================================================== diff -u -r5556c6d63ea6f4d90705386490253530f0272b57 -r0f1d08f0090b3cb676b82f049bae6fe354d331ff --- generic/predefined.xotcl (.../predefined.xotcl) (revision 5556c6d63ea6f4d90705386490253530f0272b57) +++ generic/predefined.xotcl (.../predefined.xotcl) (revision 0f1d08f0090b3cb676b82f049bae6fe354d331ff) @@ -263,7 +263,7 @@ unset default } } - puts stderr "Bootstrapslot for $class calls invalidateobjectparameter" + #puts stderr "Bootstrapslot for $class calls invalidateobjectparameter" $class invalidateobjectparameter } @@ -326,16 +326,26 @@ } error "Method '$method' unknown for slot [::xotcl::self]; valid are: {[lsort $methods]]}" } + + # TODO crashes currently + #::xotcl::Slot instproc destroy {} { + # ::xotcl::instvar domain + # if {$domain ne ""} { + # $domain invalidateobjectparameter + # } + # next + #} + ::xotcl::Slot instproc init {} { - ::xotcl::my instvar name domain manager per-object + ::xotcl::instvar name domain manager per-object #puts stderr "slot init [self] exists name? [info exists name] '$name'" set forwarder [expr {${per-object} ? "forward" : "instforward"}] #puts "domain=$domain /[::xotcl::self callingobject]/[::xotcl::my info parent]" if {$domain eq ""} { set domain [::xotcl::self callingobject] } else { #todo could be done via slotoptimizer - puts stderr "Slot [self] (name $name) init $domain calls invalidateobjectparameter" + #puts stderr "Slot [self] (name $name) init $domain calls invalidateobjectparameter" $domain invalidateobjectparameter # TODO: the following line should not be here. It is necessary to handle currently # computed default values, such as @@ -345,7 +355,7 @@ # - define a new converter type and delay for set value # - invent some non-caching (not preferable). # - [my info class] invalidateobjectparameter + #[my info class] invalidateobjectparameter } #puts stderr "???? $domain $forwarder $name -default [$manager defaultmethods] $manager %1 %self %proc" $domain $forwarder $name -default [$manager defaultmethods] $manager %1 %self %proc Index: generic/xotcl.c =================================================================== diff -u -rfd885cf0c5e9db40afffb54a2a7e2e3d714a8a14 -r0f1d08f0090b3cb676b82f049bae6fe354d331ff --- generic/xotcl.c (.../xotcl.c) (revision fd885cf0c5e9db40afffb54a2a7e2e3d714a8a14) +++ generic/xotcl.c (.../xotcl.c) (revision 0f1d08f0090b3cb676b82f049bae6fe354d331ff) @@ -143,7 +143,7 @@ ClientData clientData; } aliasCmdClientData; -#define PARSE_CONTEXT_PREALLOC 40 +#define PARSE_CONTEXT_PREALLOC 20 typedef struct { ClientData *clientData; Tcl_Obj **objv; @@ -181,24 +181,52 @@ memset(pc->full_objv, 0, sizeof(Tcl_Obj*)*(objc+1)); memset(pc->flags, 0, sizeof(int)*(objc+1)); memset(pc->clientData, 0, sizeof(ClientData)*(objc)); - } pc->objv = &pc->full_objv[1]; pc->full_objv[0] = procName; } +void parseContextExtendObjv(parseContext *pc, int from, int elts, Tcl_Obj *CONST source[]) { + int requiredSize = from + elts; + + /* XOTclPrintObjv("BEFORE: ", pc->objc, pc->full_objv); */ + + if (requiredSize > PARSE_CONTEXT_PREALLOC) { + if (pc->objv == &pc->objv_static[1]) { + /* realloc from preallocated memory */ + fprintf(stderr, "alloc %d\n", requiredSize); + pc->full_objv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*) * (requiredSize+1)); + memcpy(pc->full_objv, &pc->objv_static[0], sizeof(Tcl_Obj*) * PARSE_CONTEXT_PREALLOC); + } else { + /* realloc from mallocated memory */ + pc->full_objv = (Tcl_Obj **)ckrealloc((char *)pc->full_objv, sizeof(Tcl_Obj*) * (requiredSize)); + fprintf(stderr, "realloc %d\n", requiredSize); + } + pc->objv = &pc->full_objv[1]; + } + + memcpy(pc->objv + from, source, sizeof(Tcl_Obj *) * (elts)); + pc->objc += elts; + + /* XOTclPrintObjv("AFTER: ", pc->objc, pc->full_objv); */ +} + void parseContextRelease(parseContext *pc) { if (pc->mustDecr) { int i; - for (i = 0; i < pc->objc; i++) { + for (i = 0; i < pc->lastobjc; i++) { if (pc->flags[i] & XOTCL_PC_MUST_DECR) { DECR_REF_COUNT(pc->objv[i]); } } } + /* objv can be separately extended */ if (pc->objv != &pc->objv_static[1]) { /*fprintf(stderr,"release free %p %p\n",pc->full_objv,pc->clientData);*/ ckfree((char *)pc->full_objv); + } + /* if the interface was extended, both clientData and flags are extended */ + if (pc->clientData != &pc->clientData_static[0]) { ckfree((char *)pc->clientData); ckfree((char *)pc->flags); } @@ -4973,7 +5001,7 @@ result = ProcessMethodArguments(&pc, interp, obj, nonposArgs, methodName, objc, objv); /* TODO: check potential leak for */ if (result == TCL_OK) { - result = PushProcCallFrame(cp, interp, pc.objc+1, pc.full_objv, csc); + result = PushProcCallFrame(cp, interp, pc.objc, pc.full_objv, csc); /* maybe release is to early */ parseContextRelease(&pc); } @@ -9126,7 +9154,7 @@ } } pc->lastobjc = aPtr->name ? o : o-1; - pc->objc = i; + pc->objc = i + 1; /* Process all args until end of interface to get correct counters */ while (aPtr->name) { @@ -10156,10 +10184,10 @@ /* * STEP 3: stage the object under initialisation/ construction; using: - * pc.objc+1, pc.full_objv + * pc.objc, pc.full_objv */ #if defined(CONFIGURE_ARGS_TRACE) - fprintf(stderr, "*** POPULATE OBJ ''''%s'''': nr of parsed args '%d'\n",objectName(obj),pc.objc); + fprintf(stderr, "*** POPULATE OBJ ''''%s'''': nr of parsed args '%d'\n", objectName(obj), pc.objc); #endif for (i = 1, ifPtr = nonposArgs->ifd; i < nonposArgs->ifdSize; i++, ifPtr++) { char *argName = ifPtr->name; @@ -10214,13 +10242,13 @@ } XOTcl_PopFrame(interp, obj); - remainingArgsc = pc.objc - (nonposArgs->ifdSize - 1); + remainingArgsc = pc.objc - nonposArgs->ifdSize; -#if defined(CONFIGURE_ARGS_TRACE) +#if 0 || defined(CONFIGURE_ARGS_TRACE) fprintf(stderr, "*** POPULATE OBJ SETVALUES with '%d' elements:\n", remainingArgsc); { int j; for (j = i; j < i + remainingArgsc; j++) { - fprintf(stderr, "*** SETVALUES[%d] with '%s'\n",j,ObjStr(pc.full_objv[j])); + fprintf(stderr, "*** SETVALUES[%d] with '%s'\n", j, pc.full_objv[j] ? ObjStr(pc.full_objv[j]) : "NULL"); } } #endif @@ -12097,7 +12125,7 @@ char *methodName, int objc, Tcl_Obj *CONST objv[]) { argDefinition CONST *aPtr; int i, rc; - + rc = parseObjv(interp, objc, objv, objv[0], nonposArgs->ifd, nonposArgs->ifdSize, pcPtr); if (rc != TCL_OK) { return rc; @@ -12169,63 +12197,39 @@ * Set objc of the parse context to the size of the interface. * pcPtr->objc and nonposArgs->ifdSize will be equivalent in cases * where argument values are passed to the call in absence of var - * args ('args'). However, there are important points of deviation - * which need to be handled, e.g.: - * - * 1) No argument values have been passed and defaults are provided - * and initialised by parseObjv. objc will then not reflect the - * required ifdSize. - * - * 2) Var args have been enabled (=specified) but there are either - * no args values provided in the call or there are more than 1 - * var args (see below). + * args ('args'). Treating "args is more involved. */ - pcPtr->objc = nonposArgs->ifdSize; + pcPtr->objc = nonposArgs->ifdSize + 1; if (aPtr->converter == convertToNothing) { - /* - * Var args ('args') are expected. + /* + * The last argument was "args". + */ + int elts = objc - pcPtr->lastobjc; + + if (elts == 0) { + /* + * No arguments were passed to "args". We simply decrement objc. */ - int elts = objc - pcPtr->lastobjc; + pcPtr->objc--; + } else if (elts > 1) { /* - * 1) elts = 0: 'args' is specified, but there are no var args - * passed in the call. At this point, pcPtr->objv[i] has the - * value XOTclGlobalObjects[XOTE___UNKNOWN__] (see - * above). However, tclProc.c:InitArgsAndLocals initialises an - * empty list for 'args' because pcPtr->objc does not reflect - * the __unknown__ value. The work is so effectively - * delegated. Note that unsetUnknownArgs is not involved, as the - * __unknown__ value is not to make it through - * tclProc.c:InitArgsAndLocals - * + * Multiple arguments were passed to "args". pcPtr->objv is + * pointing to the first of the var args. We have to copy the + * remaining actual argument vector objv to the parse context. */ - if (elts == 0) { - pcPtr->objc--; - } - + + /*XOTclPrintObjv("actual: ", objc, objv);*/ + parseContextExtendObjv(pcPtr, nonposArgs->ifdSize, elts-1, objv + 1 + pcPtr->lastobjc); + } else { /* - * 2) elts = 1: 'args' is specified, and a single var arg was - * passed. there is no need to mutate the pcPtr->objv, because - * this has been achieved in parseObjvs (i.e., pcPtr->objv[i] - * contains this element). We can so avoid a memcpy operation. + * A single argument was passed to "args". There is no need to + * mutate the pcPtr->objv, because this has been achieved in + * parseObjvs (i.e., pcPtr->objv[i] contains this element). */ + } + } - /* 3) elts > 1: 'args' is specified and more than a single var - * args were passed. subsequently, pcPtr->objv is only pointing - * to the first of the var args. First, copy the sublist of var - * args to pcPtr->objv, second correct pcPtr->objc. The - * corrected pcPtr->objc will ascertain that - * tclProc.c:InitArgsAndLocals will set up a list of the - * appropriate size and content. There is no need to deal with a - * list representation for 'args' at this point. - */ - if (elts > 1) { - /* TODO: this cannot stay like this */ - memcpy(pcPtr->objv+i, objv+pcPtr->lastobjc, sizeof(Tcl_Obj *)*elts); - pcPtr->objc = pcPtr->objc + elts - 1; - } - } - return TCL_OK; } Index: generic/xotclTrace.c =================================================================== diff -u -r7cb7c751d63fe0eece5756910e3f0b18e61a4d16 -r0f1d08f0090b3cb676b82f049bae6fe354d331ff --- generic/xotclTrace.c (.../xotclTrace.c) (revision 7cb7c751d63fe0eece5756910e3f0b18e61a4d16) +++ generic/xotclTrace.c (.../xotclTrace.c) (revision 0f1d08f0090b3cb676b82f049bae6fe354d331ff) @@ -143,6 +143,16 @@ return XOTclVarErrMsg(interp, "xotcltrace: unknown option", (char*) NULL); } +void +XOTclPrintObjv(char *string, int objc, Tcl_Obj *CONST objv[]) { + int j; + fprintf(stderr, string); + for (j = 0; j < objc; j++) { + fprintf(stderr, " objv[%d]=%s, ",j, objv[j] ? ObjStr(objv[j]) : "NULL"); + } + fprintf(stderr, "\n"); +} + #ifdef XOTCL_MEM_COUNT void XOTclMemCountAlloc(char *id, void *p) {