Index: doc/index.html =================================================================== diff -u -r543e283a1681f4e7075eb65a0dd97f54cf48e2f7 -rffd2368a61d1328d71f07ef8b922820bf8263c25 --- doc/index.html (.../index.html) (revision 543e283a1681f4e7075eb65a0dd97f54cf48e2f7) +++ doc/index.html (.../index.html) (revision ffd2368a61d1328d71f07ef8b922820bf8263c25) @@ -23,7 +23,7 @@

Index: generic/gentclAPI.decls =================================================================== diff -u -r543e283a1681f4e7075eb65a0dd97f54cf48e2f7 -rffd2368a61d1328d71f07ef8b922820bf8263c25 --- generic/gentclAPI.decls (.../gentclAPI.decls) (revision 543e283a1681f4e7075eb65a0dd97f54cf48e2f7) +++ generic/gentclAPI.decls (.../gentclAPI.decls) (revision ffd2368a61d1328d71f07ef8b922820bf8263c25) @@ -224,6 +224,8 @@ {-argName "args" -type args} } # todo -protected for XOTclCInstForwardMethod +classMethod invalidateinterfacedefinition XOTclCInvalidateInterfaceDefinitionMethod { +} classMethod recreate XOTclCRecreateMethod { {-argName "name" -required 1 -type tclobj} {-argName "args" -type allargs} Index: generic/predefined.h =================================================================== diff -u -r543e283a1681f4e7075eb65a0dd97f54cf48e2f7 -rffd2368a61d1328d71f07ef8b922820bf8263c25 --- generic/predefined.h (.../predefined.h) (revision 543e283a1681f4e7075eb65a0dd97f54cf48e2f7) +++ generic/predefined.h (.../predefined.h) (revision ffd2368a61d1328d71f07ef8b922820bf8263c25) @@ -87,9 +87,10 @@ "if {[llength $att]>1} {foreach {att default} $att break}\n" "if {[info exists default]} {\n" "foreach i [$class info instances] {\n" -"if {![$i exists $att]} {::xotcl::setinstvar $i $att $default}\n" -"$i configure}\n" -"unset default}}}\n" +"if {![$i exists $att]} {::xotcl::setinstvar $i $att $default}}\n" +"unset default}}\n" +"puts stderr \"Bootstrapslot for $class calls invalidateinterfacedefinition\"\n" +"$class invalidateinterfacedefinition}\n" "::xotcl::Object instproc configureargs {} {\n" "set arg_list [list]\n" "foreach slot [my info slotobjects] {\n" @@ -143,7 +144,10 @@ "::xotcl::my instvar name domain manager per-object\n" "set forwarder [expr {${per-object} ? \"forward\" : \"instforward\"}]\n" "if {$domain eq \"\"} {\n" -"set domain [::xotcl::self callingobject]}\n" +"set domain [::xotcl::self callingobject]} else {\n" +"puts stderr \"Slot [self] (name $name) init $domain calls invalidateinterfacedefinition\"\n" +"$domain invalidateinterfacedefinition\n" +"[my info class] invalidateinterfacedefinition}\n" "$domain $forwarder $name -default [$manager defaultmethods] $manager %1 %self %proc}\n" "::xotcl::MetaSlot create ::xotcl::InfoSlot\n" "createBootstrapAttributeSlots ::xotcl::InfoSlot {\n" @@ -182,19 +186,19 @@ "namespace eval ::xotcl::Object::slot {}\n" "::xotcl::Object alloc ::xotcl::Class::slot\n" "::xotcl::Object alloc ::xotcl::Object::slot\n" -"::xotcl::InfoSlot create ::xotcl::Class::slot::superclass -type interceptor\n" +"::xotcl::InfoSlot create ::xotcl::Class::slot::superclass -type relation\n" "::xotcl::alias ::xotcl::Class::slot::superclass assign ::xotcl::relation\n" -"::xotcl::InfoSlot create ::xotcl::Object::slot::class -type interceptor\n" +"::xotcl::InfoSlot create ::xotcl::Object::slot::class -type relation\n" "::xotcl::alias ::xotcl::Object::slot::class assign ::xotcl::relation\n" "::xotcl::InterceptorSlot create ::xotcl::Object::slot::mixin \\\n" -"-type interceptor\n" +"-type relation\n" "::xotcl::InterceptorSlot create ::xotcl::Object::slot::filter \\\n" -"-elementtype \"\" -type interceptor\n" +"-elementtype \"\" -type relation\n" "::xotcl::InterceptorSlot create ::xotcl::Class::slot::instmixin \\\n" -"-type interceptor\n" +"-type relation\n" "::xotcl::InterceptorSlot create ::xotcl::Class::slot::instfilter \\\n" "-elementtype \"\" \\\n" -"-type interceptor\n" +"-type relation\n" "::xotcl::MetaSlot create ::xotcl::Attribute -superclass ::xotcl::Slot\n" "createBootstrapAttributeSlots ::xotcl::Attribute {\n" "{value_check once}\n" Index: generic/predefined.xotcl =================================================================== diff -u -r543e283a1681f4e7075eb65a0dd97f54cf48e2f7 -rffd2368a61d1328d71f07ef8b922820bf8263c25 --- generic/predefined.xotcl (.../predefined.xotcl) (revision 543e283a1681f4e7075eb65a0dd97f54cf48e2f7) +++ generic/predefined.xotcl (.../predefined.xotcl) (revision ffd2368a61d1328d71f07ef8b922820bf8263c25) @@ -192,6 +192,7 @@ } $class instparametercmd $att } + # do a second round to ensure that the already defined objects # have the appropriate default values foreach att $definitions { @@ -204,12 +205,14 @@ # # re-run configure to catch slot settings from "configureargs", # such as defaults etc. - # TODO: put this somewhere else?! - $i configure + # TODO: still needed? + #$i configure } unset default } } + puts stderr "Bootstrapslot for $class calls invalidateinterfacedefinition" + $class invalidateinterfacedefinition } # We provide a default value for superclass (when no superclass is specified explicitely) @@ -223,10 +226,12 @@ set arg "-[namespace tail $slot]" set opts [list] # - # the should be a ::xotcl::getinstvar for the bootstrap phase + # there should be a ::xotcl::getinstvar for the bootstrap phase # because InterceptorSlots overload the setter set, leading - # to an issue with the convertToInterceptor converter. + # to an issue with the convertToRelation converter. # + # TODO what's wrong with ::xotcl::setinstvar without a ? + # if {[$slot exists required] && [$slot required]} { lappend opts required } @@ -241,6 +246,7 @@ } lappend arg_list $arg } + # todo: why do we need "args"? temporary solution? lappend arg_list args #puts stderr "*** args spec for [self]: $arg_list" return $arg_list @@ -284,6 +290,7 @@ } else { $obj set $prop [list $value] } + #[::xotcl::my domain] invalidateinterfacedefinition ;# TODO maybe not needed here } ::xotcl::Slot instproc delete {-nocomplain:switch obj prop value} { set old [$obj set $prop] @@ -304,10 +311,24 @@ } ::xotcl::Slot instproc init {} { ::xotcl::my 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 invalidateinterfacedefinition" + $domain invalidateinterfacedefinition + # TODO: the following line should not be here. It is necessary to handle currently + # computed default values, such as + # {name "[namespace tail [::xotcl::self]]"} + # + # Computed defaults could not be cached. Options: + # - define a new converter type and delay for set value + # - invent some non-caching (not preferable). + # + [my info class] invalidateinterfacedefinition } #puts stderr "???? $domain $forwarder $name -default [$manager defaultmethods] $manager %1 %self %proc" $domain $forwarder $name -default [$manager defaultmethods] $manager %1 %self %proc @@ -386,20 +407,20 @@ ::xotcl::Object alloc ::xotcl::Object::slot - ::xotcl::InfoSlot create ::xotcl::Class::slot::superclass -type interceptor + ::xotcl::InfoSlot create ::xotcl::Class::slot::superclass -type relation ::xotcl::alias ::xotcl::Class::slot::superclass assign ::xotcl::relation - ::xotcl::InfoSlot create ::xotcl::Object::slot::class -type interceptor + ::xotcl::InfoSlot create ::xotcl::Object::slot::class -type relation ::xotcl::alias ::xotcl::Object::slot::class assign ::xotcl::relation ::xotcl::InterceptorSlot create ::xotcl::Object::slot::mixin \ - -type interceptor + -type relation ::xotcl::InterceptorSlot create ::xotcl::Object::slot::filter \ - -elementtype "" -type interceptor + -elementtype "" -type relation ::xotcl::InterceptorSlot create ::xotcl::Class::slot::instmixin \ - -type interceptor + -type relation ::xotcl::InterceptorSlot create ::xotcl::Class::slot::instfilter \ -elementtype "" \ - -type interceptor + -type relation # # Attribute @@ -509,6 +530,8 @@ -instproc forward args {::xotcl::next; ::xotcl::my optimize} \ -instproc init args {::xotcl::next; ::xotcl::my optimize} \ -instproc optimize {} { + #puts stderr "slot optimizer for [::xotcl::my domain] calls invalidateinterfacedefinition" + #[::xotcl::my domain] invalidateinterfacedefinition if {[::xotcl::my multivalued]} return if {[::xotcl::my defaultmethods] ne {get assign}} return if {[::xotcl::my procsearch assign] ne "::xotcl::Slot instcmd assign"} return @@ -575,7 +598,6 @@ ::xotcl::Object create [::xotcl::self]::slot } foreach arg $arglist { - #puts "arg=$arg" set l [llength $arg] set name [lindex $arg 0] if {[string first : $name] > -1} { @@ -597,10 +619,10 @@ } if {$l == 1} { eval $cmd - #puts stderr "parameter without default -> $cmd" + #puts stderr "parameter $arg without default -> $cmd" } elseif {$l == 2} { lappend cmd [list -default [lindex $arg 1]] - #puts stderr "parameter with default -> $cmd" + #puts stderr "parameter $arg with default -> $cmd" eval $cmd } elseif {$l == 3 && [lindex $arg 1] eq "-default"} { lappend cmd [list -default [lindex $arg 2]] Index: generic/tclAPI.h =================================================================== diff -u -r543e283a1681f4e7075eb65a0dd97f54cf48e2f7 -rffd2368a61d1328d71f07ef8b922820bf8263c25 --- generic/tclAPI.h (.../tclAPI.h) (revision 543e283a1681f4e7075eb65a0dd97f54cf48e2f7) +++ generic/tclAPI.h (.../tclAPI.h) (revision ffd2368a61d1328d71f07ef8b922820bf8263c25) @@ -53,6 +53,7 @@ static int XOTclCInstParametercmdMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCInstProcMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCInstProcMethodCStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); +static int XOTclCInvalidateInterfaceDefinitionMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCInvariantsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCNewMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCRecreateMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); @@ -155,6 +156,7 @@ static int XOTclCInstParametercmdMethod(Tcl_Interp *interp, XOTclClass *cl, char *name); static int XOTclCInstProcMethod(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, Tcl_Obj *precondition, Tcl_Obj *postcondition); static int XOTclCInstProcMethodC(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, Tcl_Obj *precondition, Tcl_Obj *postcondition); +static int XOTclCInvalidateInterfaceDefinitionMethod(Tcl_Interp *interp, XOTclClass *cl); static int XOTclCInvariantsMethod(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *invariantlist); static int XOTclCNewMethod(Tcl_Interp *interp, XOTclClass *cl, XOTclObject *withChildof, int nobjc, Tcl_Obj *CONST nobjv[]); static int XOTclCRecreateMethod(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *name, int objc, Tcl_Obj *CONST objv[]); @@ -258,6 +260,7 @@ XOTclCInstParametercmdMethodIdx, XOTclCInstProcMethodIdx, XOTclCInstProcMethodCIdx, + XOTclCInvalidateInterfaceDefinitionMethodIdx, XOTclCInvariantsMethodIdx, XOTclCNewMethodIdx, XOTclCRecreateMethodIdx, @@ -578,6 +581,25 @@ } static int +XOTclCInvalidateInterfaceDefinitionMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + parseContext pc; + XOTclClass *cl = XOTclObjectToClass(clientData); + if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); + if (parseObjv(interp, objc, objv, objv[0], + method_definitions[XOTclCInvalidateInterfaceDefinitionMethodIdx].ifd, + method_definitions[XOTclCInvalidateInterfaceDefinitionMethodIdx].ifdSize, + &pc) != TCL_OK) { + return TCL_ERROR; + } else { + + + parseContextRelease(&pc); + return XOTclCInvalidateInterfaceDefinitionMethod(interp, cl); + + } +} + +static int XOTclCInvariantsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; XOTclClass *cl = XOTclObjectToClass(clientData); @@ -2401,6 +2423,9 @@ {"precondition", 0, 0, convertToTclobj}, {"postcondition", 0, 0, convertToTclobj}} }, +{"::xotcl::cmd::Class::invalidateinterfacedefinition", XOTclCInvalidateInterfaceDefinitionMethodStub, 0, { + } +}, {"::xotcl::cmd::Class::instinvar", XOTclCInvariantsMethodStub, 1, { {"invariantlist", 1, 0, convertToTclobj}} }, Index: generic/xotcl.c =================================================================== diff -u -r543e283a1681f4e7075eb65a0dd97f54cf48e2f7 -rffd2368a61d1328d71f07ef8b922820bf8263c25 --- generic/xotcl.c (.../xotcl.c) (revision 543e283a1681f4e7075eb65a0dd97f54cf48e2f7) +++ generic/xotcl.c (.../xotcl.c) (revision ffd2368a61d1328d71f07ef8b922820bf8263c25) @@ -98,6 +98,7 @@ static XOTclCallStackContent *CallStackGetFrame(Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr); XOTCLINLINE static void CallStackPop(Tcl_Interp *interp, XOTclCallStackContent *cscPtr); XOTCLINLINE static void CallStackDoDestroy(Tcl_Interp *interp, XOTclObject *obj); +static int XOTclCInvalidateInterfaceDefinitionMethod(Tcl_Interp *interp, XOTclClass *cl); typedef enum { CALLING_LEVEL, ACTIVE_LEVEL } CallStackLevel; @@ -107,6 +108,12 @@ Tcl_CallFrame *varFramePtr; } callFrameContext; +typedef struct XOTclProcContext { + ClientData oldDeleteData; + Tcl_CmdDeleteProc *oldDeleteProc; + XOTclNonposArgs *nonposArgs; +} XOTclProcContext; + typedef struct tclCmdClientData { XOTclObject *obj; Tcl_Obj *cmdName; @@ -149,7 +156,7 @@ #if defined(CANONICAL_ARGS) int canonicalNonpositionalArgs(parseContext *pcPtr, Tcl_Interp *interp, XOTclNonposArgs *nonposArgs, - XOTclCallStackContent *csc, int objc, Tcl_Obj *CONST objv[]); + char *methodName, int objc, Tcl_Obj *CONST objv[]); #endif void parseContextInit(parseContext *pc, int objc, Tcl_Obj *procName) { if (objc < PARSE_CONTEXT_PREALLOC) { @@ -3259,6 +3266,10 @@ Tcl_HashTable objTable, *commandTable = &objTable; cl->order = NULL; + /* + fprintf(stderr, "MixinInvalidateObjOrders %s calls ifd invalidate\n",className(cl)); + XOTclCInvalidateInterfaceDefinitionMethod(interp, cl); TODO REMOVEMEIFYOUARESURE + */ /* reset mixin order for all instances of the class and the instances of its subclasses @@ -3267,7 +3278,10 @@ Tcl_HashSearch hSrch; Tcl_HashEntry *hPtr = &clPtr->cl->instances ? Tcl_FirstHashEntry(&clPtr->cl->instances, &hSrch) : NULL; - + /* + fprintf(stderr, "MixinInvalidateObjOrders subclass %s calls ifd invalidate \n",className(clPtr->cl)); + XOTclCInvalidateInterfaceDefinitionMethod(interp, clPtr->cl); TODO REMOVEMEIFYOUARESURE + */ /* reset mixin order for all objects having this class as per object mixin */ ResetOrderOfClassesUsedAsMixins(clPtr->cl); @@ -3298,6 +3312,8 @@ /*fprintf(stderr,"Got %s, reset for ncl %p\n",ncl?ObjStr(ncl->object.cmdName):"NULL",ncl);*/ if (ncl) { MixinResetOrderForInstances(interp, ncl); + fprintf(stderr, "MixinInvalidateObjOrders via instmixin %s calls ifd invalidate \n",className(ncl)); + XOTclCInvalidateInterfaceDefinitionMethod(interp, ncl); } } MEM_COUNT_FREE("Tcl_InitHashTable", commandTable); @@ -4773,14 +4789,6 @@ #endif } - -/* xxx */ -typedef struct XOTclProcContext { - ClientData oldDeleteData; - Tcl_CmdDeleteProc *oldDeleteProc; - XOTclNonposArgs *nonposArgs; -} XOTclProcContext; - void XOTclProcDeleteProc(ClientData clientData) { XOTclProcContext *ctxPtr = (XOTclProcContext *)clientData; (*ctxPtr->oldDeleteProc)(ctxPtr->oldDeleteData); @@ -4929,26 +4937,16 @@ # if defined(CANONICAL_ARGS) /* If the method to be invoked hasnonposArgs, we have to call the - argument parser with the argument definitions. The argument - definitions are looked up in canonicalNonpositionalArgs() via a - hash table, which causes a per-proc overhead. It would be - certainly nicer and more efficient to store both the argument - definitions in the Tcl Proc structure, which has unfortunately - no clientData. - - If would be already nice if the Proc structure would contain a - "flags" variable, where we could check, whether nonposArgs are - provided. This would make method invocations as efficient as - without nonposArgs. - + argument parser with the argument definitions obtained from the + proc context from the cmdPtr. */ { XOTclNonposArgs *nonposArgs = Tcl_Command_deleteProc(cmdPtr) == XOTclProcDeleteProc ? ((XOTclProcContext *)Tcl_Command_deleteData(cmdPtr))->nonposArgs : NULL; if (nonposArgs) { parseContext pc; - result = canonicalNonpositionalArgs(&pc, interp, nonposArgs, csc, objc, objv); + result = canonicalNonpositionalArgs(&pc, interp, nonposArgs, methodName, objc, objv); if (result == TCL_OK) { result = PushProcCallFrame(cp, interp, pc.objc+1, pc.full_objv, csc); /* maybe release is to early */ @@ -5408,6 +5406,19 @@ */ static void argDefinitionsFree(argDefinition *argDefinitions); +static void NonposArgsFree(XOTclNonposArgs *nonposArgs) { + if (nonposArgs->ifd) { + argDefinitionsFree(nonposArgs->ifd); + } + FREE(XOTclNonposArgs, nonposArgs); +} +static void ParsedInterfaceDefinitionFree(XOTclParsedInterfaceDefinition *parsedIf) { + /*fprintf(stderr, "ParsedInterfaceDefinitionFree %p, npargs %p\n",parsedIf,parsedIf->nonposArgs);*/ + if (parsedIf->nonposArgs) { + NonposArgsFree(parsedIf->nonposArgs); + } + FREE(XOTclParsedInterfaceDefinition, parsedIf); +} static Tcl_Obj * NonposArgsFormat(Tcl_Interp *interp, XOTclNonposArgs *nonposArgs) { @@ -5552,9 +5563,9 @@ return XOTclObjErrType(interp, objPtr, "class"); } -static int convertToInterceptor(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientData) { - /*TODO: should we check wheter it is a valid object and/or filter method, somehow?!*/ - return TCL_OK; +static int convertToRelation(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientData) { + /*TODO: should we check wheter it is a valid object and/or filter method, somehow?!*/ + return TCL_OK; } @@ -5622,10 +5633,10 @@ ifPtr->nrargs = 1; ifPtr->converter = convertToClass; ifPtr->type = "class"; - } else if (strncmp(option,"interceptor",length) == 0) { - ifPtr->nrargs = 1; - ifPtr->converter = convertToInterceptor; - ifPtr->type = "class"; + } else if (strncmp(option,"relation",length) == 0) { + ifPtr->nrargs = 1; + ifPtr->converter = convertToRelation; + ifPtr->type = "class"; } else { fprintf(stderr, "**** unknown option: def %s, option '%s' (%d)\n",ifPtr->name,option,length); } @@ -7340,6 +7351,9 @@ MixinInvalidateObjOrders(interp, cl); FilterInvalidateObjOrders(interp, cl); + /* todo: maybe not needed, of done by MixinInvalidateObjOrders() already */ + XOTclCInvalidateInterfaceDefinitionMethod(interp, cl); + if (clopt) { /* * Remove this class from all isClassMixinOf lists and clear the instmixin list @@ -10165,25 +10179,21 @@ /* WARNING: - This is not intended to stay like this. Currently, the parsed - interface definitions are stored in the class structure of the - object to be created and NEVER freed from there. We have - currently a memory leak, when cacheInterface is activated - + a) definitions are freed on a class cleanup, with + ParsedInterfaceDefinitionFree(cl->parsedIf) + What should be done: - a) on a class cleanup, the obj->cl->parsedIf should be freed with - argDefinitionsFree(parsedIf.nonposArgs->ifd); - FREE(XOTclNonposArgs, parsedIf.nonposArgs); - b) the same cleanup should be performed, whenever - 1) the class structure changes, - 2) slots are defined, - 3) instmixins are added + 1) the class structure changes, DONE + 2) instmixins are added DONE + 3) slots are defined, DONE + 4) slots defaults or types are changed + 5) slots removals (destroy on slots) */ - if (RUNTIME_STATE(interp)->cacheInterface && obj->cl->parsedIf) { + if (obj->cl->parsedIf) { parsedIf->nonposArgs = obj->cl->parsedIf->nonposArgs; parsedIf->possibleUnknowns = obj->cl->parsedIf->possibleUnknowns; /*fprintf(stderr, "returned cached objif for obj %s returned parsedIf->nonposArgs %p ifd %p ifdSize %d\n", @@ -10195,6 +10205,7 @@ if (result == TCL_OK) { rawConfArgs = Tcl_GetObjResult(interp); INCR_REF_COUNT(rawConfArgs); + /* TODO: this is a dangerous comparison */ if (rawConfArgs != XOTclGlobalObjects[XOTE_EMPTY]) { /* Obtain interface structure */ @@ -10206,7 +10217,7 @@ XOTclParsedInterfaceDefinition *ifd = NEW(XOTclParsedInterfaceDefinition); ifd->nonposArgs = parsedIf->nonposArgs; ifd->possibleUnknowns = parsedIf->possibleUnknowns; - obj->cl->parsedIf = ifd; + obj->cl->parsedIf = ifd; /* free with ParsedInterfaceDefinitionFree(cl->parsedIf); */ /*fprintf(stderr, "GetObjectInterface cache nonposArgs %p possibleUnknowns %d ifd %p ifdSize %d\n", ifd->nonposArgs,ifd->possibleUnknowns,ifd->nonposArgs->ifd, ifd->nonposArgs->ifdSize);*/ } @@ -10244,12 +10255,12 @@ nonposArgs = parsedIf.nonposArgs; iConfigurePtr = iConfigure = nonposArgs->ifd; - /* allow the retrieval of self (GetSelfObj(); needed in convertToInterceptor) + /* allow the retrieval of self (GetSelfObj(); needed in convertToRelation) * + make instvars of obj accessible */ XOTcl_PushFrame(interp, obj); /* 2. continue parsing the actual args passed */ - result = canonicalNonpositionalArgs(&pc, interp, nonposArgs, csc, objc, objv); + result = canonicalNonpositionalArgs(&pc, interp, nonposArgs, "configure", objc, objv); if (result != TCL_OK) { parseContextRelease(&pc); goto configure_exit; @@ -10457,7 +10468,7 @@ * STEP 2: Proceed with parsing of the passed var args, using parseObjv() */ - result = canonicalNonpositionalArgs(&pc, interp, nonposArgs, csc, objc, objv); + result = canonicalNonpositionalArgs(&pc, interp, nonposArgs, "configure", objc, objv); if (result != TCL_OK) { goto configure_exit; } @@ -10564,8 +10575,7 @@ #if defined(CONFIGURE_ARGS) if(parsedIf.nonposArgs) { if (RUNTIME_STATE(interp)->cacheInterface == 0) { - argDefinitionsFree(parsedIf.nonposArgs->ifd); - FREE(XOTclNonposArgs, parsedIf.nonposArgs); + NonposArgsFree(parsedIf.nonposArgs); } } #else @@ -11396,6 +11406,15 @@ return rc; } +static int XOTclCInvalidateInterfaceDefinitionMethod(Tcl_Interp *interp, XOTclClass *cl) { + fprintf(stderr, " %s invalidate %p\n", className(cl), cl->parsedIf); + if (cl->parsedIf) { + ParsedInterfaceDefinitionFree(cl->parsedIf); + cl->parsedIf = NULL; + } + return TCL_OK; +} + static int XOTclCRecreateMethod(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *name, int objc, Tcl_Obj *CONST objv[]) { XOTclObject *newObj; @@ -12371,7 +12390,7 @@ #if defined(CANONICAL_ARGS) int canonicalNonpositionalArgs(parseContext *pcPtr, Tcl_Interp *interp, XOTclNonposArgs *nonposArgs, - XOTclCallStackContent *csc, int objc, Tcl_Obj *CONST objv[]) { + char *methodName, int objc, Tcl_Obj *CONST objv[]) { argDefinition CONST *aPtr; int i, rc; @@ -12395,26 +12414,26 @@ int bool; Tcl_GetBooleanFromObj(interp, aPtr->defaultValue, &bool); pcPtr->objv[i] = Tcl_NewBooleanObj(!bool); - } else if(aPtr->converter == convertToInterceptor) { + } else if(aPtr->converter == convertToRelation) { int result = TCL_OK, relIdx; XOTclObject *self = GetSelfObj(interp); if(self) { - Tcl_Obj *dummy = Tcl_NewStringObj(argName,strlen(argName)); - INCR_REF_COUNT(dummy); - result = convertToRelationtype(interp,dummy,(ClientData)&relIdx); - DECR_REF_COUNT(dummy); - if (result == TCL_OK) { - result = XOTclRelationCmd(interp, self, relIdx, pcPtr->objv[i]); - /* TODO: For the time being, we fall back to an unknown value - * so that we do not obtain proc-local (through InitArgsAndLocals()) - * or object variables (through XOTclOConfigureMethod) from relational commands - * ... is this a valid approach? - */ - pcPtr->objv[i] = XOTclGlobalObjects[XOTE___UNKNOWN__]; - } else { - return XOTclVarErrMsg(interp, "setting relation '",argName, "' on object '", - objectName(self), "' failed", (char *) NULL); - } + Tcl_Obj *dummy = Tcl_NewStringObj(argName,strlen(argName)); + INCR_REF_COUNT(dummy); + result = convertToRelationtype(interp,dummy,(ClientData)&relIdx); + DECR_REF_COUNT(dummy); + if (result == TCL_OK) { + result = XOTclRelationCmd(interp, self, relIdx, pcPtr->objv[i]); + /* TODO: For the time being, we fall back to an unknown value + * so that we do not obtain proc-local (through InitArgsAndLocals()) + * or object variables (through XOTclOConfigureMethod) from relational commands + * ... is this a valid approach? + */ + pcPtr->objv[i] = XOTclGlobalObjects[XOTE___UNKNOWN__]; + } else { + return XOTclVarErrMsg(interp, "setting relation '",argName, "' on object '", + objectName(self), "' failed", (char *) NULL); + } } else { return XOTclVarErrMsg(interp, "trying to set a relation outside a self-reference", (char *) NULL); } @@ -12426,8 +12445,7 @@ /* 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) { - char *methodName = (char *)Tcl_GetCommandName(interp, csc->cmdPtr); - return XOTclVarErrMsg(interp, "method ",methodName, ": required argument '", + return XOTclVarErrMsg(interp, "method ", methodName, ": required argument '", argName, "' is missing", (char *) NULL); } else { /* Use as dummy default value an arbitrary symbol, normally @@ -13156,6 +13174,7 @@ RUNTIME_STATE(interp)->doFilters = 1; RUNTIME_STATE(interp)->callDestroy = 1; + RUNTIME_STATE(interp)->cacheInterface = 0; /* TODO xxx should not stay */ /* create xotcl namespace */ RUNTIME_STATE(interp)->XOTclNS = Index: tests/objifdtest.xotcl =================================================================== diff -u --- tests/objifdtest.xotcl (revision 0) +++ tests/objifdtest.xotcl (revision ffd2368a61d1328d71f07ef8b922820bf8263c25) @@ -0,0 +1,56 @@ +package require XOTcl +namespace import -force xotcl::* +package require xotcl::test + +proc ? {cmd expected {msg ""}} { + set count 10 + if {$msg ne ""} { + set t [Test new -cmd $cmd -count $count -msg $msg] + } else { + set t [Test new -cmd $cmd -count $count] + } + $t expected $expected + $t run +} + +catch {::xotcl::configure cacheinterface true} + +puts stderr =====START +Class C -parameter {a {b:boolean} {c 1}} + +C c1 +? {C configureargs} "-instfilter:relation -superclass:relation -instmixin:relation -mixin:relation -filter:relation -class:relation args" +? {c1 configureargs} "-a -b:boolean {-c 1} -mixin:relation -filter:relation -class:relation args" + +# reclass to Object, no neet to do anything on caching +puts stderr "=== reclass c1 to Object" +c1 class Object +? {c1 configureargs} "-mixin:relation -filter:relation -class:relation args" + +puts stderr "=== create Class D" +Class D -superclass C -parameter {d:required} +D d1 -d 100 +? {d1 configureargs} "-d:required -a -b:boolean {-c 1} -mixin:relation -filter:relation -class:relation args" + + +set case "instmixin M into D" +Class M -parameter {m1 m2 b} +Class M2 -parameter {b2} +puts stderr "=== $case" +D instmixin M +? {d1 configureargs} "-b -m1 -m2 -d:required -a {-c 1} -mixin:relation -filter:relation -class:relation args" "$case: mixin added" +M instmixin M2 +? {d1 configureargs} "-b2 -b -m1 -m2 -d:required -a {-c 1} -mixin:relation -filter:relation -class:relation args" "$case: transitive mixin added" +D instmixin "" +#we should have again the old interface +? {d1 configureargs} "-d:required -a -b:boolean {-c 1} -mixin:relation -filter:relation -class:relation args" "$case: mixin removed" + +set case "instmixin M into C" +puts stderr "=== $case" +C instmixin M +? {d1 configureargs} "-b2 -b -m1 -m2 -d:required -a {-c 1} -mixin:relation -filter:relation -class:relation args" "$case: mixin added" +C instmixin "" +#we should have again the old interface +? {d1 configureargs} "-d:required -a -b:boolean {-c 1} -mixin:relation -filter:relation -class:relation args" "$case: mixin removed" + +puts stderr =====END \ No newline at end of file