Index: ChangeLog =================================================================== diff -u -rf0387e8a04225c1b3b62dd2726f6b6042d618454 -r0037211cd9632cbb418f9f8ca40a001a51d1598d --- ChangeLog (.../ChangeLog) (revision f0387e8a04225c1b3b62dd2726f6b6042d618454) +++ ChangeLog (.../ChangeLog) (revision 0037211cd9632cbb418f9f8ca40a001a51d1598d) @@ -1,3 +1,37 @@ +2008-10-17 + + * handle nonposargs in method "copy" properly + + * extend regression test for copy + + * added " mixinof -closure ?pattern?" + Query the objects for which is used as a per-object-mixin + (directly or indirectly) + + * extended regression test for mixinof + + * updated documentation + +2008-09-11 + * Implement proper downgrading of Classes to Objects: + + In cases where a class ::C is created, which is later downgraded + to an object ::C (either via "::C class ::xotcl::Object" or via + "::xotcl::Object ::C"), earlier versions of XOTcl were to + liberal. The major problem is to invalidate all places, where + ::C might be used as a class, and were only classes are allowed + (e.g. mixin chains, precedence orders). + + The new version does not allow downgrading via the class method + and does a destroy/create instead of a recreate when a + same-named class existed before. + + * reset mixin order for per-object mixins, when the superclass + of a class is deleted, which is used as per-object mixin + + * extended regression test + * Updating and improving documentation + 2008-06-24 * Release of XOTcl 1.6.1 Index: configure =================================================================== diff -u -r34f178fae21c3cf3a2410c7b1986d3e6b84dcf42 -r0037211cd9632cbb418f9f8ca40a001a51d1598d --- configure (.../configure) (revision 34f178fae21c3cf3a2410c7b1986d3e6b84dcf42) +++ configure (.../configure) (revision 0037211cd9632cbb418f9f8ca40a001a51d1598d) @@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.59 for xotcl 1.6.1. +# Generated by GNU Autoconf 2.59 for xotcl 1.6.2. # # Copyright (C) 2003 Free Software Foundation, Inc. # This configure script is free software; the Free Software Foundation @@ -267,8 +267,8 @@ # Identity of this package. PACKAGE_NAME='xotcl' PACKAGE_TARNAME='xotcl' -PACKAGE_VERSION='1.6.1' -PACKAGE_STRING='xotcl 1.6.1' +PACKAGE_VERSION='1.6.2' +PACKAGE_STRING='xotcl 1.6.2' PACKAGE_BUGREPORT='' # Factoring default headers for most tests. @@ -777,7 +777,7 @@ # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -\`configure' configures xotcl 1.6.1 to adapt to many kinds of systems. +\`configure' configures xotcl 1.6.2 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -834,7 +834,7 @@ if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of xotcl 1.6.1:";; + short | recursive ) echo "Configuration of xotcl 1.6.2:";; esac cat <<\_ACEOF @@ -979,7 +979,7 @@ test -n "$ac_init_help" && exit 0 if $ac_init_version; then cat <<\_ACEOF -xotcl configure 1.6.1 +xotcl configure 1.6.2 generated by GNU Autoconf 2.59 Copyright (C) 2003 Free Software Foundation, Inc. @@ -993,7 +993,7 @@ This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by xotcl $as_me 1.6.1, which was +It was created by xotcl $as_me 1.6.2, which was generated by GNU Autoconf 2.59. Invocation command line was $ $0 $@ @@ -1572,7 +1572,7 @@ # do not modify the following lines manually, they are generated with changeXOTclVersion XOTCL_MAJOR_VERSION=1 XOTCL_MINOR_VERSION=6 -XOTCL_RELEASE_LEVEL=.1 +XOTCL_RELEASE_LEVEL=.2 XOTCL_VERSION=${XOTCL_MAJOR_VERSION}.${XOTCL_MINOR_VERSION} NODOT_VERSION=${XOTCL_MAJOR_VERSION}${XOTCL_MINOR_VERSION} @@ -10804,7 +10804,7 @@ } >&5 cat >&5 <<_CSEOF -This file was extended by xotcl $as_me 1.6.1, which was +This file was extended by xotcl $as_me 1.6.2, which was generated by GNU Autoconf 2.59. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -10859,7 +10859,7 @@ cat >>$CONFIG_STATUS <<_ACEOF ac_cs_version="\\ -xotcl config.status 1.6.1 +xotcl config.status 1.6.2 configured by $0, generated by GNU Autoconf 2.59, with options \\"`echo "$ac_configure_args" | sed 's/[\\""\`\$]/\\\\&/g'`\\" @@ -11489,3 +11489,5 @@ + + Index: configure.in =================================================================== diff -u -r34f178fae21c3cf3a2410c7b1986d3e6b84dcf42 -r0037211cd9632cbb418f9f8ca40a001a51d1598d --- configure.in (.../configure.in) (revision 34f178fae21c3cf3a2410c7b1986d3e6b84dcf42) +++ configure.in (.../configure.in) (revision 0037211cd9632cbb418f9f8ca40a001a51d1598d) @@ -11,7 +11,7 @@ # for this package, and can be a relative path, such as: # #-------------------------------------------------------------------- -define(XOTclVersion, 1.6.1) +define(XOTclVersion, 1.6.2) AC_INIT([xotcl], [XOTclVersion]) #-------------------------------------------------------------------- @@ -104,7 +104,7 @@ # do not modify the following lines manually, they are generated with changeXOTclVersion XOTCL_MAJOR_VERSION=1 XOTCL_MINOR_VERSION=6 -XOTCL_RELEASE_LEVEL=.1 +XOTCL_RELEASE_LEVEL=.2 XOTCL_VERSION=${XOTCL_MAJOR_VERSION}.${XOTCL_MINOR_VERSION} NODOT_VERSION=${XOTCL_MAJOR_VERSION}${XOTCL_MINOR_VERSION} @@ -501,3 +501,5 @@ + + Index: doc/langRef.xotcl =================================================================== diff -u -r5d5e792f4a7f64411aa0537f4677ae96dea4432f -r0037211cd9632cbb418f9f8ca40a001a51d1598d --- doc/langRef.xotcl (.../langRef.xotcl) (revision 5d5e792f4a7f64411aa0537f4677ae96dea4432f) +++ doc/langRef.xotcl (.../langRef.xotcl) (revision 0037211cd9632cbb418f9f8ca40a001a51d1598d) @@ -1129,10 +1129,12 @@ Returns all instprocs defined for the class. If pattern is specified it returns all instprocs that match the pattern. - <@li><@TT>ClassName info mixinof ?pattern?: - Returns the list of classes, into which this class was mixed in - via per object mixin. This is the inverse function of <@TT>Object - info mixin. If <@TT>pattern is specified and + <@li><@TT>ClassName info mixinof ?-closure? ?pattern?: Returns the + list of classes, into which this class was mixed in via per + object mixin. This is the inverse function of <@TT>Object info + mixin. If <@TT>-closure is specified, also the + classes are returned, for which the class is indirectly mixed in + as a per-object mixin. If <@TT>pattern is specified and it contains wildcards, all matching mixin classes are returned. If <@TT>pattern does not contain wildcards, either the fully qualified name is returned, or empty, if no Index: generic/predefined.h =================================================================== diff -u -r9908c8760bc77e7801e462c525f37cefc13dbdcc -r0037211cd9632cbb418f9f8ca40a001a51d1598d --- generic/predefined.h (.../predefined.h) (revision 9908c8760bc77e7801e462c525f37cefc13dbdcc) +++ generic/predefined.h (.../predefined.h) (revision 0037211cd9632cbb418f9f8ca40a001a51d1598d) @@ -325,7 +325,7 @@ "$cl instinvar [$origin info instinvar]\n" "$cl instfilter [$origin info instfilter -guards]\n" "$cl instmixin [$origin info instmixin]\n" -"my copyNSVarsAndCmds ::xotcl::classes::$origin ::xotcl::classes::$dest} else {\n" +"my copyNSVarsAndCmds ::xotcl::classes$origin ::xotcl::classes$dest} else {\n" "set obj [[$origin info class] create $dest -noinit]}\n" "$obj invar [$origin info invar]\n" "$obj check [$origin info check]\n" Index: generic/predefined.xotcl =================================================================== diff -u -r99bd33b963fde1d8c93383fab145234724f2f063 -r0037211cd9632cbb418f9f8ca40a001a51d1598d --- generic/predefined.xotcl (.../predefined.xotcl) (revision 99bd33b963fde1d8c93383fab145234724f2f063) +++ generic/predefined.xotcl (.../predefined.xotcl) (revision 0037211cd9632cbb418f9f8ca40a001a51d1598d) @@ -523,6 +523,7 @@ } ::xotcl::Object::CopyHandler instproc copyNSVarsAndCmds {orig dest} { + #puts stderr "copyNSVarsAndCmds $orig $dest" ::xotcl::namespace_copyvars $orig $dest ::xotcl::namespace_copycmds $orig $dest } @@ -548,7 +549,7 @@ $cl instinvar [$origin info instinvar] $cl instfilter [$origin info instfilter -guards] $cl instmixin [$origin info instmixin] - my copyNSVarsAndCmds ::xotcl::classes::$origin ::xotcl::classes::$dest + my copyNSVarsAndCmds ::xotcl::classes$origin ::xotcl::classes$dest #$cl parameter [$origin info parameter] } else { # create obj Index: generic/xotcl.c =================================================================== diff -u -rb776c687739ef6ede62d99bbf8162fa2b6f5c6ab -r0037211cd9632cbb418f9f8ca40a001a51d1598d --- generic/xotcl.c (.../xotcl.c) (revision b776c687739ef6ede62d99bbf8162fa2b6f5c6ab) +++ generic/xotcl.c (.../xotcl.c) (revision 0037211cd9632cbb418f9f8ca40a001a51d1598d) @@ -1217,7 +1217,7 @@ int result = TCL_OK; char *objName = ObjStr(objPtr); - /*fprintf(stderr, "GetXOTclClassFromObj %s retry %d\n", objName, retry);*/ + /* fprintf(stderr, "GetXOTclClassFromObj %s retry %d\n", objName, retry);*/ if (retry) { /* we refer to an existing object; use command resolver */ @@ -1235,6 +1235,7 @@ if (!cls) { result = XOTclObjConvertObject(interp, objPtr, &obj); + if (result == TCL_OK) { cls = XOTclObjectToClass(obj); if (cls) { @@ -3331,15 +3332,15 @@ */ static int -addToResultSet(Tcl_Interp *interp, Tcl_HashTable *destTable, XOTclClass *cl, int *new, +addToResultSet(Tcl_Interp *interp, Tcl_HashTable *destTable, XOTclObject *obj, int *new, int appendResult, char *pattern, XOTclObject *matchObject) { - Tcl_CreateHashEntry(destTable, (char *)cl, new); + Tcl_CreateHashEntry(destTable, (char *)obj, new); if (*new) { - if (matchObject && matchObject == (XOTclObject *)cl) { + if (matchObject && matchObject == obj) { return 1; } if (appendResult) { - AppendMatchingElement(interp, cl->object.cmdName, pattern); + AppendMatchingElement(interp, obj->cmdName, pattern); } } return 0; @@ -3374,12 +3375,78 @@ } /* + * recursively get all per object mixins from an class and its subclasses/instmixinofs + * into an initialized object ptr hashtable (TCL_ONE_WORD_KEYS) + */ + +static int +getAllObjectMixinsOf(Tcl_Interp *interp, Tcl_HashTable *destTable, XOTclClass *startCl, + int isMixin, + int appendResult, char *pattern, XOTclObject *matchObject) { + int rc = 0, new = 0; + XOTclClasses *sc; + + /*fprintf(stderr, "startCl = %s, opt %p, isMixin %d\n", + ObjStr(startCl->object.cmdName),startCl->opt, isMixin);*/ + + /* + * check all subclasses of startCl for mixins + */ + for (sc = startCl->sub; sc; sc = sc->next) { + rc = getAllObjectMixinsOf(interp, destTable, sc->cl, isMixin, appendResult, pattern, matchObject); + if (rc) {return rc;} + } + /*fprintf(stderr, "check subclasses of %s done\n",ObjStr(startCl->object.cmdName));*/ + + if (startCl->opt) { + XOTclCmdList *m; + XOTclClass *cl; + for (m = startCl->opt->isClassMixinOf; m; m = m->next) { + + /* we should have no deleted commands in the list */ + assert(Tcl_Command_cmdEpoch(m->cmdPtr) == 0); + + cl = XOTclGetClassFromCmdPtr(m->cmdPtr); + assert(cl); + /* fprintf(stderr, "check %s mixinof %s\n", + ObjStr(cl->object.cmdName),ObjStr(startCl->object.cmdName));*/ + rc = getAllObjectMixinsOf(interp, destTable, cl, isMixin, appendResult, pattern, matchObject); + /*fprintf(stderr, "check %s mixinof %s done\n", + ObjStr(cl->object.cmdName),ObjStr(startCl->object.cmdName));*/ + if (rc) {return rc;} + } + } + + /* + * check, if startCl has associated per-object mixins + */ + if (startCl->opt) { + XOTclCmdList *m; + XOTclObject *obj; + + for (m = startCl->opt->isObjectMixinOf; m; m = m->next) { + + /* we should have no deleted commands in the list */ + assert(Tcl_Command_cmdEpoch(m->cmdPtr) == 0); + + obj = XOTclGetObjectFromCmdPtr(m->cmdPtr); + assert(obj); + + rc = addToResultSet(interp, destTable, obj, &new, appendResult, pattern, matchObject); + if (rc == 1) {return rc;} + } + } + return rc; +} + +/* * recursively get all isClassMixinOf of a class into an initialized * object ptr hashtable (TCL_ONE_WORD_KEYS) */ static int -getAllClassMixinsOf(Tcl_Interp *interp, Tcl_HashTable *destTable, XOTclClass *startCl, int isMixin, +getAllClassMixinsOf(Tcl_Interp *interp, Tcl_HashTable *destTable, XOTclClass *startCl, + int isMixin, int appendResult, char *pattern, XOTclObject *matchObject) { int rc = 0, new = 0; XOTclClass *cl; @@ -3394,7 +3461,7 @@ * the startCl is a per class mixin, add it to the result set */ if (isMixin) { - rc = addToResultSet(interp, destTable, startCl, &new, appendResult, pattern, matchObject); + rc = addToResultSet(interp, destTable, &startCl->object, &new, appendResult, pattern, matchObject); if (rc == 1) {return rc;} /* @@ -3420,7 +3487,7 @@ cl = XOTclGetClassFromCmdPtr(m->cmdPtr); assert(cl); - rc = addToResultSet(interp, destTable, cl, &new, appendResult, pattern, matchObject); + rc = addToResultSet(interp, destTable, &cl->object, &new, appendResult, pattern, matchObject); if (rc == 1) {return rc;} if (new) { rc = getAllClassMixinsOf(interp, destTable, cl, 1, appendResult, pattern, matchObject); @@ -3465,7 +3532,7 @@ rc = addToResultSetWithGuards(interp, destTable, cl, m->clientData, &new, 1, pattern, matchObject); } else { /* fprintf(stderr,"addToResultSet: %s\n", ObjStr(cl->object.cmdName)); */ - rc = addToResultSet(interp, destTable, cl, &new, 1, pattern, matchObject); + rc = addToResultSet(interp, destTable, &cl->object, &new, 1, pattern, matchObject); } if (rc == 1) {return rc;} @@ -5880,10 +5947,8 @@ Tcl_Obj *nonposArgs = Tcl_NewListObj(i, &argsv[0]); INCR_REF_COUNT(ordinaryArgs); INCR_REF_COUNT(nonposArgs); - /* fprintf(stderr, "nonpos <%s> ordinary <%s>\n", - ObjStr(nonposArgs), ObjStr(ordinaryArgs));*/ result = parseNonposArgs(interp, procName, nonposArgs, ordinaryArgs, - nonposArgsTable, &haveNonposArgs); + nonposArgsTable, &haveNonposArgs); DECR_REF_COUNT(ordinaryArgs); DECR_REF_COUNT(nonposArgs); if (result != TCL_OK) @@ -6346,25 +6411,33 @@ return XOTclErrBadVal(interp, "info args", "a tcl method name", name); } -static int -ListArgsFromOrdinaryArgs(Tcl_Interp *interp, XOTclNonposArgs *nonposArgs) { +static void +AppendOrdinaryArgsFromNonposArgs(Tcl_Interp *interp, XOTclNonposArgs *nonposArgs, + int varsOnly, + Tcl_Obj *argList) { int i, rc, ordinaryArgsDefc, defaultValueObjc; - Tcl_Obj **ordinaryArgsDefv, **defaultValueObjv, *ordinaryArg, - *argList = Tcl_NewListObj(0, NULL); + Tcl_Obj **ordinaryArgsDefv, **defaultValueObjv, *ordinaryArg; rc = Tcl_ListObjGetElements(interp, nonposArgs->ordinaryArgs, &ordinaryArgsDefc, &ordinaryArgsDefv); - if (rc != TCL_OK) - return TCL_ERROR; - for (i=0; i < ordinaryArgsDefc; i++) { ordinaryArg = ordinaryArgsDefv[i]; rc = Tcl_ListObjGetElements(interp, ordinaryArg, &defaultValueObjc, &defaultValueObjv); - if (rc == TCL_OK && defaultValueObjc == 2) { - ordinaryArg = defaultValueObjv[0]; + if (rc == TCL_OK) { + if (varsOnly && defaultValueObjc == 2) { + Tcl_ListObjAppendElement(interp, argList, defaultValueObjv[0]); + } else { + Tcl_ListObjAppendElement(interp, argList, ordinaryArg); + } } - Tcl_ListObjAppendElement(interp, argList, ordinaryArg); } +} + + +static int +ListArgsFromOrdinaryArgs(Tcl_Interp *interp, XOTclNonposArgs *nonposArgs) { + Tcl_Obj *argList = argList = Tcl_NewListObj(0, NULL); + AppendOrdinaryArgsFromNonposArgs(interp, nonposArgs, 1, argList); Tcl_SetObjResult(interp, argList); return TCL_OK; } @@ -7842,27 +7915,15 @@ } else { /* The target class is not a meta class. Changing meta-class to meta-class, or class to class, or object to object is fine, - but downgrading requires more work */ + but upgrading/downgrading is not allowed */ /*fprintf(stderr,"target class %s not a meta class, am i a class %d\n", ObjStr(cl->object.cmdName), XOTclObjectIsClass(obj) );*/ if (XOTclObjectIsClass(obj)) { - /*XOTclObjectClearClass(obj);*/ - return XOTclVarErrMsg(interp, "cannot turn class into an object ", (char *) NULL); - - /* We are not done here yet. We have to clear the - class from class hierarchies etc., where an object - is not allowed (e.g class hierarchies, mixin lists, etc.) - - We have to prohibit "Class class Object" - */ - - /*XXX*/ - } } (void)RemoveInstance(obj, obj->cl); @@ -10937,7 +10998,7 @@ if (modifiers > 0) { withClosure = checkForModifier(objv, modifiers, "-closure"); if (withClosure == 0) - return XOTclVarErrMsg(interp, "info mixinof: unknown modifier ", + return XOTclVarErrMsg(interp, "info instmixinof: unknown modifier ", ObjStr(objv[2]), (char *) NULL); } @@ -11034,22 +11095,35 @@ if (!strcmp(cmd, "mixinof")) { XOTclObject *matchObject; Tcl_DString ds, *dsPtr = &ds; - int rc; + int rc, withClosure = 0; - if (objc-modifiers > 3 || modifiers > 0) + if (objc-modifiers > 3 || modifiers > 1) return XOTclObjErrArgCnt(interp, cl->object.cmdName, - "info mixinof ?pattern?"); - if (opt) { + "info mixinof ?-closure? ?pattern?"); + if (modifiers > 0) { + withClosure = checkForModifier(objv, modifiers, "-closure"); + if (withClosure == 0) + return XOTclVarErrMsg(interp, "info mixinof: unknown modifier ", + ObjStr(objv[2]), (char *) NULL); + } + if (opt && !withClosure) { DSTRING_INIT(dsPtr); if (getMatchObject(interp, &pattern, &matchObject, dsPtr) == -1) { return TCL_OK; } + /*XXX*/ rc = AppendMatchingElementsFromCmdList(interp, opt->isObjectMixinOf, pattern, matchObject); if (matchObject) { Tcl_SetObjResult(interp, rc ? matchObject->cmdName : XOTclGlobalObjects[XOTE_EMPTY]); } DSTRING_FREE(dsPtr); - } + } else if (withClosure) { + Tcl_HashTable objTable, *commandTable = &objTable; + MEM_COUNT_ALLOC("Tcl_InitHashTable", commandTable); + Tcl_InitHashTable(commandTable, TCL_ONE_WORD_KEYS); + rc = getAllObjectMixinsOf(interp, commandTable, cl, 0, 1, pattern, matchObject); + MEM_COUNT_FREE("Tcl_InitHashTable", commandTable); + } return TCL_OK; } break; @@ -11635,9 +11709,11 @@ Tcl_Obj *newFullCmdName, *oldFullCmdName; char *newName, *oldName, *name; Tcl_Namespace *ns, *newNs; - Tcl_HashTable *cmdTable; + Tcl_HashTable *cmdTable, *nonposArgsTable; Tcl_HashSearch hSrch; Tcl_HashEntry *hPtr; + XOTclObject *obj; + XOTclClass *cl; if (objc != 3) return XOTclObjErrArgCnt(interp, NULL, "namespace_copycmds fromNs toNs"); @@ -11646,6 +11722,24 @@ if (!ns) return TCL_OK; + name = ObjStr(objv[1]); + /* check, if we work on an object or class namespace */ + if (isClassName(name)) { + cl = XOTclpGetClass(interp, NSCutXOTclClasses(name)); + obj = (XOTclObject *)cl; + nonposArgsTable = cl->nonposArgsTable; + } else { + cl = NULL; + obj = XOTclpGetObject(interp, name); + nonposArgsTable = obj->nonposArgsTable; + } + + if (obj == 0) { + return XOTclVarErrMsg(interp, "CopyCmds argument 1 (",ObjStr(objv[1]),") is not an object", + NULL); + } + /* obj = XOTclpGetObject(interp, ObjStr(objv[1]));*/ + newNs = ObjFindNamespace(interp, objv[2]); if (!newNs) return XOTclVarErrMsg(interp, "CopyCmds: Destination namespace ", @@ -11710,40 +11804,52 @@ if (!XOTclpGetObject(interp, oldName)) { if (TclIsProc((Command*)cmd)) { Proc *procPtr = TclFindProc((Interp *)interp, oldName); - Tcl_Obj *arglistObj; + Tcl_Obj *arglistObj = NULL; CompiledLocal *localPtr; + XOTclNonposArgs *nonposArgs = NULL; /* * Build a list containing the arguments of the proc */ - arglistObj = Tcl_NewListObj(0, NULL); - INCR_REF_COUNT(arglistObj); + if (nonposArgsTable) { + nonposArgs = NonposArgsGet(nonposArgsTable, name); + if (nonposArgs) { + arglistObj = NonposArgsFormat(interp, nonposArgs->nonposArgs); + INCR_REF_COUNT(arglistObj); + AppendOrdinaryArgsFromNonposArgs(interp, nonposArgs, 0, arglistObj); + } + } - for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; - localPtr = localPtr->nextPtr) { + if (!arglistObj) { + arglistObj = Tcl_NewListObj(0, NULL); + INCR_REF_COUNT(arglistObj); - if (TclIsCompiledLocalArgument(localPtr)) { - Tcl_Obj *defVal, *defStringObj = Tcl_NewStringObj(localPtr->name, -1); - INCR_REF_COUNT(defStringObj); - /* check for default values */ - if ((GetProcDefault(interp, cmdTable, name, - localPtr->name, &defVal) == TCL_OK) && - (defVal != 0)) { - Tcl_AppendStringsToObj(defStringObj, " ", ObjStr(defVal), - (char *) NULL); - } - Tcl_ListObjAppendElement(interp, arglistObj, defStringObj); - DECR_REF_COUNT(defStringObj); + for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; + localPtr = localPtr->nextPtr) { + + if (TclIsCompiledLocalArgument(localPtr)) { + Tcl_Obj *defVal, *defStringObj = Tcl_NewStringObj(localPtr->name, -1); + INCR_REF_COUNT(defStringObj); + + /* check for default values */ + if ((GetProcDefault(interp, cmdTable, name, + localPtr->name, &defVal) == TCL_OK) && + (defVal != 0)) { + Tcl_AppendStringsToObj(defStringObj, " ", ObjStr(defVal), + (char *) NULL); + } + Tcl_ListObjAppendElement(interp, arglistObj, defStringObj); + DECR_REF_COUNT(defStringObj); + } } } if (Tcl_Command_objProc(cmd) == RUNTIME_STATE(interp)->objInterpProc) { Tcl_DString ds, *dsPtr = &ds; - if (isClassName(ns->fullName)) { - /* it started with ::xotcl::classes */ - XOTclClass *cl = XOTclpGetClass(interp, NSCutXOTclClasses(ns->fullName)); + if (cl) { + /* we have a class */ XOTclProcAssertion *procs; if (cl) { Index: library/lib/changeXOTclVersion.xotcl =================================================================== diff -u -r34f178fae21c3cf3a2410c7b1986d3e6b84dcf42 -r0037211cd9632cbb418f9f8ca40a001a51d1598d --- library/lib/changeXOTclVersion.xotcl (.../changeXOTclVersion.xotcl) (revision 34f178fae21c3cf3a2410c7b1986d3e6b84dcf42) +++ library/lib/changeXOTclVersion.xotcl (.../changeXOTclVersion.xotcl) (revision 0037211cd9632cbb418f9f8ca40a001a51d1598d) @@ -6,7 +6,7 @@ # set XOTCL_MAJOR_VERSION 1 set XOTCL_MINOR_VERSION 6 -set XOTCL_RELEASE_LEVEL .1 +set XOTCL_RELEASE_LEVEL .2 # example settings: # 1.0 Index: library/store/XOTclGdbm/configure =================================================================== diff -u -r34f178fae21c3cf3a2410c7b1986d3e6b84dcf42 -r0037211cd9632cbb418f9f8ca40a001a51d1598d --- library/store/XOTclGdbm/configure (.../configure) (revision 34f178fae21c3cf3a2410c7b1986d3e6b84dcf42) +++ library/store/XOTclGdbm/configure (.../configure) (revision 0037211cd9632cbb418f9f8ca40a001a51d1598d) @@ -11006,3 +11006,5 @@ + + Index: library/store/XOTclGdbm/configure.in =================================================================== diff -u -r34f178fae21c3cf3a2410c7b1986d3e6b84dcf42 -r0037211cd9632cbb418f9f8ca40a001a51d1598d --- library/store/XOTclGdbm/configure.in (.../configure.in) (revision 34f178fae21c3cf3a2410c7b1986d3e6b84dcf42) +++ library/store/XOTclGdbm/configure.in (.../configure.in) (revision 0037211cd9632cbb418f9f8ca40a001a51d1598d) @@ -291,3 +291,5 @@ + + Index: library/store/XOTclSdbm/configure =================================================================== diff -u -r34f178fae21c3cf3a2410c7b1986d3e6b84dcf42 -r0037211cd9632cbb418f9f8ca40a001a51d1598d --- library/store/XOTclSdbm/configure (.../configure) (revision 34f178fae21c3cf3a2410c7b1986d3e6b84dcf42) +++ library/store/XOTclSdbm/configure (.../configure) (revision 0037211cd9632cbb418f9f8ca40a001a51d1598d) @@ -10952,3 +10952,5 @@ + + Index: library/store/XOTclSdbm/configure.in =================================================================== diff -u -r34f178fae21c3cf3a2410c7b1986d3e6b84dcf42 -r0037211cd9632cbb418f9f8ca40a001a51d1598d --- library/store/XOTclSdbm/configure.in (.../configure.in) (revision 34f178fae21c3cf3a2410c7b1986d3e6b84dcf42) +++ library/store/XOTclSdbm/configure.in (.../configure.in) (revision 0037211cd9632cbb418f9f8ca40a001a51d1598d) @@ -250,3 +250,5 @@ + + Index: library/xml/TclExpat-1.1/configure =================================================================== diff -u -r34f178fae21c3cf3a2410c7b1986d3e6b84dcf42 -r0037211cd9632cbb418f9f8ca40a001a51d1598d --- library/xml/TclExpat-1.1/configure (.../configure) (revision 34f178fae21c3cf3a2410c7b1986d3e6b84dcf42) +++ library/xml/TclExpat-1.1/configure (.../configure) (revision 0037211cd9632cbb418f9f8ca40a001a51d1598d) @@ -10992,3 +10992,5 @@ + + Index: library/xml/TclExpat-1.1/configure.in =================================================================== diff -u -r34f178fae21c3cf3a2410c7b1986d3e6b84dcf42 -r0037211cd9632cbb418f9f8ca40a001a51d1598d --- library/xml/TclExpat-1.1/configure.in (.../configure.in) (revision 34f178fae21c3cf3a2410c7b1986d3e6b84dcf42) +++ library/xml/TclExpat-1.1/configure.in (.../configure.in) (revision 0037211cd9632cbb418f9f8ca40a001a51d1598d) @@ -255,3 +255,5 @@ + + Index: tests/mixinoftest.xotcl =================================================================== diff -u -r570b5b8ea87572bdfd1460842ac333359800467b -r0037211cd9632cbb418f9f8ca40a001a51d1598d --- tests/mixinoftest.xotcl (.../mixinoftest.xotcl) (revision 570b5b8ea87572bdfd1460842ac333359800467b) +++ tests/mixinoftest.xotcl (.../mixinoftest.xotcl) (revision 0037211cd9632cbb418f9f8ca40a001a51d1598d) @@ -24,6 +24,32 @@ A destroy ########################################### +# testing transitive per object mixins +########################################### + +Class B +Class C -superclass B + +Class M +B instmixin M + +Object o -mixin C +Object o1 -mixin B +? {C info mixinof} ::o +? {lsort [B info mixinof -closure]} "::o ::o1" +? {lsort [B info mixinof -closure ::o1]} "::o1" +? {lsort [B info mixinof -closure ::o*]} "::o ::o1" +? {lsort [C info mixinof -closure ::o*]} "::o" +# A class is mixed into a per-object mixin class +? {lsort [M info mixinof -closure ::o*]} "::o ::o1" +? {lsort [M info mixinof]} "" + +M destroy +B destroy +C destroy +::o destroy +::o1 destroy +########################################### # testing per object mixins with redefinition ########################################### Class M -instproc foo args {puts x;next} Index: tests/testx.xotcl =================================================================== diff -u -r6eb89539f80a3c5aac8f271fc780df57db921013 -r0037211cd9632cbb418f9f8ca40a001a51d1598d --- tests/testx.xotcl (.../testx.xotcl) (revision 6eb89539f80a3c5aac8f271fc780df57db921013) +++ tests/testx.xotcl (.../testx.xotcl) (revision 0037211cd9632cbb418f9f8ca40a001a51d1598d) @@ -2549,7 +2549,6 @@ ::errorCheck "[::cutSpaces [y info invar]--[y info pre assProc]--[y info post assProc]]"\ "{7 > 5} { #a comment }--{5 > 3} { #pre }--{5 > 4} {#post }"\ "Copy Obj Assertions" - # # move test # @@ -2626,6 +2625,82 @@ ::errorCheck [B info superclass]-[B1 info superclass]-[X info subclass] \ "::X-::V ::X ::Z-::B ::B1" \ "Move of subclass relationship" + + # + # test nonpos args + # + Class X + X proc do0 {arg1 arg2} {puts "$arg1 $arg2"} + X proc do1 {-arg1 -arg2} {puts "$arg1 $arg2"} + X proc do2 {-arg1 arg2} {puts "$arg1 $arg2"} + X proc do3 {arg1 {arg2 d1}} {puts "$arg1 $arg2"} + X proc do4 {-arg1 {-arg2 d2}} {puts "$arg1 $arg2"} + X proc do5 {{-arg1 d3} {arg2 d4}} {puts "$arg1 $arg2"} + X instproc do6 {{-arg1 d3} {arg2 d4}} {puts "$arg1 $arg2"} + + X copy Y + + foreach m [lsort [X info procs]] { + foreach info {args nonposargs} { + set x [X info $info $m] + set y [Y info $info $m] + ::errorCheck $x $y "copy nonposargs: $x ne $y" + } + foreach a [X info args $m] { + set vx ""; set vy "" + set dx [X info default $m $a vx] + set dy [Y info default $m $a vy] + ::errorCheck $dx $dy "copy nonposargs: hasdefault $dx ne $dy" + if {[info exists dx] && [info exists dy]} { + ::errorCheck $vx $vy "copy nonposargs: hasdefault value $vx ne $vy" + } + } + } + foreach m [lsort [X info instprocs]] { + foreach info {instargs instnonposargs} { + set x [X info $info $m] + set y [Y info $info $m] + ::errorCheck $x $y "copy inst nonposargs: $x ne $y" + } + foreach a [X info instargs $m] { + set vx ""; set vy "" + set dx [X info instdefault $m $a vx] + set dy [Y info instdefault $m $a vy] + ::errorCheck $dx $dy "copy inst nonposargs: hasdefault $dx ne $dy" + if {[info exists dx] && [info exists dy]} { + ::errorCheck $vx $vy "copy inst nonposargs: hasdefault value $vx ne $vy" + } + } + } + + Object X + X proc do0 {arg1 arg2} {puts "$arg1 $arg2"} + X proc do1 {-arg1 -arg2} {puts "$arg1 $arg2"} + X proc do2 {-arg1 arg2} {puts "$arg1 $arg2"} + X proc do3 {arg1 {arg2 d1}} {puts "$arg1 $arg2"} + X proc do4 {-arg1 {-arg2 d2}} {puts "$arg1 $arg2"} + X proc do5 {{-arg1 d3} {arg2 d4}} {puts "$arg1 $arg2"} + + X copy Y + + foreach m [lsort [X info procs]] { + foreach info {args nonposargs} { + set x [X info $info $m] + set y [Y info $info $m] + ::errorCheck $x $y "copy nonposargs: $x ne $y" + } + foreach a [X info args $m] { + set vx ""; set vy "" + set dx [X info default $m $a vx] + set dy [Y info default $m $a vy] + ::errorCheck $dx $dy "copy nonposargs: hasdefault $dx ne $dy" + if {[info exists dx] && [info exists dy]} { + ::errorCheck $vx $vy "copy nonposargs: hasdefault value $vx ne $vy" + } + } + + } + } } @@ -2794,6 +2869,45 @@ unset ::cleanupResult Object instmixin "" + + # upgrading/downgrading + Class B + Class C -superclass B + C c1 + Object o1 -mixin B + Object o2 -mixin C + + ::errorCheck [B info class] "::xotcl::Class" "up/down before 0" + ::errorCheck [c1 istype B] 1 "up/down before 1" + ::errorCheck [C info superclass] ::B "up/down before 2" + ::errorCheck [B info subclass] ::C "up/down before 3" + ::errorCheck [o1 info mixin] ::B "up/down before 4" + ::errorCheck [o2 info mixin] ::C "up/down before 5" + ::errorCheck [B info mixinof] ::o1 "up/down before 6" + ::errorCheck [C info mixinof] ::o2 "up/down before 7" + ::errorCheck [c1 info precedence] "::C ::B ::xotcl::Object" "up/down before 8" + ::errorCheck [o1 info precedence] "::B ::xotcl::Object" "up/down before 9" + ::errorCheck [o2 info precedence] "::C ::B ::xotcl::Object" "up/down before 10" + + ::errorCheck [catch {B class Object}] 1 "don't allow downgrading" + + Object B + ::errorCheck [B info class] "::xotcl::Object" "up/down after 0" + ::errorCheck [c1 istype B] 0 "up/down after 1" + ::errorCheck [C info superclass] ::xotcl::Object "up/down after 2" + ::errorCheck [catch {B info subclass}] 1 "up/down after 3" + ::errorCheck [o1 info mixin] "" "up/down after 4" + ::errorCheck [o2 info mixin] ::C "up/down after 5" + ::errorCheck [catch {B info mixinof}] 1 "up/down after 6" + ::errorCheck [C info mixinof] ::o2 "up/down after 7" + ::errorCheck [c1 info precedence] "::C ::xotcl::Object" "up/down after 8" + ::errorCheck [o1 info precedence] "::xotcl::Object" "up/down after 9" + ::errorCheck [o2 info precedence] "::C ::xotcl::Object" "up/down after 10" + ::errorCheck [B info class] "::xotcl::Object" "up/down after 0x" + + B class Object + ::errorCheck [catch {B class Object}] 0 "don't complain when same level" + ::errorCheck [catch {B class Class}] 1 "don't allow upgrading" } @@ -3122,10 +3236,11 @@ ::errorCheck [o mixin XY4] ::XY4 " __unknown XY4" } - - ::errorCheck [lsort [UnknownClass info info]] {args body children class classchildren classparent commands default filter filterguard forward heritage info instances instbody instcommands instdefault instfilter instfilterguard instforward instinvar instmixin instmixinof instpost instpre instprocs invar methods mixin mixinof parameter parent post pre precedence procs subclass superclass vars} "info info" + # clear unknown handler to avoid strange results later + Class proc __unknown "" "" + ::errorCheck [Class info instances *Unk*] ::UnknownClass "match in info instances" ::errorCheck [Class info instances Unk*] "::UnknownClass" "no match in info instances" ::errorCheck [Class info instances Unk] "" "no match in info instances (no metachars)"