Index: doc/migration1-2.html =================================================================== diff -u -rfa0f6eb39d86da65a0c8f994a30d625d635172ad -r7050a52ac53992d9a3aec12e48b0fa58a26449e6 --- doc/migration1-2.html (.../migration1-2.html) (revision fa0f6eb39d86da65a0c8f994a30d625d635172ad) +++ doc/migration1-2.html (.../migration1-2.html) (revision 7050a52ac53992d9a3aec12e48b0fa58a26449e6) @@ -191,10 +191,50 @@

Introspection

Predefined Methods

Dispatch, Aliases, etc.

+

Assertions

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +

Method Protection

- Last modified: Sat Jan 2 19:05:22 CET 2010 + Last modified: Sun Jan 3 18:26:04 CET 2010 Index: generic/gentclAPI.decls =================================================================== diff -u -r25de23e98a24210b149179c5d1f52836a65fddab -r7050a52ac53992d9a3aec12e48b0fa58a26449e6 --- generic/gentclAPI.decls (.../gentclAPI.decls) (revision 25de23e98a24210b149179c5d1f52836a65fddab) +++ generic/gentclAPI.decls (.../gentclAPI.decls) (revision 7050a52ac53992d9a3aec12e48b0fa58a26449e6) @@ -23,6 +23,11 @@ {-argName "-per-object"} {-argName "cmdName" -required 1 -type tclobj} } +xotclCmd assertion XOTclAssertionCmd { + {-argName "object" -type object} + {-argName "assertionsubcmd" -required 1 -type "check|object-invar|class-invar"} + {-argName "arg" -required 0 -type tclobj} +} xotclCmd configure XOTclConfigureCmd { {-argName "configureoption" -required 1 -type "filter|softrecreate|cacheinterface"} {-argName "value" -required 0 -type tclobj} @@ -39,6 +44,7 @@ xotclCmd dispatch XOTclDispatchCmd { {-argName "object" -required 1 -type object} {-argName "-objscope"} + {-argName "-noassertions"} {-argName "command" -required 1 -type tclobj} {-argName "args" -type args} } @@ -109,9 +115,6 @@ {-argName "-reset"} {-argName "name" -required 1 -type tclobj} } -objectMethod check XOTclOCheckMethod { - {-argName "flag" -required 1 -type tclobj} -} objectMethod cleanup XOTclOCleanupMethod { } objectMethod configure XOTclOConfigureMethod { @@ -143,9 +146,6 @@ objectMethod instvar XOTclOInstVarMethod { {-argName "args" -type allargs} } -objectMethod invar XOTclOInvariantsMethod { - {-argName "invariantlist" -required 1 -type tclobj} -} objectMethod object-method XOTclOMethodMethod { {-argName "-inner-namespace"} {-argName "-public"} @@ -202,9 +202,6 @@ {-argName "filter" -required 1} {-argName "guard" -required 1 -type tclobj} } -classMethod instinvar XOTclCInvariantsMethod { - {-argName "invariantlist" -required 1 -type tclobj} -} classMethod mixinguard XOTclCMixinGuardMethod { {-argName "mixin" -required 1} {-argName "guard" -required 1 -type tclobj} @@ -250,9 +247,6 @@ # # info object methods # -infoObjectMethod check XOTclObjInfoCheckMethod { - {-argName "object" -required 1 -type object} -} infoObjectMethod children XOTclObjInfoChildrenMethod { {-argName "object" -required 1 -type object} {-argName "pattern" -required 0} @@ -278,9 +272,6 @@ infoObjectMethod hasnamespace XOTclObjInfoHasnamespaceMethod { {-argName "object" -required 1 -type object} } -infoObjectMethod invar XOTclObjInfoInvarMethod { - {-argName "object" -required 1 -type object} -} infoObjectMethod method XOTclObjInfoMethodMethod { {-argName "object" -type object} @@ -376,9 +367,6 @@ {-argName "-definition"} {-argName "name"} } -infoClassMethod invar XOTclClassInfoInvarMethod { - {-argName "class" -required 1 -type class} -} infoClassMethod mixin XOTclClassInfoMixinMethod { {-argName "class" -required 1 -type class} {-argName "-closure"} Index: generic/predefined.h =================================================================== diff -u -rfa0f6eb39d86da65a0c8f994a30d625d635172ad -r7050a52ac53992d9a3aec12e48b0fa58a26449e6 --- generic/predefined.h (.../predefined.h) (revision fa0f6eb39d86da65a0c8f994a30d625d635172ad) +++ generic/predefined.h (.../predefined.h) (revision 7050a52ac53992d9a3aec12e48b0fa58a26449e6) @@ -480,15 +480,15 @@ "set cl [[$origin info class] create $dest -noinit]\n" "set obj $cl\n" "$cl superclass [$origin info superclass]\n" -"$cl instinvar [$origin info instinvar]\n" -"$cl instfilter [$origin info instfilter -guards]\n" -"$cl instmixin [$origin info instmixin]\n" +"::xotcl::assertion $cl class-invar [::xotcl::assertion $origin class-invar]\n" +"::xotcl::relation $cl class-filter [::xotcl::relation $origin class-filter]\n" +"::xotcl::relation $cl class-mixin [::xotcl::relation $origin class-mixin]\n" ".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" -"$obj mixin [$origin info mixin]\n" -"$obj filter [$origin info filter -guards]\n" +"::xotcl::assertion $obj check [::xotcl::assertion $origin check]\n" +"::xotcl::assertion $obj object-invar [::xotcl::assertion $origin object-invar]\n" +"::xotcl::relation $obj object-filter [::xotcl::relation $origin object-filter]\n" +"::xotcl::relation $obj object-mixin [::xotcl::relation $origin object-mixin]\n" "if {[$origin info hasnamespace]} {\n" "$obj requireNamespace}} else {\n" "namespace eval $dest {}}\n" Index: generic/predefined.xotcl =================================================================== diff -u -rfa0f6eb39d86da65a0c8f994a30d625d635172ad -r7050a52ac53992d9a3aec12e48b0fa58a26449e6 --- generic/predefined.xotcl (.../predefined.xotcl) (revision fa0f6eb39d86da65a0c8f994a30d625d635172ad) +++ generic/predefined.xotcl (.../predefined.xotcl) (revision 7050a52ac53992d9a3aec12e48b0fa58a26449e6) @@ -900,19 +900,19 @@ # class object set obj $cl $cl superclass [$origin info superclass] - $cl instinvar [$origin info instinvar] - $cl instfilter [$origin info instfilter -guards] - $cl instmixin [$origin info instmixin] + ::xotcl::assertion $cl class-invar [::xotcl::assertion $origin class-invar] + ::xotcl::relation $cl class-filter [::xotcl::relation $origin class-filter] + ::xotcl::relation $cl class-mixin [::xotcl::relation $origin class-mixin] .copyNSVarsAndCmds ::xotcl::classes$origin ::xotcl::classes$dest } else { # create obj set obj [[$origin info class] create $dest -noinit] } # copy object -> may be a class obj - $obj invar [$origin info invar] - $obj check [$origin info check] - $obj mixin [$origin info mixin] - $obj filter [$origin info filter -guards] + ::xotcl::assertion $obj check [::xotcl::assertion $origin check] + ::xotcl::assertion $obj object-invar [::xotcl::assertion $origin object-invar] + ::xotcl::relation $obj object-filter [::xotcl::relation $origin object-filter] + ::xotcl::relation $obj object-mixin [::xotcl::relation $origin object-mixin] if {[$origin info hasnamespace]} { $obj requireNamespace } Index: generic/tclAPI.h =================================================================== diff -u -r25de23e98a24210b149179c5d1f52836a65fddab -r7050a52ac53992d9a3aec12e48b0fa58a26449e6 --- generic/tclAPI.h (.../tclAPI.h) (revision 25de23e98a24210b149179c5d1f52836a65fddab) +++ generic/tclAPI.h (.../tclAPI.h) (revision 7050a52ac53992d9a3aec12e48b0fa58a26449e6) @@ -26,6 +26,15 @@ } enum CallprotectionIdx {CallprotectionNULL, CallprotectionAllIdx, CallprotectionProtectedIdx, CallprotectionPublicIdx}; +static int convertToAssertionsubcmd(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { + int index, result; + static CONST char *opts[] = {"check", "object-invar", "class-invar", NULL}; + result = Tcl_GetIndexFromObj(interp, objPtr, opts, "assertionsubcmd", 0, &index); + *clientData = (ClientData) INT2PTR(index + 1); + return result; +} +enum AssertionsubcmdIdx {AssertionsubcmdNULL, AssertionsubcmdCheckIdx, AssertionsubcmdObject_invarIdx, AssertionsubcmdClass_invarIdx}; + static int convertToConfigureoption(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { int index, result; static CONST char *opts[] = {"filter", "softrecreate", "cacheinterface", NULL}; @@ -104,7 +113,6 @@ static int XOTclCFilterGuardMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCForwardMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCInvalidateObjectParameterMethodStub(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 XOTclCMethodMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCMixinGuardMethodStub(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 []); @@ -115,7 +123,6 @@ static int XOTclClassInfoForwardMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclClassInfoHeritageMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclClassInfoInstancesMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); -static int XOTclClassInfoInvarMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclClassInfoMethodMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclClassInfoMethodsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclClassInfoMixinMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); @@ -126,14 +133,12 @@ static int XOTclClassInfoSubclassMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclClassInfoSuperclassMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclObjInfoCallableMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); -static int XOTclObjInfoCheckMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclObjInfoChildrenMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclObjInfoClassMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclObjInfoFilterMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclObjInfoFilterguardMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclObjInfoForwardMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclObjInfoHasnamespaceMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); -static int XOTclObjInfoInvarMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclObjInfoMethodMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclObjInfoMethodsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclObjInfoMixinMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); @@ -143,7 +148,6 @@ static int XOTclObjInfoSlotObjectsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclObjInfoVarsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclOAutonameMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); -static int XOTclOCheckMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclOCleanupMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclOConfigureMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclODestroyMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); @@ -152,7 +156,6 @@ static int XOTclOFilterSearchMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclOForwardMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclOInstVarMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); -static int XOTclOInvariantsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclOMethodMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclOMixinGuardMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclONextMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); @@ -164,6 +167,7 @@ static int XOTclOVolatileMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclOVwaitMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclAliasCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); +static int XOTclAssertionCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclConfigureCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCreateObjectSystemCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclDeprecatedCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); @@ -191,7 +195,6 @@ static int XOTclCFilterGuardMethod(Tcl_Interp *interp, XOTclClass *cl, char *filter, Tcl_Obj *guard); static int XOTclCForwardMethod(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *name, Tcl_Obj *withDefault, int withEarlybinding, Tcl_Obj *withMethodprefix, int withObjscope, Tcl_Obj *withOnerror, int withVerbose, Tcl_Obj *target, int nobjc, Tcl_Obj *CONST nobjv[]); static int XOTclCInvalidateObjectParameterMethod(Tcl_Interp *interp, XOTclClass *cl); -static int XOTclCInvariantsMethod(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *invariantlist); static int XOTclCMethodMethod(Tcl_Interp *interp, XOTclClass *cl, int withInner_namespace, int withPublic, Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, Tcl_Obj *withPrecondition, Tcl_Obj *withPostcondition); static int XOTclCMixinGuardMethod(Tcl_Interp *interp, XOTclClass *cl, char *mixin, Tcl_Obj *guard); static int XOTclCNewMethod(Tcl_Interp *interp, XOTclClass *cl, XOTclObject *withChildof, int nobjc, Tcl_Obj *CONST nobjv[]); @@ -202,7 +205,6 @@ static int XOTclClassInfoForwardMethod(Tcl_Interp *interp, XOTclClass *class, int withDefinition, char *name); static int XOTclClassInfoHeritageMethod(Tcl_Interp *interp, XOTclClass *class, char *pattern); static int XOTclClassInfoInstancesMethod(Tcl_Interp *interp, XOTclClass *class, int withClosure, char *patternString, XOTclObject *patternObj); -static int XOTclClassInfoInvarMethod(Tcl_Interp *interp, XOTclClass *class); static int XOTclClassInfoMethodMethod(Tcl_Interp *interp, XOTclClass *class, int infomethodsubcmd, char *name); static int XOTclClassInfoMethodsMethod(Tcl_Interp *interp, XOTclClass *object, int withMethodtype, int withCallprotection, int withNomixins, int withIncontext, char *pattern); static int XOTclClassInfoMixinMethod(Tcl_Interp *interp, XOTclClass *class, int withClosure, int withGuards, char *patternString, XOTclObject *patternObj); @@ -213,14 +215,12 @@ static int XOTclClassInfoSubclassMethod(Tcl_Interp *interp, XOTclClass *class, int withClosure, char *patternString, XOTclObject *patternObj); static int XOTclClassInfoSuperclassMethod(Tcl_Interp *interp, XOTclClass *class, int withClosure, Tcl_Obj *pattern); static int XOTclObjInfoCallableMethod(Tcl_Interp *interp, XOTclObject *object, int withWhich, int withMethodtype, int withCallprotection, int withNomixins, int withIncontext, char *pattern); -static int XOTclObjInfoCheckMethod(Tcl_Interp *interp, XOTclObject *object); static int XOTclObjInfoChildrenMethod(Tcl_Interp *interp, XOTclObject *object, char *pattern); static int XOTclObjInfoClassMethod(Tcl_Interp *interp, XOTclObject *object); static int XOTclObjInfoFilterMethod(Tcl_Interp *interp, XOTclObject *object, int withOrder, int withGuards, char *pattern); static int XOTclObjInfoFilterguardMethod(Tcl_Interp *interp, XOTclObject *object, char *filter); static int XOTclObjInfoForwardMethod(Tcl_Interp *interp, XOTclObject *object, int withDefinition, char *name); static int XOTclObjInfoHasnamespaceMethod(Tcl_Interp *interp, XOTclObject *object); -static int XOTclObjInfoInvarMethod(Tcl_Interp *interp, XOTclObject *object); static int XOTclObjInfoMethodMethod(Tcl_Interp *interp, XOTclObject *object, int infomethodsubcmd, char *name); static int XOTclObjInfoMethodsMethod(Tcl_Interp *interp, XOTclObject *object, int withMethodtype, int withCallprotection, int withNomixins, int withIncontext, char *pattern); static int XOTclObjInfoMixinMethod(Tcl_Interp *interp, XOTclObject *object, int withGuards, int withOrder, char *patternString, XOTclObject *patternObj); @@ -230,7 +230,6 @@ static int XOTclObjInfoSlotObjectsMethod(Tcl_Interp *interp, XOTclObject *object, char *pattern); static int XOTclObjInfoVarsMethod(Tcl_Interp *interp, XOTclObject *object, char *pattern); static int XOTclOAutonameMethod(Tcl_Interp *interp, XOTclObject *obj, int withInstance, int withReset, Tcl_Obj *name); -static int XOTclOCheckMethod(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *flag); static int XOTclOCleanupMethod(Tcl_Interp *interp, XOTclObject *obj); static int XOTclOConfigureMethod(Tcl_Interp *interp, XOTclObject *obj, int objc, Tcl_Obj *CONST objv[]); static int XOTclODestroyMethod(Tcl_Interp *interp, XOTclObject *obj); @@ -239,7 +238,6 @@ static int XOTclOFilterSearchMethod(Tcl_Interp *interp, XOTclObject *obj, char *filter); static int XOTclOForwardMethod(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *method, Tcl_Obj *withDefault, int withEarlybinding, Tcl_Obj *withMethodprefix, int withObjscope, Tcl_Obj *withOnerror, int withVerbose, Tcl_Obj *target, int nobjc, Tcl_Obj *CONST nobjv[]); static int XOTclOInstVarMethod(Tcl_Interp *interp, XOTclObject *obj, int objc, Tcl_Obj *CONST objv[]); -static int XOTclOInvariantsMethod(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *invariantlist); static int XOTclOMethodMethod(Tcl_Interp *interp, XOTclObject *obj, int withInner_namespace, int withPublic, Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, Tcl_Obj *withPrecondition, Tcl_Obj *withPostcondition); static int XOTclOMixinGuardMethod(Tcl_Interp *interp, XOTclObject *obj, char *mixin, Tcl_Obj *guard); static int XOTclONextMethod(Tcl_Interp *interp, XOTclObject *obj, int objc, Tcl_Obj *CONST objv[]); @@ -251,10 +249,11 @@ static int XOTclOVolatileMethod(Tcl_Interp *interp, XOTclObject *obj); static int XOTclOVwaitMethod(Tcl_Interp *interp, XOTclObject *obj, char *varname); static int XOTclAliasCmd(Tcl_Interp *interp, XOTclObject *object, char *methodName, int withObjscope, int withPer_object, Tcl_Obj *cmdName); +static int XOTclAssertionCmd(Tcl_Interp *interp, XOTclObject *object, int assertionsubcmd, Tcl_Obj *arg); 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 *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 XOTclDispatchCmd(Tcl_Interp *interp, XOTclObject *object, int withObjscope, int withNoassertions, 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); static int XOTclGetSelfObjCmd(Tcl_Interp *interp, int selfoption); @@ -279,7 +278,6 @@ XOTclCFilterGuardMethodIdx, XOTclCForwardMethodIdx, XOTclCInvalidateObjectParameterMethodIdx, - XOTclCInvariantsMethodIdx, XOTclCMethodMethodIdx, XOTclCMixinGuardMethodIdx, XOTclCNewMethodIdx, @@ -290,7 +288,6 @@ XOTclClassInfoForwardMethodIdx, XOTclClassInfoHeritageMethodIdx, XOTclClassInfoInstancesMethodIdx, - XOTclClassInfoInvarMethodIdx, XOTclClassInfoMethodMethodIdx, XOTclClassInfoMethodsMethodIdx, XOTclClassInfoMixinMethodIdx, @@ -301,14 +298,12 @@ XOTclClassInfoSubclassMethodIdx, XOTclClassInfoSuperclassMethodIdx, XOTclObjInfoCallableMethodIdx, - XOTclObjInfoCheckMethodIdx, XOTclObjInfoChildrenMethodIdx, XOTclObjInfoClassMethodIdx, XOTclObjInfoFilterMethodIdx, XOTclObjInfoFilterguardMethodIdx, XOTclObjInfoForwardMethodIdx, XOTclObjInfoHasnamespaceMethodIdx, - XOTclObjInfoInvarMethodIdx, XOTclObjInfoMethodMethodIdx, XOTclObjInfoMethodsMethodIdx, XOTclObjInfoMixinMethodIdx, @@ -318,7 +313,6 @@ XOTclObjInfoSlotObjectsMethodIdx, XOTclObjInfoVarsMethodIdx, XOTclOAutonameMethodIdx, - XOTclOCheckMethodIdx, XOTclOCleanupMethodIdx, XOTclOConfigureMethodIdx, XOTclODestroyMethodIdx, @@ -327,7 +321,6 @@ XOTclOFilterSearchMethodIdx, XOTclOForwardMethodIdx, XOTclOInstVarMethodIdx, - XOTclOInvariantsMethodIdx, XOTclOMethodMethodIdx, XOTclOMixinGuardMethodIdx, XOTclONextMethodIdx, @@ -339,6 +332,7 @@ XOTclOVolatileMethodIdx, XOTclOVwaitMethodIdx, XOTclAliasCmdIdx, + XOTclAssertionCmdIdx, XOTclConfigureCmdIdx, XOTclCreateObjectSystemCmdIdx, XOTclDeprecatedCmdIdx, @@ -521,25 +515,6 @@ } static int -XOTclCInvariantsMethodStub(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 (ArgumentParse(interp, objc, objv, (XOTclObject *) cl, objv[0], - method_definitions[XOTclCInvariantsMethodIdx].paramDefs, - method_definitions[XOTclCInvariantsMethodIdx].nrParameters, - &pc) != TCL_OK) { - return TCL_ERROR; - } else { - Tcl_Obj *invariantlist = (Tcl_Obj *)pc.clientData[0]; - - parseContextRelease(&pc); - return XOTclCInvariantsMethod(interp, cl, invariantlist); - - } -} - -static int XOTclCMethodMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; XOTclClass *cl = XOTclObjectToClass(clientData); @@ -769,24 +744,6 @@ } static int -XOTclClassInfoInvarMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - parseContext pc; - - if (ArgumentParse(interp, objc, objv, NULL, objv[0], - method_definitions[XOTclClassInfoInvarMethodIdx].paramDefs, - method_definitions[XOTclClassInfoInvarMethodIdx].nrParameters, - &pc) != TCL_OK) { - return TCL_ERROR; - } else { - XOTclClass *class = (XOTclClass *)pc.clientData[0]; - - parseContextRelease(&pc); - return XOTclClassInfoInvarMethod(interp, class); - - } -} - -static int XOTclClassInfoMethodMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; @@ -1032,24 +989,6 @@ } static int -XOTclObjInfoCheckMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - parseContext pc; - - if (ArgumentParse(interp, objc, objv, NULL, objv[0], - method_definitions[XOTclObjInfoCheckMethodIdx].paramDefs, - method_definitions[XOTclObjInfoCheckMethodIdx].nrParameters, - &pc) != TCL_OK) { - return TCL_ERROR; - } else { - XOTclObject *object = (XOTclObject *)pc.clientData[0]; - - parseContextRelease(&pc); - return XOTclObjInfoCheckMethod(interp, object); - - } -} - -static int XOTclObjInfoChildrenMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; @@ -1165,24 +1104,6 @@ } static int -XOTclObjInfoInvarMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - parseContext pc; - - if (ArgumentParse(interp, objc, objv, NULL, objv[0], - method_definitions[XOTclObjInfoInvarMethodIdx].paramDefs, - method_definitions[XOTclObjInfoInvarMethodIdx].nrParameters, - &pc) != TCL_OK) { - return TCL_ERROR; - } else { - XOTclObject *object = (XOTclObject *)pc.clientData[0]; - - parseContextRelease(&pc); - return XOTclObjInfoInvarMethod(interp, object); - - } -} - -static int XOTclObjInfoMethodMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; @@ -1377,25 +1298,6 @@ } static int -XOTclOCheckMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - parseContext pc; - XOTclObject *obj = (XOTclObject *)clientData; - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - if (ArgumentParse(interp, objc, objv, obj, objv[0], - method_definitions[XOTclOCheckMethodIdx].paramDefs, - method_definitions[XOTclOCheckMethodIdx].nrParameters, - &pc) != TCL_OK) { - return TCL_ERROR; - } else { - Tcl_Obj *flag = (Tcl_Obj *)pc.clientData[0]; - - parseContextRelease(&pc); - return XOTclOCheckMethod(interp, obj, flag); - - } -} - -static int XOTclOCleanupMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; XOTclObject *obj = (XOTclObject *)clientData; @@ -1538,25 +1440,6 @@ } static int -XOTclOInvariantsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - parseContext pc; - XOTclObject *obj = (XOTclObject *)clientData; - if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); - if (ArgumentParse(interp, objc, objv, obj, objv[0], - method_definitions[XOTclOInvariantsMethodIdx].paramDefs, - method_definitions[XOTclOInvariantsMethodIdx].nrParameters, - &pc) != TCL_OK) { - return TCL_ERROR; - } else { - Tcl_Obj *invariantlist = (Tcl_Obj *)pc.clientData[0]; - - parseContextRelease(&pc); - return XOTclOInvariantsMethod(interp, obj, invariantlist); - - } -} - -static int XOTclOMethodMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; XOTclObject *obj = (XOTclObject *)clientData; @@ -1740,6 +1623,26 @@ } static int +XOTclAssertionCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + parseContext pc; + + if (ArgumentParse(interp, objc, objv, NULL, objv[0], + method_definitions[XOTclAssertionCmdIdx].paramDefs, + method_definitions[XOTclAssertionCmdIdx].nrParameters, + &pc) != TCL_OK) { + return TCL_ERROR; + } else { + XOTclObject *object = (XOTclObject *)pc.clientData[0]; + int assertionsubcmd = (int )PTR2INT(pc.clientData[1]); + Tcl_Obj *arg = (Tcl_Obj *)pc.clientData[2]; + + parseContextRelease(&pc); + return XOTclAssertionCmd(interp, object, assertionsubcmd, arg); + + } +} + +static int XOTclConfigureCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; @@ -1809,10 +1712,11 @@ } else { XOTclObject *object = (XOTclObject *)pc.clientData[0]; int withObjscope = (int )PTR2INT(pc.clientData[1]); - Tcl_Obj *command = (Tcl_Obj *)pc.clientData[2]; + int withNoassertions = (int )PTR2INT(pc.clientData[2]); + Tcl_Obj *command = (Tcl_Obj *)pc.clientData[3]; parseContextRelease(&pc); - return XOTclDispatchCmd(interp, object, withObjscope, command, objc-pc.lastobjc, objv+pc.lastobjc); + return XOTclDispatchCmd(interp, object, withObjscope, withNoassertions, command, objc-pc.lastobjc, objv+pc.lastobjc); } } @@ -2112,9 +2016,6 @@ {"::xotcl::cmd::Class::__invalidateobjectparameter", XOTclCInvalidateObjectParameterMethodStub, 0, { } }, -{"::xotcl::cmd::Class::instinvar", XOTclCInvariantsMethodStub, 1, { - {"invariantlist", 1, 0, convertToTclobj}} -}, {"::xotcl::cmd::Class::class-method", XOTclCMethodMethodStub, 7, { {"-inner-namespace", 0, 0, convertToBoolean}, {"-public", 0, 0, convertToString}, @@ -2164,9 +2065,6 @@ {"-closure", 0, 0, convertToString}, {"pattern", 0, 0, convertToObjpattern}} }, -{"::xotcl::cmd::ClassInfo::invar", XOTclClassInfoInvarMethodStub, 1, { - {"class", 1, 0, convertToClass}} -}, {"::xotcl::cmd::ClassInfo::method", XOTclClassInfoMethodMethodStub, 3, { {"class", 0, 0, convertToClass}, {"infomethodsubcmd", 0, 0, convertToInfomethodsubcmd}, @@ -2220,9 +2118,6 @@ {"-incontext", 0, 0, convertToString}, {"pattern", 0, 0, convertToString}} }, -{"::xotcl::cmd::ObjectInfo::check", XOTclObjInfoCheckMethodStub, 1, { - {"object", 1, 0, convertToObject}} -}, {"::xotcl::cmd::ObjectInfo::children", XOTclObjInfoChildrenMethodStub, 2, { {"object", 1, 0, convertToObject}, {"pattern", 0, 0, convertToString}} @@ -2248,9 +2143,6 @@ {"::xotcl::cmd::ObjectInfo::hasnamespace", XOTclObjInfoHasnamespaceMethodStub, 1, { {"object", 1, 0, convertToObject}} }, -{"::xotcl::cmd::ObjectInfo::invar", XOTclObjInfoInvarMethodStub, 1, { - {"object", 1, 0, convertToObject}} -}, {"::xotcl::cmd::ObjectInfo::method", XOTclObjInfoMethodMethodStub, 3, { {"object", 0, 0, convertToObject}, {"infomethodsubcmd", 0, 0, convertToInfomethodsubcmd}, @@ -2295,9 +2187,6 @@ {"-reset", 0, 0, convertToString}, {"name", 1, 0, convertToTclobj}} }, -{"::xotcl::cmd::Object::check", XOTclOCheckMethodStub, 1, { - {"flag", 1, 0, convertToTclobj}} -}, {"::xotcl::cmd::Object::cleanup", XOTclOCleanupMethodStub, 0, { } }, @@ -2331,9 +2220,6 @@ {"::xotcl::cmd::Object::instvar", XOTclOInstVarMethodStub, 1, { {"args", 0, 0, convertToNothing}} }, -{"::xotcl::cmd::Object::invar", XOTclOInvariantsMethodStub, 1, { - {"invariantlist", 1, 0, convertToTclobj}} -}, {"::xotcl::cmd::Object::object-method", XOTclOMethodMethodStub, 7, { {"-inner-namespace", 0, 0, convertToString}, {"-public", 0, 0, convertToString}, @@ -2378,6 +2264,11 @@ {"-per-object", 0, 0, convertToString}, {"cmdName", 1, 0, convertToTclobj}} }, +{"::xotcl::assertion", XOTclAssertionCmdStub, 3, { + {"object", 0, 0, convertToObject}, + {"assertionsubcmd", 1, 0, convertToAssertionsubcmd}, + {"arg", 0, 0, convertToTclobj}} +}, {"::xotcl::configure", XOTclConfigureCmdStub, 2, { {"configureoption", 1, 0, convertToConfigureoption}, {"value", 0, 0, convertToTclobj}} @@ -2391,9 +2282,10 @@ {"oldCmd", 1, 0, convertToString}, {"newCmd", 0, 0, convertToString}} }, -{"::xotcl::dispatch", XOTclDispatchCmdStub, 4, { +{"::xotcl::dispatch", XOTclDispatchCmdStub, 5, { {"object", 1, 0, convertToObject}, {"-objscope", 0, 0, convertToString}, + {"-noassertions", 0, 0, convertToString}, {"command", 1, 0, convertToTclobj}, {"args", 0, 0, convertToNothing}} }, Index: generic/xotcl.c =================================================================== diff -u -r25de23e98a24210b149179c5d1f52836a65fddab -r7050a52ac53992d9a3aec12e48b0fa58a26449e6 --- generic/xotcl.c (.../xotcl.c) (revision 25de23e98a24210b149179c5d1f52836a65fddab) +++ generic/xotcl.c (.../xotcl.c) (revision 7050a52ac53992d9a3aec12e48b0fa58a26449e6) @@ -2745,9 +2745,9 @@ if (!opt) return TCL_OK; if (opt->checkoptions & CHECK_OBJINVAR) - Tcl_AppendElement(interp, "invar"); + Tcl_AppendElement(interp, "object-invar"); if (opt->checkoptions & CHECK_CLINVAR) - Tcl_AppendElement(interp, "instinvar"); + Tcl_AppendElement(interp, "class-invar"); if (opt->checkoptions & CHECK_PRE) Tcl_AppendElement(interp, "pre"); if (opt->checkoptions & CHECK_POST) @@ -2862,15 +2862,18 @@ /* we do not check assertion modifying methods, otherwise we can not react in catch on a runtime assertion check failure */ - /* TODO: the following check operations are not generic. these should be - removed, most of the is*String() definition are then obsolete and - should be deleted from xotclInt.h as well. +#if 1 + /* TODO: the following check operations is xotcl1 legacy and is not + generic. it should be replaced by another methodproperty. + Most of the is*String() + definition are then obsolete and should be deleted from + xotclInt.h as well. */ - if (isCheckString(methodName) || isInfoString(methodName) || - isInvarString(methodName) || isInstinvarString(methodName) || - isProcString(methodName) || isInstprocString(methodName)) + if (isCheckString(methodName)) { return TCL_OK; + } +#endif INCR_REF_COUNT(savedObjResult); @@ -2998,9 +3001,66 @@ return result; } +static int AssertionSetCheckOptions(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *arg) { + XOTclObjectOpt *opt = XOTclRequireObjectOpt(obj); + int ocArgs, i; + Tcl_Obj **ovArgs; + opt->checkoptions = CHECK_NONE; + if (Tcl_ListObjGetElements(interp, arg, &ocArgs, &ovArgs) == TCL_OK + && ocArgs > 0) { + for (i = 0; i < ocArgs; i++) { + char *option = ObjStr(ovArgs[i]); + if (option) { + switch (*option) { + case 'c': + if (strcmp(option, "class-invar") == 0) { + opt->checkoptions |= CHECK_CLINVAR; + } + break; + case 'o': + if (strcmp(option, "object-invar") == 0) { + opt->checkoptions |= CHECK_OBJINVAR; + } + break; + case 'p': + if (strcmp(option, "pre") == 0) { + opt->checkoptions |= CHECK_PRE; + } else if (strcmp(option, "post") == 0) { + opt->checkoptions |= CHECK_POST; + } + break; + case 'a': + if (strcmp(option, "all") == 0) { + opt->checkoptions |= CHECK_ALL; + } + break; + } + } + } + } + if (opt->checkoptions == CHECK_NONE && ocArgs>0) { + return XOTclVarErrMsg(interp, "Unknown check option in command '", + objectName(obj), " check ", ObjStr(arg), + "', valid: all pre post object-invar class-invar", + (char *) NULL); + } + return TCL_OK; +} +static void AssertionSetInvariants(Tcl_Interp *interp, XOTclAssertionStore **assertions, Tcl_Obj *arg) { + if (*assertions) + TclObjListFreeList((*assertions)->invariants); + else + *assertions = AssertionCreateStore(); + (*assertions)->invariants = AssertionNewList(interp, arg); +} + + + + + /* * Per-Object-Mixins */ @@ -5251,14 +5311,6 @@ ); # endif -#if 0 -#ifdef DISPATCH_TRACE - printExit(interp, "ProcMethodDispatch", objc, objv, result); - /* fprintf(stderr, " returnCode %d xotcl rc %d\n", - Tcl_Interp_returnCode(interp), result);*/ -#endif -#endif - opt = obj->opt; if (opt && obj->teardown && (opt->checkoptions & CHECK_POST)) { /* even, when the passed result != TCL_OK, run assertion to report @@ -5272,16 +5324,16 @@ } if (pcPtr) { -#if defined(TCL_STACK_ALLOC_TRACE) +# if defined(TCL_STACK_ALLOC_TRACE) fprintf(stderr, "---- FinalizeProcMethod calls releasePc, stackFree %p\n", pcPtr); -#endif +# endif parseContextRelease(pcPtr); TclStackFree(interp, pcPtr); } -#if defined(TCL_STACK_ALLOC_TRACE) +# if defined(TCL_STACK_ALLOC_TRACE) fprintf(stderr, "---- FinalizeProcMethod calls pop, csc free %p method %s\n", cscPtr, methodName); -#endif +# endif CallStackPop(interp, cscPtr); TclStackFree(interp, cscPtr); @@ -10355,6 +10407,59 @@ return result; } +/* TODO: MOVE ME */ +/* todo move me xxx */ +/* +xotclCmd assertion XOTclAssertionCmd { + {-argName "object" -type object} + {-argName "assertionsubcmd" -required 1 -type "check|object-invar|class-invar"} + {-argName "arg" -required 0 -type tclobj} +} + + Make "::xotcl::assertion" a cmd rather than a method, otherwise we + cannot define e.g. a "method check options {...}" to reset the check + options in case of a failed option, since assertion checking would + be applied on the sketched method already. +*/ + +static int XOTclAssertionCmd(Tcl_Interp *interp, XOTclObject *object, int subcmd, Tcl_Obj *arg) { + XOTclClass *class; + + switch (subcmd) { + case AssertionsubcmdCheckIdx: + if (arg) { + return AssertionSetCheckOptions(interp, object, arg); + } else { + return AssertionListCheckOption(interp, object); + } + break; + + case AssertionsubcmdObject_invarIdx: + if (arg) { + XOTclObjectOpt *opt = XOTclRequireObjectOpt(object); + AssertionSetInvariants(interp, &opt->assertions, arg); + } else { + if (object->opt && object->opt->assertions) { + Tcl_SetObjResult(interp, AssertionList(interp, object->opt->assertions->invariants)); + } + } + break; + + case AssertionsubcmdClass_invarIdx: + class = (XOTclClass *)object; + if (arg) { + XOTclClassOpt *opt = XOTclRequireClassOpt(class); + AssertionSetInvariants(interp, &opt->assertions, arg); + } else { + if (class->opt && class->opt->assertions) { + Tcl_SetObjResult(interp, AssertionList(interp, class->opt->assertions->invariants)); + } + } + } + return TCL_OK; +} + + static int XOTclConfigureCmd(Tcl_Interp *interp, int configureoption, Tcl_Obj *value) { int bool; @@ -10435,7 +10540,8 @@ static int -XOTclDispatchCmd(Tcl_Interp *interp, XOTclObject *object, int withObjscope, +XOTclDispatchCmd(Tcl_Interp *interp, XOTclObject *object, + int withObjscope, int withNoassertions, Tcl_Obj *command, int nobjc, Tcl_Obj *CONST nobjv[]) { int result; char *methodName = ObjStr(command); @@ -10492,7 +10598,7 @@ tail, "'", (char *) NULL); } {XOTcl_FrameDecls; - + if (withObjscope) { XOTcl_PushFrame(interp, object); } @@ -10501,6 +10607,7 @@ * vector, we can include the cmd name in the objv by using * nobjv-1; this way, we avoid a memcpy() */ + result = MethodDispatch((ClientData)object, interp, nobjc+1, nobjv-1, cmd, object, NULL /*XOTclClass *cl*/, tail, @@ -10530,6 +10637,7 @@ result = XOTclCallMethodWithArgs((ClientData)object, interp, command, arg, nobjc, objv, XOTCL_CM_NO_UNKNOWN); } + return result; } @@ -11541,52 +11649,6 @@ return TCL_OK; } -static int XOTclOCheckMethod(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *flag) { - XOTclObjectOpt *opt = XOTclRequireObjectOpt(obj); - int ocArgs, i; - Tcl_Obj **ovArgs; - opt->checkoptions = CHECK_NONE; - - if (Tcl_ListObjGetElements(interp, flag, &ocArgs, &ovArgs) == TCL_OK - && ocArgs > 0) { - for (i = 0; i < ocArgs; i++) { - char *option = ObjStr(ovArgs[i]); - if (option) { - switch (*option) { - case 'i': - if (strcmp(option, "instinvar") == 0) { - opt->checkoptions |= CHECK_CLINVAR; - } else if (strcmp(option, "invar") == 0) { - opt->checkoptions |= CHECK_OBJINVAR; - } - break; - case 'p': - if (strcmp(option, "pre") == 0) { - opt->checkoptions |= CHECK_PRE; - } else if (strcmp(option, "post") == 0) { - opt->checkoptions |= CHECK_POST; - } - break; - case 'a': - if (strcmp(option, "all") == 0) { - opt->checkoptions |= CHECK_ALL; - } - break; - } - } - } - } - if (opt->checkoptions == CHECK_NONE && ocArgs>0) { - return XOTclVarErrMsg(interp, "Unknown check option in command '", - objectName(obj), " check ", ObjStr(flag), - "', valid: all pre post invar instinvar", - (char *) NULL); - } - - Tcl_ResetResult(interp); - return TCL_OK; -} - static int XOTclOCleanupMethod(Tcl_Interp *interp, XOTclObject *obj) { XOTclClass *cl = XOTclObjectToClass(obj); char *fn; @@ -11946,18 +12008,6 @@ return result; } -static int XOTclOInvariantsMethod(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *invariantlist) { - XOTclObjectOpt *opt = XOTclRequireObjectOpt(obj); - - if (opt->assertions) - TclObjListFreeList(opt->assertions->invariants); - else - opt->assertions = AssertionCreateStore(); - - opt->assertions->invariants = AssertionNewList(interp, invariantlist); - return TCL_OK; -} - static int XOTclOMixinGuardMethod(Tcl_Interp *interp, XOTclObject *obj, char *mixin, Tcl_Obj *guard) { XOTclObjectOpt *opt = obj->opt; @@ -12477,18 +12527,6 @@ filter, " on ", className(cl), (char *) NULL); } -static int XOTclCInvariantsMethod(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *invariantlist) { - XOTclClassOpt *opt = XOTclRequireClassOpt(cl); - - if (opt->assertions) - TclObjListFreeList(opt->assertions->invariants); - else - opt->assertions = AssertionCreateStore(); - - opt->assertions->invariants = AssertionNewList(interp, invariantlist); - return TCL_OK; -} - static int XOTclCMixinGuardMethod(Tcl_Interp *interp, XOTclClass *cl, char *mixin, Tcl_Obj *guard) { XOTclClassOpt *opt = cl->opt; @@ -12633,10 +12671,6 @@ /*************************** * Begin Object Info Methods ***************************/ -static int XOTclObjInfoCheckMethod(Tcl_Interp *interp, XOTclObject *object) { - return AssertionListCheckOption(interp, object); -} - static int XOTclObjInfoChildrenMethod(Tcl_Interp *interp, XOTclObject *object, char *pattern) { return ListChildren(interp, object, pattern, 0); } @@ -12672,13 +12706,6 @@ return TCL_OK; } -static int XOTclObjInfoInvarMethod(Tcl_Interp *interp, XOTclObject *object) { - if (object->opt && object->opt->assertions) { - Tcl_SetObjResult(interp, AssertionList(interp, object->opt->assertions->invariants)); - } - return TCL_OK; -} - static int AggregatedMethodType(int methodType) { switch (methodType) { case MethodtypeNULL: /* default */ @@ -12917,15 +12944,6 @@ return ListForward(interp, Tcl_Namespace_cmdTable(class->nsPtr), pattern, withDefinition); } -static int XOTclClassInfoInvarMethod(Tcl_Interp *interp, XOTclClass * class) { - XOTclClassOpt *opt = class->opt; - - if (opt && opt->assertions) { - Tcl_SetObjResult(interp, AssertionList(interp, opt->assertions->invariants)); - } - return TCL_OK; -} - static int XOTclClassInfoMixinMethod(Tcl_Interp *interp, XOTclClass * class, int withClosure, int withGuards, char *patternString, XOTclObject *patternObj) { XOTclClassOpt *opt = class->opt; Index: generic/xotclInt.h =================================================================== diff -u -r6d8f5916b802c8890df470326886526a4b62c8a4 -r7050a52ac53992d9a3aec12e48b0fa58a26449e6 --- generic/xotclInt.h (.../xotclInt.h) (revision 6d8f5916b802c8890df470326886526a4b62c8a4) +++ generic/xotclInt.h (.../xotclInt.h) (revision 7050a52ac53992d9a3aec12e48b0fa58a26449e6) @@ -137,24 +137,8 @@ #define isInitString(m) (\ *m == 'i' && m[1] == 'n' && m[2] == 'i' && m[3] == 't' && \ m[4] == '\0') -#define isInfoString(m) (\ - *m == 'i' && m[1] == 'n' && m[2] == 'f' && m[3] == 'o' && \ - m[4] == '\0') -#define isInstinvarString(m) (\ - *m == 'i' && m[1] == 'n' && m[2] == 's' && m[3] == 't' && \ - m[4] == 'i' && m[5] == 'n' && m[6] == 'v' && m[7] == 'a' && \ - m[8] == 'r' && m[9] == '\0') -#define isInvarString(m) (\ - *m == 'i' && m[1] == 'n' && m[2] == 'v' && m[3] == 'a' && \ - m[4] == 'r' && m[5] == '\0') -#define isInstprocString(m) (\ - *m == 'i' && m[1] == 'n' && m[2] == 's' && m[3] == 't' && \ - m[4] == 'p' && m[5] == 'r' && m[6] == 'o' && m[7] == 'c' && \ - m[8] == '\0') -#define isProcString(m) (\ - *m == 'p' && m[1] == 'r' && m[2] == 'o' && m[3] == 'c' && \ - m[4] == '\0') + #if (defined(sun) || defined(__hpux)) && !defined(__GNUC__) # define USE_ALLOCA #endif Index: library/lib/xotcl1.xotcl =================================================================== diff -u -rb62dcaa16d03cd56d95a75f493cbd0de0fb5c60b -r7050a52ac53992d9a3aec12e48b0fa58a26449e6 --- library/lib/xotcl1.xotcl (.../xotcl1.xotcl) (revision b62dcaa16d03cd56d95a75f493cbd0de0fb5c60b) +++ library/lib/xotcl1.xotcl (.../xotcl1.xotcl) (revision 7050a52ac53992d9a3aec12e48b0fa58a26449e6) @@ -57,7 +57,7 @@ #puts stderr "[self] [self proc] $name defined" } - # define - like in xotcl - a minimal implementation of "method" + # define - like in XOTcl 1 - a minimal implementation of "method" Object instproc method {name arguments body} { .proc $name $arguments $body } @@ -299,6 +299,8 @@ .proc instparametercmd {o {pattern:optional ""}} { ::xotcl::cmd::ClassInfo::methods $o -methodtype setter {*}$pattern } + # assertion handling + .proc instinvar {o} {::xotcl::assertion $o class-invar} } objectInfo eval { @@ -329,6 +331,11 @@ if {[::info exists pattern]} {lappend cmd $pattern} eval $cmd } + # assertion handling + .proc check {o} { + ::xotcl::checkoption_internal_to_xotcl1 [::xotcl::assertion $o check] + } + .proc invar {o} {::xotcl::assertion $o object-invar} } foreach cmd [::info command ::xotcl::cmd::ObjectInfo::*] { @@ -355,8 +362,10 @@ ::xotcl::alias ::xotcl::classInfo instfilter ::xotcl::cmd::ClassInfo::filter ::xotcl::alias ::xotcl::classInfo instfilterguard ::xotcl::cmd::ClassInfo::filterguard ::xotcl::alias ::xotcl::classInfo instforward ::xotcl::cmd::ClassInfo::forward - ::xotcl::alias ::xotcl::classInfo instinvar ::xotcl::cmd::ClassInfo::invar ::xotcl::alias ::xotcl::classInfo mixinof ::xotcl::cmd::ClassInfo::object-mixin-of + # assertion handling + ::xotcl::alias ::xotcl::classInfo invar objectInfo::invar + ::xotcl::alias ::xotcl::classInfo check objectInfo::check # define info methods from objectInfo on classInfo as well ::xotcl::alias classInfo body objectInfo::body @@ -391,6 +400,40 @@ ::xotcl::alias Class mixinguard ::xotcl::cmd::Object::mixinguard ::xotcl::alias Class instmixinguard ::xotcl::cmd::Class::mixinguard + # assertion handling + proc checkoption_xotcl1_to_internal checkoptions { + set options [list] + foreach option $checkoptions { + if {$option eq "invar"} { + lappend options "object-invar" + } elseif {$option eq "instinvar"} { + lappend options "class-invar" + } else { + lappend options $option + } + } + return $options + } + proc checkoption_internal_to_xotcl1 checkoptions { + set options [list] + foreach option $checkoptions { + if {$option eq "object-invar"} { + lappend options "invar" + } elseif {$option eq "class-invar"} { + lappend options "instinvar" + } else { + lappend options $option + } + } + return $options + } + + Object instproc check {checkoptions} { + ::xotcl::assertion [self] check [::xotcl::checkoption_xotcl1_to_internal $checkoptions] + } + Object forward invar ::xotcl::assertion %self object-invar + Class forward instinvar ::xotcl::assertion %self class-invar + # define forward and instforward in terms of forward # we are changing the the semantics from forward -> instforward, # this has to be done at the end to avoid confusion with the Index: library/serialize/Serializer.xotcl =================================================================== diff -u -r6d8f5916b802c8890df470326886526a4b62c8a4 -r7050a52ac53992d9a3aec12e48b0fa58a26449e6 --- library/serialize/Serializer.xotcl (.../Serializer.xotcl) (revision 6d8f5916b802c8890df470326886526a4b62c8a4) +++ library/serialize/Serializer.xotcl (.../Serializer.xotcl) (revision 7050a52ac53992d9a3aec12e48b0fa58a26449e6) @@ -229,10 +229,10 @@ append cmd \t [my pcmd $setcmd] " \\\n" } } - foreach x {mixin invar} { - set v [$o info $x] - if {$v ne ""} {my append post_cmds [list $o $x set $v] "\n"} - } + set v [$o info mixin] + if {$v ne ""} {my append post_cmds [list $o mixin set $v] "\n"} + set v [::xotcl::assertion $o object-invar] + if {$v ne ""} {my append post_cmds [list ::xotcl::assertion $o object-invar $v] "\n"} set v [$o info filter -guards] if {$v ne ""} {append cmd [my pcmd [list filter $v]] " \\\n"} return $cmd Index: tests/testx.xotcl =================================================================== diff -u -r5b0ee985a6ff266c1246c8ade3e86c33956ac772 -r7050a52ac53992d9a3aec12e48b0fa58a26449e6 --- tests/testx.xotcl (.../testx.xotcl) (revision 5b0ee985a6ff266c1246c8ade3e86c33956ac772) +++ tests/testx.xotcl (.../testx.xotcl) (revision 7050a52ac53992d9a3aec12e48b0fa58a26449e6) @@ -136,15 +136,16 @@ TestX assertions -proc run {{n 20}} { for {set i 0} {$i < $n} {incr i} { Class C($i) - C($i) invar { + + set r [C($i) invar { {$a > 2} {$c < 3} {$d > 5} {#a } {#b } - } + }] + C($i) instinvar { {$a > 2} {$c < 3} {$d > 5} {#a } {#b } } - ::errorCheck [C($i) info invar] {{$a > 2} {$c < 3} {$d > 5} {#a } {#b }} \ "Class invar " @@ -3103,13 +3104,13 @@ ::errorCheck [lsort [b info methods]] "__next abstract append array autoname check class cleanup configure contains copy defaultmethod destroy eval exists extractConfigureArg f filter filterguard filtersearch forward hasclass incr info init instvar invar isclass ismetaclass ismixin isobject istype lappend method mixin mixinguard move myProc myProc2 myProcMix1 myProcMix2 noinit objectparameter objproc parametercmd proc procsearch requireNamespace residualargs self set setFilter signature subst trace unknown unset uplevel upvar volatile vwait" "b info methods" - ::errorCheck [lsort [b info methods -nocmds]] "abstract contains copy defaultmethod extractConfigureArg f hasclass init isclass ismetaclass ismixin isobject istype method move myProc myProc2 myProcMix1 myProcMix2 objectparameter objproc parametercmd proc procsearch self setFilter signature unknown" "b info methods -nocmds" + ::errorCheck [lsort [b info methods -nocmds]] "abstract check contains copy defaultmethod extractConfigureArg f hasclass init isclass ismetaclass ismixin isobject istype method move myProc myProc2 myProcMix1 myProcMix2 objectparameter objproc parametercmd proc procsearch self setFilter signature unknown" "b info methods -nocmds" - ::errorCheck [lsort [b info methods -noprocs]] "__next append array autoname check class cleanup configure destroy eval exists filter filterguard filtersearch forward incr info instvar invar lappend mixin mixinguard noinit requireNamespace residualargs set subst trace unset uplevel upvar volatile vwait" "b info methods -noprocs" - ::errorCheck [lsort [b info methods -nocmds -nomixins]] "abstract contains copy defaultmethod extractConfigureArg f hasclass init isclass ismetaclass ismixin isobject istype method move myProc myProc2 objectparameter objproc parametercmd proc procsearch self setFilter signature unknown" "b info methods -nocmds -nomixins" + ::errorCheck [lsort [b info methods -noprocs]] "__next append array autoname class cleanup configure destroy eval exists filter filterguard filtersearch forward incr info instvar invar lappend mixin mixinguard noinit requireNamespace residualargs set subst trace unset uplevel upvar volatile vwait" "b info methods -noprocs" + ::errorCheck [lsort [b info methods -nocmds -nomixins]] "abstract check contains copy defaultmethod extractConfigureArg f hasclass init isclass ismetaclass ismixin isobject istype method move myProc myProc2 objectparameter objproc parametercmd proc procsearch self setFilter signature unknown" "b info methods -nocmds -nomixins" ::errorCheck [b info methods -nocmds -noprocs] "" "b info methods -nocmds -noprocs" - ::errorCheck [lsort [B info methods -nocmds]] "abstract allinstances contains copy defaultmethod extractConfigureArg f hasclass init instparametercmd instproc isclass ismetaclass ismixin isobject istype method move objectparameter parameter parametercmd proc procsearch self setFilter signature unknown uses" "B info methods -nocmds" + ::errorCheck [lsort [B info methods -nocmds]] "abstract allinstances check contains copy defaultmethod extractConfigureArg f hasclass init instparametercmd instproc isclass ismetaclass ismixin isobject istype method move objectparameter parameter parametercmd proc procsearch self setFilter signature unknown uses" "B info methods -nocmds" namespace eval a { proc o args {return o}
XOTcl 1XOTcl 2
objectName check checkptions::xotcl::assertion objectName check checkptions
objectName info check::xotcl::assertion objectName check
objectName invar conditions::xotcl::assertion objectName object-invar conditions
objectName info invar::xotcl::assertion objectName object-invar
className instinvar conditions::xotcl::assertion className class-invar conditions
className info instinvar::xotcl::assertion className class-invar
className invar conditions::xotcl::assertion className object-invar conditions
className info invar::xotcl::assertion className object-invar