Index: ChangeLog =================================================================== diff -u -rc7463312d92f53e9d3815408fe9537e9755cab8b -rc990d14157d8434cd5b1ee5f45aa43f82cb911b5 --- ChangeLog (.../ChangeLog) (revision c7463312d92f53e9d3815408fe9537e9755cab8b) +++ ChangeLog (.../ChangeLog) (revision c990d14157d8434cd5b1ee5f45aa43f82cb911b5) @@ -62,6 +62,12 @@ Meta C -superclass O -parameter {a {b -default ""} {c -default 1}} C c1 ;# c1 has no no default value for "a", before it had ====== +2009-06-29 + - !!! removed obsolete features + * ability to specify nonpos args and pos args as different arguments + * compile flags AUTOVARS, REFCOUNTED, REFCOUNT_TRACE + - added -flags with one argument + type + - generated all class methods from interface descriptions 2009-06-28 - objv-stubs for all 23 class info methods Index: generic/gentclAPI.tcl =================================================================== diff -u -rc7463312d92f53e9d3815408fe9537e9755cab8b -rc990d14157d8434cd5b1ee5f45aa43f82cb911b5 --- generic/gentclAPI.tcl (.../gentclAPI.tcl) (revision c7463312d92f53e9d3815408fe9537e9755cab8b) +++ generic/gentclAPI.tcl (.../gentclAPI.tcl) (revision c990d14157d8434cd5b1ee5f45aa43f82cb911b5) @@ -14,7 +14,7 @@ "" {set type NULL} default {set type "\"$(-type)\""} } - lappend l "{\"$(-argName)\", $(-required), $(-nrArgs), $type}" + lappend l "{\"$(-argName)\", $(-required), $(-nrargs), $type}" } join $l ",\n " } @@ -34,6 +34,15 @@ set varName with[string totitle $switchName] set calledArg $varName set type "int " + if {$(-nrargs) == 1} { + switch $(-type) { + "" {set type "char *"} + "class" {set type "XOTclClass *"} + "object" {set type "XOTclObject *"} + "tclobj" {set type "Tcl_Obj *"} + default {error "type '$(-type)' not allowed for parameter"} + } + } } else { set varName $(-argName) set calledArg $varName @@ -44,7 +53,7 @@ "tclobj" {set type "Tcl_Obj *"} "args" { set type "int " - set calledArg "objc-pc.args, objv+pc.args" + set calledArg "objc-pc.lastobjc, objv+pc.lastobjc" lappend if "int nobjc" "Tcl_Obj *CONST nobjv\[\]" set ifSet 1 set cVar 0 @@ -73,6 +82,7 @@ # } # }] } + default {error "type '$(-type)' not allowed for argument"} } } if {!$ifSet} {lappend if "$type$varName"} @@ -139,7 +149,7 @@ typedef struct { char *methodName; Tcl_ObjCmdProc *proc; - interfaceDefinition ifd; + CONST interfaceDefinition ifd; } methodDefinition2; static int parse2(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], @@ -170,7 +180,7 @@ } set completed [list] foreach argDefinition $argDefinitions { - array set "" {-required 0 -nrArgs 0 -type ""} + array set "" {-required 0 -nrargs 0 -type ""} array set "" $argDefinition lappend completed [array get ""] } @@ -207,8 +217,59 @@ classMethod dealloc XOTclCDeallocMethod { {-argName "object" -required 1 -type tclobj} } +classMethod new XOTclCNewMethod { + {-argName "-childof" -type object -nrargs 1} + {-argName "args" -required 0 -type args} +} +classMethod instfilterguard XOTclCInstFilterGuardMethod { + {-argName "filter" -required 1} + {-argName "guard" -required 1 -type tclobj} +} +classMethod instinvar XOTclCInvariantsMethod { + {-argName "invariantlist" -required 1 -type tclobj} +} +classMethod instmixinguard XOTclCInstMixinGuardMethod { + {-argName "mixin" -required 1} + {-argName "guard" -required 1 -type tclobj} +} +classMethod instparametercmd XOTclCInstParameterCmdMethod { + {-argName "name" -required 1} +} +classMethod instproc XOTclCInstProcMethod { + {-argName "name" -required 1 -type tclobj} + {-argName "args" -required 1 -type tclobj} + {-argName "body" -required 1 -type tclobj} + {-argName "precondition" -type tclobj} + {-argName "postcondition" -type tclobj} +} +classMethod classscopedinstproc XOTclCInstProcMethodC { + {-argName "name" -required 1 -type tclobj} + {-argName "args" -required 1 -type tclobj} + {-argName "body" -required 1 -type tclobj} + {-argName "precondition" -type tclobj} + {-argName "postcondition" -type tclobj} +} +classMethod instforward XOTclCInstForwardMethod { + {-argName "method" -required 1 -type tclobj} + {-argName "-default" -nrargs 1 -type tclobj} + {-argName "-earlybinding"} + {-argName "-methodprefix" -nrargs 1 -type tclobj} + {-argName "-objscope"} + {-argName "-onerror" -nrargs 1 -type tclobj} + {-argName "-verbose" -nrargs 0} + {-argName "target" -type tclobj -required 0} + {-argName "args" -type args} +} +# todo -protected for XOTclCInstForwardMethod +classMethod recreate XOTclCRecreateMethod { + {-argName "name" -required 1 -type tclobj} + {-argName "args" -required 1 -type allargs} +} +classMethod unknown XOTclCUnknownMethod { + {-argName "name" -required 1} + {-argName "args" -required 1 -type allargs} +} - # # check methods # Index: generic/predefined.xotcl =================================================================== diff -u -r80dbbc5075b96ca2d25ebf426204398f68411e17 -rc990d14157d8434cd5b1ee5f45aa43f82cb911b5 --- generic/predefined.xotcl (.../predefined.xotcl) (revision 80dbbc5075b96ca2d25ebf426204398f68411e17) +++ generic/predefined.xotcl (.../predefined.xotcl) (revision c990d14157d8434cd5b1ee5f45aa43f82cb911b5) @@ -104,6 +104,7 @@ ::xotcl::alias ::xotcl::classInfo classparent ::xotcl::cmd::ObjectInfo::parent ::xotcl::alias ::xotcl::classInfo classchildren ::xotcl::cmd::ObjectInfo::children unset cmd + ::xotcl::Object instforward info -onerror ::xotcl::infoError ::xotcl::objectInfo %1 {%@2 %self} ::xotcl::Class instforward info -onerror ::xotcl::infoError ::xotcl::classInfo %1 {%@2 %self} @@ -265,6 +266,7 @@ if {$domain eq ""} { set domain [::xotcl::self callingobject] } + #puts stderr "???? $domain $forwarder $name -default [$manager defaultmethods] $manager %1 %self %proc" $domain $forwarder $name -default [$manager defaultmethods] $manager %1 %self %proc } @@ -343,9 +345,9 @@ ::xotcl::alias ::xotcl::Object::slot::class assign ::xotcl::relation ::xotcl::InterceptorSlot create ::xotcl::Object::slot::mixin -::xotcl::InterceptorSlot create ::xotcl::Object::slot::filter -elementtype "" + ::xotcl::InterceptorSlot create ::xotcl::Object::slot::filter -elementtype "" ::xotcl::InterceptorSlot create ::xotcl::Class::slot::instmixin -::xotcl::InterceptorSlot create ::xotcl::Class::slot::instfilter -elementtype "" + ::xotcl::InterceptorSlot create ::xotcl::Class::slot::instfilter -elementtype "" # # Attribute Index: generic/tclAPI.h =================================================================== diff -u -rc7463312d92f53e9d3815408fe9537e9755cab8b -rc990d14157d8434cd5b1ee5f45aa43f82cb911b5 --- generic/tclAPI.h (.../tclAPI.h) (revision c7463312d92f53e9d3815408fe9537e9755cab8b) +++ generic/tclAPI.h (.../tclAPI.h) (revision c990d14157d8434cd5b1ee5f45aa43f82cb911b5) @@ -2,7 +2,7 @@ typedef struct { char *methodName; Tcl_ObjCmdProc *proc; - interfaceDefinition ifd; + CONST interfaceDefinition ifd; } methodDefinition2; static int parse2(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], @@ -16,6 +16,16 @@ static int XOTclCAllocMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCCreateMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCDeallocMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); +static int XOTclCInstFilterGuardMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); +static int XOTclCInstForwardMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); +static int XOTclCInstMixinGuardMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); +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 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 []); +static int XOTclCUnknownMethodStub(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 XOTclClassInfoInstargsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); @@ -69,6 +79,16 @@ static int XOTclCAllocMethod(Tcl_Interp *interp, XOTclClass *cl, char *name); static int XOTclCCreateMethod(Tcl_Interp *interp, XOTclClass *cl, char *name, int objc, Tcl_Obj *CONST objv[]); static int XOTclCDeallocMethod(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *object); +static int XOTclCInstFilterGuardMethod(Tcl_Interp *interp, XOTclClass *cl, char *filter, Tcl_Obj *guard); +static int XOTclCInstForwardMethod(Tcl_Interp *interp, XOTclClass *cl, 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 XOTclCInstMixinGuardMethod(Tcl_Interp *interp, XOTclClass *cl, char *mixin, Tcl_Obj *guard); +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 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[]); +static int XOTclCUnknownMethod(Tcl_Interp *interp, XOTclClass *cl, char *name, int objc, Tcl_Obj *CONST objv[]); 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 XOTclClassInfoInstargsMethod(Tcl_Interp *interp, XOTclClass *class, char *methodName); @@ -123,6 +143,16 @@ XOTclCAllocMethodIdx, XOTclCCreateMethodIdx, XOTclCDeallocMethodIdx, + XOTclCInstFilterGuardMethodIdx, + XOTclCInstForwardMethodIdx, + XOTclCInstMixinGuardMethodIdx, + XOTclCInstParameterCmdMethodIdx, + XOTclCInstProcMethodIdx, + XOTclCInstProcMethodCIdx, + XOTclCInvariantsMethodIdx, + XOTclCNewMethodIdx, + XOTclCRecreateMethodIdx, + XOTclCUnknownMethodIdx, XOTclClassInfoHeritageMethodIdx, XOTclClassInfoInstancesMethodIdx, XOTclClassInfoInstargsMethodIdx, @@ -249,6 +279,173 @@ } static int +XOTclCInstFilterGuardMethodStub(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 (parse2(interp, objc, objv, XOTclCInstFilterGuardMethodIdx, &pc) != TCL_OK) { + return TCL_ERROR; + } else { + char * filter = (char *)pc.clientData[0]; + Tcl_Obj * guard = (Tcl_Obj *)pc.clientData[1]; + + return XOTclCInstFilterGuardMethod(interp, cl, filter, guard); + + } +} + +static int +XOTclCInstForwardMethodStub(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 (parse2(interp, objc, objv, XOTclCInstForwardMethodIdx, &pc) != TCL_OK) { + return TCL_ERROR; + } else { + Tcl_Obj * method = (Tcl_Obj *)pc.clientData[0]; + Tcl_Obj * withDefault = (Tcl_Obj *)pc.clientData[1]; + int withEarlybinding = (int )pc.clientData[2]; + Tcl_Obj * withMethodprefix = (Tcl_Obj *)pc.clientData[3]; + int withObjscope = (int )pc.clientData[4]; + Tcl_Obj * withOnerror = (Tcl_Obj *)pc.clientData[5]; + int withVerbose = (int )pc.clientData[6]; + Tcl_Obj * target = (Tcl_Obj *)pc.clientData[7]; + + return XOTclCInstForwardMethod(interp, cl, method, withDefault, withEarlybinding, withMethodprefix, withObjscope, withOnerror, withVerbose, target, objc-pc.lastobjc, objv+pc.lastobjc); + + } +} + +static int +XOTclCInstMixinGuardMethodStub(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 (parse2(interp, objc, objv, XOTclCInstMixinGuardMethodIdx, &pc) != TCL_OK) { + return TCL_ERROR; + } else { + char * mixin = (char *)pc.clientData[0]; + Tcl_Obj * guard = (Tcl_Obj *)pc.clientData[1]; + + return XOTclCInstMixinGuardMethod(interp, cl, mixin, guard); + + } +} + +static int +XOTclCInstParameterCmdMethodStub(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 (parse2(interp, objc, objv, XOTclCInstParameterCmdMethodIdx, &pc) != TCL_OK) { + return TCL_ERROR; + } else { + char * name = (char *)pc.clientData[0]; + + return XOTclCInstParameterCmdMethod(interp, cl, name); + + } +} + +static int +XOTclCInstProcMethodStub(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 (parse2(interp, objc, objv, XOTclCInstProcMethodIdx, &pc) != TCL_OK) { + return TCL_ERROR; + } else { + Tcl_Obj * name = (Tcl_Obj *)pc.clientData[0]; + Tcl_Obj * args = (Tcl_Obj *)pc.clientData[1]; + Tcl_Obj * body = (Tcl_Obj *)pc.clientData[2]; + Tcl_Obj * precondition = (Tcl_Obj *)pc.clientData[3]; + Tcl_Obj * postcondition = (Tcl_Obj *)pc.clientData[4]; + + return XOTclCInstProcMethod(interp, cl, name, args, body, precondition, postcondition); + + } +} + +static int +XOTclCInstProcMethodCStub(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 (parse2(interp, objc, objv, XOTclCInstProcMethodCIdx, &pc) != TCL_OK) { + return TCL_ERROR; + } else { + Tcl_Obj * name = (Tcl_Obj *)pc.clientData[0]; + Tcl_Obj * args = (Tcl_Obj *)pc.clientData[1]; + Tcl_Obj * body = (Tcl_Obj *)pc.clientData[2]; + Tcl_Obj * precondition = (Tcl_Obj *)pc.clientData[3]; + Tcl_Obj * postcondition = (Tcl_Obj *)pc.clientData[4]; + + return XOTclCInstProcMethodC(interp, cl, name, args, body, precondition, postcondition); + + } +} + +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 (parse2(interp, objc, objv, XOTclCInvariantsMethodIdx, &pc) != TCL_OK) { + return TCL_ERROR; + } else { + Tcl_Obj * invariantlist = (Tcl_Obj *)pc.clientData[0]; + + return XOTclCInvariantsMethod(interp, cl, invariantlist); + + } +} + +static int +XOTclCNewMethodStub(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 (parse2(interp, objc, objv, XOTclCNewMethodIdx, &pc) != TCL_OK) { + return TCL_ERROR; + } else { + XOTclObject * withChildof = (XOTclObject *)pc.clientData[0]; + + return XOTclCNewMethod(interp, cl, withChildof, objc-pc.lastobjc, objv+pc.lastobjc); + + } +} + +static int +XOTclCRecreateMethodStub(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 (parse2(interp, objc, objv, XOTclCRecreateMethodIdx, &pc) != TCL_OK) { + return TCL_ERROR; + } else { + Tcl_Obj * name = (Tcl_Obj *)pc.clientData[0]; + + return XOTclCRecreateMethod(interp, cl, name, objc, objv); + + } +} + +static int +XOTclCUnknownMethodStub(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 (parse2(interp, objc, objv, XOTclCUnknownMethodIdx, &pc) != TCL_OK) { + return TCL_ERROR; + } else { + char * name = (char *)pc.clientData[0]; + + return XOTclCUnknownMethod(interp, cl, name, objc, objv); + + } +} + +static int XOTclClassInfoHeritageMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; @@ -1023,6 +1220,57 @@ {"dealloc", XOTclCDeallocMethodStub, { {"object", 1, 0, "tclobj"}} }, +{"instfilterguard", XOTclCInstFilterGuardMethodStub, { + {"filter", 1, 0, NULL}, + {"guard", 1, 0, "tclobj"}} +}, +{"instforward", XOTclCInstForwardMethodStub, { + {"method", 1, 0, "tclobj"}, + {"-default", 0, 1, "tclobj"}, + {"-earlybinding", 0, 0, NULL}, + {"-methodprefix", 0, 1, "tclobj"}, + {"-objscope", 0, 0, NULL}, + {"-onerror", 0, 1, "tclobj"}, + {"-verbose", 0, 0, NULL}, + {"target", 0, 0, "tclobj"}, + {"args", 0, 0, "args"}} +}, +{"instmixinguard", XOTclCInstMixinGuardMethodStub, { + {"mixin", 1, 0, NULL}, + {"guard", 1, 0, "tclobj"}} +}, +{"instparametercmd", XOTclCInstParameterCmdMethodStub, { + {"name", 1, 0, NULL}} +}, +{"instproc", XOTclCInstProcMethodStub, { + {"name", 1, 0, "tclobj"}, + {"args", 1, 0, "tclobj"}, + {"body", 1, 0, "tclobj"}, + {"precondition", 0, 0, "tclobj"}, + {"postcondition", 0, 0, "tclobj"}} +}, +{"classscopedinstproc", XOTclCInstProcMethodCStub, { + {"name", 1, 0, "tclobj"}, + {"args", 1, 0, "tclobj"}, + {"body", 1, 0, "tclobj"}, + {"precondition", 0, 0, "tclobj"}, + {"postcondition", 0, 0, "tclobj"}} +}, +{"instinvar", XOTclCInvariantsMethodStub, { + {"invariantlist", 1, 0, "tclobj"}} +}, +{"new", XOTclCNewMethodStub, { + {"-childof", 0, 1, "object"}, + {"args", 0, 0, "args"}} +}, +{"recreate", XOTclCRecreateMethodStub, { + {"name", 1, 0, "tclobj"}, + {"args", 1, 0, "allargs"}} +}, +{"unknown", XOTclCUnknownMethodStub, { + {"name", 1, 0, NULL}, + {"args", 1, 0, "allargs"}} +}, {"instances", XOTclClassInfoHeritageMethodStub, { {"class", 1, 0, "class"}, {"pattern", 0, 0, NULL}} Index: generic/xotcl.c =================================================================== diff -u -rc7463312d92f53e9d3815408fe9537e9755cab8b -rc990d14157d8434cd5b1ee5f45aa43f82cb911b5 --- generic/xotcl.c (.../xotcl.c) (revision c7463312d92f53e9d3815408fe9537e9755cab8b) +++ generic/xotcl.c (.../xotcl.c) (revision c990d14157d8434cd5b1ee5f45aa43f82cb911b5) @@ -818,23 +818,13 @@ static void XOTclCleanupObject(XOTclObject *obj) { XOTclObjectRefCountDecr(obj); -#if REFCOUNT_TRACE - fprintf(stderr,"###CLNO %p refcount = %d\n", obj, obj->refCount); -#endif + if (obj->refCount <= 0) { assert(obj->refCount == 0); assert(obj->flags & XOTCL_DESTROYED); -#if REFCOUNT_TRACE - fprintf(stderr,"###CLNO %p flags %x rc %d destr %d dc %d\n", - obj, obj->flags, - (obj->flags & XOTCL_REFCOUNTED) != 0, - (obj->flags & XOTCL_DESTROYED) != 0, - (obj->flags & XOTCL_DESTROY_CALLED) != 0 - ); -#endif MEM_COUNT_FREE("XOTclObject/XOTclClass", obj); -#if defined(XOTCLOBJ_TRACE) || defined(REFCOUNT_TRACE) +#if defined(XOTCLOBJ_TRACE) fprintf(stderr, "CKFREE Object %p refcount=%d\n", obj, obj->refCount); #endif #if !defined(NDEBUG) @@ -867,38 +857,9 @@ fprintf(stderr,"FIP --- tcl %p (%d)\n", objPtr, objPtr->refCount); #endif -#if !defined(REFCOUNTED) if (obj) { XOTclCleanupObject(obj); } -#else - if (obj) { -#if REFCOUNT_TRACE - fprintf(stderr, "FIP in %p\n", obj->teardown); - fprintf(stderr, "FIP call is destroy %d\n", RUNTIME_STATE(obj->teardown)->callIsDestroy); - fprintf(stderr,"FIP %p flags %x rc %d destr %d dc %d refcount = %d\n", - obj, obj->flags, - (obj->flags & XOTCL_REFCOUNTED) != 0, - (obj->flags & XOTCL_DESTROYED) != 0, - (obj->flags & XOTCL_DESTROY_CALLED) != 0, - obj->refCount - ); -#endif - if (obj->flags & XOTCL_REFCOUNTED && - !(obj->flags & XOTCL_DESTROY_CALLED)) { - Tcl_Interp *interp = obj->teardown; - INCR_REF_COUNT(obj->cmdName); - callDestroyMethod((ClientData)obj, interp, obj, 0); - /* the call to cleanup is the counterpart of the - INCR_REF_COUNT(obj->cmdName) above */ - XOTclCleanupObject(obj); - } else { - fprintf(stderr, "BEFORE CLEANUPOBJ %x\n", (obj->flags & XOTCL_REFCOUNTED)); - XOTclCleanupObject(obj); - fprintf(stderr, "AFTER CLEANUPOBJ\n"); - } - } -#endif objPtr->internalRep.otherValuePtr = NULL; objPtr->typePtr = NULL; } @@ -5629,19 +5590,13 @@ Tcl_Obj *cmdName = obj->cmdName; XOTclCallStack *cs = &rst->cs; /* int isdestroy = (objv[1] == XOTclGlobalObjects[XOTE_DESTROY]); */ -#ifdef AUTOVARS - int isNext; -#endif assert(objc>0); methodName = ObjStr(objv[1]); /*fprintf(stderr,"DoDispatch obj = %s objc = %d 0=%s methodName=%s\n", objectName(obj), objc, ObjStr(objv[0]), methodName);*/ -#ifdef AUTOVARS - isNext = isNextString(methodName); -#endif #ifdef DISPATCH_TRACE printCall(interp,"DISPATCH", objc, objv); #endif @@ -5665,9 +5620,6 @@ if (!(objflags & XOTCL_MIXIN_ORDER_VALID)) MixinComputeDefined(interp, obj); -#ifdef AUTOVARS - if (!isNext) { -#endif /* Only start new filter chain, if (a) filters are defined and (b) the toplevel csc entry is not an filter on self @@ -5716,9 +5668,6 @@ } } -#ifdef AUTOVARS - } -#endif /* if no filter/mixin is found => do ordinary method lookup */ if (cmd == NULL) { @@ -6243,18 +6192,6 @@ } -#ifdef AUTOVARS - { char *p, *body; - body = ObjStr(ov[3]); - if ((p = strstr(body, "self")) && p != body && *(p-1) != '[') - Tcl_AppendStringsToObj(ov[3], "::set self [self]\n", (char *) NULL); - if (strstr(body, "proc")) - Tcl_AppendStringsToObj(ov[3], "::set proc [self proc]\n", (char *) NULL); - if (strstr(body, "class")) - Tcl_AppendStringsToObj(ov[3], "::set class [self class]\n", (char *) NULL); - } -#endif - Tcl_PushCallFrame(interp,(Tcl_CallFrame *)framePtr, ns, 0); result = Tcl_ProcObjCmd(0, interp, 4, ov) != TCL_OK; @@ -7796,22 +7733,8 @@ obj->flags |= XOTCL_DESTROYED; objTrace("ODestroy", obj); -#if REFCOUNT_TRACE - fprintf(stderr,"ODestroy %p flags %d rc %d destr %d dc %d\n", - obj, obj->flags, - (obj->flags & XOTCL_REFCOUNTED) != 0, - (obj->flags & XOTCL_DESTROYED) != 0, - (obj->flags & XOTCL_DESTROY_CALLED) != 0 - ); -#endif -#if REFCOUNTED - if (!(obj->flags & XOTCL_REFCOUNTED)) { - DECR_REF_COUNT(obj->cmdName); - } -#else - DECR_REF_COUNT(obj->cmdName); -#endif + DECR_REF_COUNT(obj->cmdName); XOTclCleanupObject(obj); #if !defined(NDEBUG) @@ -9167,17 +9090,33 @@ return result; } -extern void -XOTclRemovePMethod(Tcl_Interp *interp, XOTcl_Object *obji, char *nm) { +extern int +XOTclRemovePMethod(Tcl_Interp *interp, XOTcl_Object *obji, char *name) { XOTclObject *obj = (XOTclObject*) obji; - if (obj->nsPtr) - NSDeleteCmd(interp, obj->nsPtr, nm); + + if (obj->nsPtr) { + int rc = NSDeleteCmd(interp, obj->nsPtr, name); + if (rc < 0) + return XOTclVarErrMsg(interp, objectName(obj), " cannot delete method '", name, + "' of object ", objectName(obj), (char *) NULL); + } + return TCL_OK; } -extern void -XOTclRemoveIMethod(Tcl_Interp *interp, XOTcl_Class *cli, char *nm) { +extern int +XOTclRemoveIMethod(Tcl_Interp *interp, XOTcl_Class *cli, char *name) { XOTclClass *cl = (XOTclClass*) cli; - NSDeleteCmd(interp, cl->nsPtr, nm); + XOTclClassOpt *opt = cl->opt; + int rc; + + if (opt && opt->assertions) + AssertionRemoveProc(opt->assertions, name); + + rc = NSDeleteCmd(interp, cl->nsPtr, name); + if (rc < 0) + return XOTclVarErrMsg(interp, className(cl), " cannot delete method '", name, + "' of class ", className(cl), (char *) NULL); + return TCL_OK; } /* @@ -10945,7 +10884,7 @@ */ newobj = XOTclpGetObject(interp, objName); - /*fprintf(stderr,"+++ create objv[1] '%s', specifiedName '%s', newObj=%p ismeta(%s) %d, ismeta(%s) %d\n", + /*fprintf(stderr,"+++ createspecifiedName '%s', objName '%s', newObj=%p ismeta(%s) %d, ismeta(%s) %d\n", specifiedName, objName, newobj, className(cl), IsMetaClass(interp, cl, 1), newobj ? ObjStr(newobj->cl->object.cmdName) : "NULL", @@ -10961,8 +10900,8 @@ if (newobj && (IsMetaClass(interp, cl, 1) == IsMetaClass(interp, newobj->cl, 1))) { - /*fprintf(stderr, "%%%% recreate, call recreate method ... %s, objc=%d\n", - ObjStr(tov[1]), objc+1);*/ + /* fprintf(stderr, "%%%% recreate, call recreate method ... %s, objc=%d\n", + ObjStr(tov[1]), objc+1);*/ /* call recreate --> initialization */ result = callMethod((ClientData) cl, interp, @@ -11004,138 +10943,21 @@ } create_method_exit: - /* fprintf(stderr, "create -- end ... %s\n", ObjStr(tov[1]));*/ + /*fprintf(stderr, "create -- end ... %s => %d\n", ObjStr(tov[1]),result);*/ if (tmpObj) {DECR_REF_COUNT(tmpObj);} FREE_ON_STACK(tov); return result; } -static int -XOTclCNewMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(clientData); - XOTclObject *child = NULL; - Tcl_Obj *fullname; - int result, offset = 1, -#if REFCOUNTED - isrefcount = 0, -#endif - i, prefixLength; - Tcl_DString dFullname, *dsPtr = &dFullname; - XOTclStringIncrStruct *iss = &RUNTIME_STATE(interp)->iss; - if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); - if (objc < 1) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], "[-childof obj] ?args?"); - for (i=1; ilength; - - while (1) { - (void)XOTclStringIncr(iss); - Tcl_DStringAppend(dsPtr, iss->start, iss->length); - if (!Tcl_FindCommand(interp, Tcl_DStringValue(dsPtr), NULL, 0)) { - break; - } - /* in case the value existed already, reset prefix to the - original length */ - Tcl_DStringSetLength(dsPtr, prefixLength); - } - - fullname = Tcl_NewStringObj(Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr)); - - INCR_REF_COUNT(fullname); - - objc -= offset; - { - ALLOC_ON_STACK(Tcl_Obj*, objc+3, ov); - - ov[0] = objv[0]; - ov[1] = XOTclGlobalObjects[XOTE_CREATE]; - ov[2] = fullname; - if (objc >= 1) - memcpy(ov+3, objv+offset, sizeof(Tcl_Obj *)*objc); - - result = DoDispatch(clientData, interp, objc+3, ov, 0); - FREE_ON_STACK(ov); - } - -#if REFCOUNTED - if (result == TCL_OK) { - if (isrefcount) { - Tcl_Obj *obj = Tcl_GetObjResult(interp); - XOTclObject *o = (XOTclObject*) obj->internalRep.otherValuePtr; - o->flags |= XOTCL_REFCOUNTED; - o->teardown = in; - DECR_REF_COUNT(obj); - } - } -#endif - - DECR_REF_COUNT(fullname); - Tcl_DStringFree(dsPtr); - - return result; -} - - -static int -XOTclCRecreateMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(clientData); - XOTclObject *newobj; - int result; - - if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); - if (objc < 2) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], " ?args?"); - - if (XOTclObjConvertObject(interp, objv[1], &newobj) != TCL_OK) - return XOTclVarErrMsg(interp, "can't recreate not existing obj ", - ObjStr(objv[1]), (char *) NULL); - - INCR_REF_COUNT(objv[1]); - newobj->flags |= XOTCL_RECREATE; - - result = doCleanup(interp, newobj, &cl->object, objc, objv); - if (result == TCL_OK) { - result = doObjInitialization(interp, newobj, objc, objv); - if (result == TCL_OK) - Tcl_SetObjResult(interp, objv[1]); - } - DECR_REF_COUNT(objv[1]); - return result; -} - - - - typedef struct { ClientData clientData[10]; Tcl_Obj *objv[10]; - int args; + int lastobjc; } parseContext; typedef struct { @@ -11150,6 +10972,12 @@ static int convertToType(Tcl_Interp *interp, Tcl_Obj *objPtr, char *type, ClientData *clientData, int *varArgs) { + + if (type == NULL) { + *clientData = (char *)ObjStr(objPtr); + return TCL_OK; + } + switch (*type) { case 'a': if (strcmp(type,"allargs") == 0 || strcmp(type,"args") == 0) { @@ -11212,14 +11040,19 @@ static int parse2(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int idx, parseContext *pc) { - int i, o, flagCount = 0, nrReq = 0, nrOpt = 0, varArgs = 0; - argDefinition *aPtr, *bPtr; - interfaceDefinition *ifdPtr = &methodDefinitons[idx].ifd; + int i, o, args, flagCount = 0, nrReq = 0, nrOpt = 0, varArgs = 0; + /* todo benchmark with and without CONST */ + argDefinition CONST *aPtr, *bPtr; + interfaceDefinition CONST* ifdPtr = &methodDefinitons[idx].ifd; memset(pc, 0, sizeof(parseContext)); - + + /*fprintf(stderr, "BEGIN "); + for (o=1; oname && oname,o);*/ + /*fprintf(stderr,".. processing i=%d: '%s' o=%d\n",i,aPtr->name,o);*/ if (*aPtr->name == '-') { /* the interface defintion has switches,switches can be given in an arbitrary order */ @@ -11232,9 +11065,25 @@ found = 0; for (bPtr = aPtr; *bPtr->name == '-'; bPtr ++) { if (strcmp(objStr,bPtr->name) == 0) { - pc->clientData[bPtr-ifdPtr[0]] = (ClientData)1; + if (bPtr->nrargs == 0) { + pc->clientData[bPtr-ifdPtr[0]] = (ClientData)1; + } else { + /* we assume for now, nrargs is at most 1 */ + o++; p++; + /*fprintf(stderr, "flag '%s' o=%d p=%d, objc=%d\n",objStr,o,p,objc);*/ + if (otype, &pc->clientData[i], &varArgs) != TCL_OK) { + return TCL_ERROR; + } + } else { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "Argument for flag '", objStr, "' expected", (char *) NULL); + return TCL_ERROR; + } + } flagCount++; found = 1; + break; } } if (!found) { @@ -11259,25 +11108,30 @@ /*fprintf(stderr,"... arg %s req %d type %s try to set on %d: '%s'\n", aPtr->name,aPtr->required,aPtr->type,i, ObjStr(objv[o]));*/ - if (aPtr->type) { - if (convertToType(interp, objv[o], aPtr->type, &pc->clientData[i], &varArgs) != TCL_OK) { - return TCL_ERROR; - } - } else { - /* If no type is specified, return the string in clientData; - * objv is always passed via pc->objv - */ - pc->clientData[i] = ObjStr(objv[o]); + if (convertToType(interp, objv[o], aPtr->type, &pc->clientData[i], &varArgs) != TCL_OK) { + return TCL_ERROR; } + + /* + * objv is always passed via pc->objv + */ pc->objv[i] = objv[o]; o++; i++; aPtr++; } } - pc->args = objc - flagCount - 1; - /* fprintf(stderr, "objc = %d, args = %d, nrReq %d, nrReq + nrOpt = %d, varArgs %d\n", - objc,pc->args,nrReq,nrReq + nrOpt, varArgs);*/ + args = objc - flagCount - 1; - if (pc->args < nrReq || (!varArgs && pc->args > nrReq + nrOpt)) { + /*fprintf(stderr, "less nrreq %d last arg %s type %s\n", args < nrReq, aPtr->name, aPtr->type);*/ + /* if we have varargs, the last argument might not have get a value */ + if (!varArgs && aPtr->type && + (strcmp(aPtr->type,"args") == 0 || strcmp(aPtr->type,"allargs") == 0)) { + varArgs = 1; + } + + /*fprintf(stderr, "objc = %d, args = %d, nrReq %d, nrReq + nrOpt = %d, varArgs %d i %d %s\n", + objc,args,nrReq,nrReq + nrOpt, varArgs, i,aPtr->name);*/ + + if (args < nrReq || (!varArgs && args > nrReq + nrOpt)) { Tcl_Obj *msg = Tcl_NewStringObj("", 0); for (aPtr=ifdPtr[0]; aPtr->name; aPtr++) { if (aPtr != ifdPtr[0]) { @@ -11293,7 +11147,9 @@ } return XOTclObjErrArgCntObj(interp, objv[0], NULL, msg); } + pc->lastobjc = o-1; + /*fprintf(stderr, "END args=%d\n",pc->lastobjc);*/ /* fprintf(stderr,"after parse: o %d, i %d, objc %d, req %d opt %d ok? %d\n", o,i,objc, nrReq, nrOpt, objc >= 1+nrReq && objc <= 1+nrReq+nrOpt); */ return TCL_OK; @@ -11420,6 +11276,295 @@ return TCL_OK; } +static int XOTclCNewMethod(Tcl_Interp *interp, XOTclClass *cl, XOTclObject *withChildof, + int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *child = NULL; + Tcl_Obj *fullname; + int result, offset = 1, prefixLength; + Tcl_DString dFullname, *dsPtr = &dFullname; + XOTclStringIncrStruct *iss = &RUNTIME_STATE(interp)->iss; + + Tcl_DStringInit(dsPtr); + if (child) { + Tcl_DStringAppend(dsPtr, objectName(child), -1); + Tcl_DStringAppend(dsPtr, "::__#", 5); + } else { + Tcl_DStringAppend(dsPtr, "::xotcl::__#", 12); + } + prefixLength = dsPtr->length; + + while (1) { + (void)XOTclStringIncr(iss); + Tcl_DStringAppend(dsPtr, iss->start, iss->length); + if (!Tcl_FindCommand(interp, Tcl_DStringValue(dsPtr), NULL, 0)) { + break; + } + /* in case the value existed already, reset prefix to the + original length */ + Tcl_DStringSetLength(dsPtr, prefixLength); + } + + fullname = Tcl_NewStringObj(Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr)); + + INCR_REF_COUNT(fullname); + + objc -= offset; + { + ALLOC_ON_STACK(Tcl_Obj*, objc+3, ov); + + ov[0] = objv[0]; + ov[1] = XOTclGlobalObjects[XOTE_CREATE]; + ov[2] = fullname; + if (objc >= 1) + memcpy(ov+3, objv+offset, sizeof(Tcl_Obj *)*objc); + + result = DoDispatch((ClientData)cl, interp, objc+3, ov, 0); + FREE_ON_STACK(ov); + } + + DECR_REF_COUNT(fullname); + Tcl_DStringFree(dsPtr); + + return result; +} + +static int XOTclCInstFilterGuardMethod(Tcl_Interp *interp, XOTclClass *cl, char *filter, Tcl_Obj *guard) { + XOTclCmdList *h; + XOTclClassOpt *opt = cl->opt; + + if (opt && opt->instfilters) { + h = CmdListFindNameInList(interp, filter, opt->instfilters); + if (h) { + if (h->clientData) + GuardDel(h); + GuardAdd(interp, h, guard); + FilterInvalidateObjOrders(interp, cl); + return TCL_OK; + } + } + + return XOTclVarErrMsg(interp, "Instfilterguard: can't find filter ", + 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 XOTclCInstMixinGuardMethod(Tcl_Interp *interp, XOTclClass *cl, char *mixin, Tcl_Obj *guard) { + XOTclClassOpt *opt = cl->opt; + XOTclCmdList *h; + + if (opt && opt->instmixins) { + XOTclClass *mixinCl = XOTclpGetClass(interp, mixin); + Tcl_Command mixinCmd = NULL; + if (mixinCl) { + mixinCmd = Tcl_GetCommandFromObj(interp, mixinCl->object.cmdName); + } + if (mixinCmd) { + h = CmdListFindCmdInList(mixinCmd, opt->instmixins); + if (h) { + if (h->clientData) + GuardDel((XOTclCmdList*) h); + GuardAdd(interp, h, guard); + MixinInvalidateObjOrders(interp, cl); + return TCL_OK; + } + } + } + + return XOTclVarErrMsg(interp, "Instmixinguard: can't find mixin ", + mixin, " on ", className(cl), (char *) NULL); +} + +static int XOTclCInstParameterCmdMethod(Tcl_Interp *interp, XOTclClass *cl, char *name) { + XOTclAddInstanceMethod(interp, (XOTcl_Class *)cl, name, (Tcl_ObjCmdProc*)XOTclSetterMethod, 0, 0, 0); + return TCL_OK; +} + + +/* TODO REMOVE ME LATER */ +static int makeMethod2(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, + Tcl_Obj *precondition, Tcl_Obj *postcondition, int clsns); + +static int XOTclCInstProcMethod(Tcl_Interp *interp, XOTclClass *cl, + Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, + Tcl_Obj *precondition, Tcl_Obj *postcondition) { + return makeMethod2(interp, cl, name, args, body, precondition, postcondition, 0); +} + +static int XOTclCInstProcMethodC(Tcl_Interp *interp, XOTclClass *cl, + Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, + Tcl_Obj *precondition, Tcl_Obj *postcondition) { + return makeMethod2(interp, cl, name, args, body, precondition, postcondition, 1); +} + +static void forwardCmdDeleteProc(ClientData clientData); /* TODO REMOVE ME LATER */ + +static int +forwardProcessOptions2(Tcl_Interp *interp, Tcl_Obj *name, + Tcl_Obj *withDefault, int withEarlybinding, Tcl_Obj *withMethodprefix, + int withObjscope, Tcl_Obj *withOnerror, int withVerbose, + Tcl_Obj *target, int objc, Tcl_Obj * CONST objv[], + forwardCmdClientData **tcdp) { + forwardCmdClientData *tcd; + int i, rc = 0; + + tcd = NEW(forwardCmdClientData); + memset(tcd, 0, sizeof(forwardCmdClientData)); + + if (withDefault) { + tcd->subcommands = withDefault; + rc = Tcl_ListObjLength(interp, withDefault, &tcd->nr_subcommands); + INCR_REF_COUNT(tcd->subcommands); + } + if (withMethodprefix) { + tcd->prefix = withMethodprefix; + INCR_REF_COUNT(tcd->prefix); + } + if (withOnerror) { + tcd->onerror = withOnerror; + INCR_REF_COUNT(tcd->onerror); + } + tcd->objscope = withObjscope; + tcd->verbose = withVerbose; + + tcd->needobjmap = 0; + + tcd->cmdName = target; + /*fprintf(stderr, "...forwardprocess objc %d\n",objc);*/ + + for (i=0; ineedobjmap |= (*element == '%' && *(element+1) == '@'); + /* TODO simplify: cmdName not needed here */ + if (tcd->cmdName == NULL) { + tcd->cmdName = objv[i]; + } else if (tcd->args == NULL) { + tcd->args = Tcl_NewListObj(1, &objv[i]); + tcd->nr_args++; + INCR_REF_COUNT(tcd->args); + } else { + Tcl_ListObjAppendElement(interp, tcd->args, objv[i]); + tcd->nr_args++; + } + } + + if (!tcd->cmdName) { + tcd->cmdName = name; + } + + /*fprintf(stderr, "cmdName = %s, args = %s, # = %d\n", + ObjStr(tcd->cmdName), ObjStr(tcd->args), tcd->nr_args);*/ + + if (tcd->objscope) { + /* when we evaluating objscope, and define ... + o forward append -objscope append + a call to + o append ... + would lead to a recursive call; so we add the appropriate namespace + */ + char *nameString = ObjStr(tcd->cmdName); + if (!isAbsolutePath(nameString)) { + tcd->cmdName = NameInNamespaceObj(interp, nameString, callingNameSpace(interp)); + /*fprintf(stderr,"name %s not absolute, therefore qualifying %s\n", name, + ObjStr(tcd->cmdName));*/ + } + } + INCR_REF_COUNT(tcd->cmdName); + + if (withEarlybinding) { + Tcl_Command cmd = Tcl_GetCommandFromObj(interp, tcd->cmdName); + if (cmd == NULL) + return XOTclVarErrMsg(interp, "cannot lookup command '", ObjStr(tcd->cmdName), "'", (char *) NULL); + + tcd->objProc = Tcl_Command_objProc(cmd); + if (tcd->objProc == XOTclObjDispatch /* don't do direct invoke on xotcl objects */ + || tcd->objProc == TclObjInterpProc /* don't do direct invoke on tcl procs */ + ) { + /* silently ignore earlybinding flag */ + tcd->objProc = NULL; + } else { + tcd->clientData = Tcl_Command_objClientData(cmd); + } + } + + tcd->passthrough = !tcd->args && *(ObjStr(tcd->cmdName)) != '%' && tcd->objProc; + + /*fprintf(stderr, "forward args = %p, name = '%s'\n", tcd->args, ObjStr(tcd->cmdName));*/ + if (rc == TCL_OK) { + *tcdp = tcd; + } else { + forwardCmdDeleteProc((ClientData)tcd); + } + return rc; +} + +static int XOTclCInstForwardMethod(Tcl_Interp *interp, XOTclClass *cl, 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[]) { + forwardCmdClientData *tcd; + int rc; + + /*withVerbose = 1; TODO REMOVE*/ + /*fprintf(stderr,"XOTclCInstForwardMethod name %s, default %p early %d prefix %p objscope %d onerror %p verb %d target %p\n",ObjStr(method), withDefault, withEarlybinding, withMethodprefix, withObjscope, withOnerror, withVerbose,target);*/ + rc = forwardProcessOptions2(interp, method, + withDefault, withEarlybinding, withMethodprefix, + withObjscope, withOnerror, withVerbose, + target, nobjc, nobjv, &tcd); + + if (rc == TCL_OK) { + tcd->obj = &cl->object; + XOTclAddIMethod(interp, (XOTcl_Class*)cl, NSTail(ObjStr(method)), + (Tcl_ObjCmdProc*)XOTclForwardMethod, + (ClientData)tcd, forwardCmdDeleteProc); + } + return rc; +} + +static int XOTclCRecreateMethod(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *name, + int objc, Tcl_Obj *CONST objv[]) { + XOTclObject *newobj; + int result; + + if (XOTclObjConvertObject(interp, name, &newobj) != TCL_OK) + return XOTclVarErrMsg(interp, "can't recreate non existing object ", + ObjStr(name), (char *) NULL); + + INCR_REF_COUNT(name); + newobj->flags |= XOTCL_RECREATE; + + result = doCleanup(interp, newobj, &cl->object, objc, objv); + if (result == TCL_OK) { + result = doObjInitialization(interp, newobj, objc, objv); + if (result == TCL_OK) + Tcl_SetObjResult(interp, name); + } + DECR_REF_COUNT(name); + return result; +} + +static int XOTclCUnknownMethod(Tcl_Interp *interp, XOTclClass *cl, char *name, + int objc, Tcl_Obj *CONST objv[]) { + if (isCreateString(name)) + return XOTclVarErrMsg(interp, "error ", className(cl), ": unable to dispatch '", + name, "'", (char *)NULL); + + return callMethod((ClientData)cl, interp, XOTclGlobalObjects[XOTE_CREATE], objc+1, objv+1, 0); +} + + + /*************************** * End Class Methods ***************************/ @@ -11964,18 +12109,7 @@ -static int -XOTclCInstParameterCmdMethod(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(clientData); - if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); - if (objc < 2) return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], "name"); - XOTclAddInstanceMethod(interp, (XOTcl_Class*) cl, ObjStr(objv[1]), - (Tcl_ObjCmdProc*)XOTclSetterMethod, 0, 0, 0); - return TCL_OK; -} - static int XOTclCParameterCmdMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { @@ -12101,32 +12235,7 @@ return rc; } - static int -XOTclCInstForwardMethod(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj * CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(clientData); - forwardCmdClientData *tcd; - int rc; - - if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); - if (objc < 2) goto forward_argc_error; - rc = forwardProcessOptions(interp, objc, objv, &tcd); - - if (rc == TCL_OK) { - tcd->obj = &cl->object; - XOTclAddIMethod(interp, (XOTcl_Class*) cl, NSTail(ObjStr(objv[1])), - (Tcl_ObjCmdProc*)XOTclForwardMethod, - (ClientData)tcd, forwardCmdDeleteProc); - return TCL_OK; - } else { - forward_argc_error: - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], - "method ?target? ?-default name? ?-objscope? ?-methodprefix string? ?args?"); - } -} - -static int XOTclOForwardMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]) { XOTcl_Object *obj = (XOTcl_Object*) clientData; @@ -12190,53 +12299,139 @@ } static int -makeMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int clsns) { +MakeProc2(Tcl_Namespace *ns, XOTclAssertionStore *aStore, Tcl_HashTable **nonposArgsTable, + Tcl_Interp *interp, + Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, Tcl_Obj *precondition, Tcl_Obj *postcondition, + XOTclObject *obj, int clsns) { + int result, haveNonposArgs = 0, argsc, i; + TclCallFrame frame, *framePtr = &frame; + Tcl_Obj *ov[4], **argsv; + Tcl_HashEntry *hPtr = NULL; + char *procName = ObjStr(name); - XOTclClass *cl = XOTclObjectToClass(clientData); - char *argStr, *bdyStr, *name; - XOTclClassOpt *opt; - int incr = 0, result = TCL_OK; + if (*nonposArgsTable && (hPtr = XOTcl_FindHashEntry(*nonposArgsTable, procName))) { + NonposArgsDeleteHashEntry(hPtr); + } - if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); - if (objc < 4 || objc > 7) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], - "name ?non-positional-args? args body ?preAssertion postAssertion?"); + ov[0] = NULL; /*objv[0];*/ + ov[1] = name; - if (objc == 5 || objc == 7) { - incr = 1; + /* see, if we have nonposArgs in the ordinary argument list */ + result = Tcl_ListObjGetElements(interp, args, &argsc, &argsv); + if (result != TCL_OK) { + return XOTclVarErrMsg(interp, "cannot break args into list: ", + ObjStr(args), (char *) NULL); } + for (i=0; i 0) { + arg = ObjStr(npav[0]); + /* fprintf(stderr, "*** argparse1 arg='%s' rc=%d\n", arg, rc);*/ + if (*arg == '-') { + haveNonposArgs = 1; + continue; + } + } + break; + } + if (haveNonposArgs) { + int nrOrdinaryArgs = argsc - i; + Tcl_Obj *ordinaryArgs = Tcl_NewListObj(nrOrdinaryArgs, &argsv[i]); + Tcl_Obj *nonposArgs = Tcl_NewListObj(i, &argsv[0]); + INCR_REF_COUNT(ordinaryArgs); + INCR_REF_COUNT(nonposArgs); + result = parseNonposArgs(interp, procName, nonposArgs, ordinaryArgs, + nonposArgsTable, &haveNonposArgs); + DECR_REF_COUNT(ordinaryArgs); + DECR_REF_COUNT(nonposArgs); + if (result != TCL_OK) + return result; + } - if ((cl->object.flags & XOTCL_IS_ROOT_CLASS && isDestroyString(name)) || - (cl->object.flags & XOTCL_IS_ROOT_META_CLASS && isDeallocString(name)) || - (cl->object.flags & XOTCL_IS_ROOT_META_CLASS && isAllocString(name)) || - (cl->object.flags & XOTCL_IS_ROOT_META_CLASS && isCreateString(name))) - return XOTclVarErrMsg(interp, className(cl), " method '", name, "' of ", + if (haveNonposArgs) { + ov[2] = XOTclGlobalObjects[XOTE_ARGS]; + ov[3] = addPrefixToBody(body, 1); + } else { /* no nonpos arguments */ + ov[2] = args; + ov[3] = addPrefixToBody(body, 0); + } + + Tcl_PushCallFrame(interp,(Tcl_CallFrame *)framePtr, ns, 0); + + result = Tcl_ProcObjCmd(0, interp, 4, ov) != TCL_OK; +#if defined(NAMESPACEINSTPROCS) + { + Proc *procPtr = TclFindProc((Interp *)interp, procName); + /*fprintf(stderr,"proc=%p cmd=%p ns='%s' objns=%s\n", procPtr, procPtr->cmdPtr, + procPtr->cmdPtr->nsPtr->fullName, cmd->nsPtr->fullName);*/ + /*** patch the command ****/ + if (procPtr) { + if (clsns) { + /* set the namespace of the method as inside of the class */ + if (!obj->nsPtr) { + makeObjNamespace(interp, obj); + } + /*fprintf(stderr,"obj %s\n", objectName(obj)); + fprintf(stderr,"ns %p obj->ns %p\n", ns, obj->nsPtr); + fprintf(stderr,"ns %s obj->ns %s\n", ns->fullName, obj->nsPtr->fullName);*/ + procPtr->cmdPtr->nsPtr = (Namespace*) obj->nsPtr; + } else { + /* set the namespace of the method to the same namespace the class has */ + procPtr->cmdPtr->nsPtr = ((Command *)obj->id)->nsPtr; + } + } + } +#endif + + Tcl_PopCallFrame(interp); + + if (precondition || postcondition) { + AssertionAddProc(interp, ObjStr(name), aStore, precondition, postcondition); + } + + DECR_REF_COUNT(ov[3]); + + return result; +} + +static int makeMethod2(Tcl_Interp *interp, XOTclClass *cl, Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, + Tcl_Obj *precondition, Tcl_Obj *postcondition, int clsns) { + XOTclClassOpt *opt = cl->opt; + int result = TCL_OK; + char *argStr = ObjStr(args), *bdyStr = ObjStr(body), *nameStr = ObjStr(name); + + if ((cl->object.flags & XOTCL_IS_ROOT_CLASS && isDestroyString(nameStr)) || + (cl->object.flags & XOTCL_IS_ROOT_META_CLASS && isDeallocString(nameStr)) || + (cl->object.flags & XOTCL_IS_ROOT_META_CLASS && isAllocString(nameStr)) || + (cl->object.flags & XOTCL_IS_ROOT_META_CLASS && isCreateString(nameStr))) + return XOTclVarErrMsg(interp, className(cl), " method '", nameStr, "' of ", className(cl), " can not be overwritten. Derive a ", "sub-class", (char *) NULL); + if (precondition && !postcondition) { + return XOTclVarErrMsg(interp, className(cl), " method '", nameStr, + "'; when specifying a precondition (", ObjStr(precondition), + ") a postcondition must be specified as well", + (char *) NULL); + } + /* if both, args and body are empty strings, we delete the method */ if (*argStr == 0 && *bdyStr == 0) { - int rc; - opt = cl->opt; - if (opt && opt->assertions) - AssertionRemoveProc(opt->assertions, name); - rc = NSDeleteCmd(interp, cl->nsPtr, name); - if (rc < 0) - return XOTclVarErrMsg(interp, className(cl), " cannot delete method '", name, - "' of class ", className(cl), (char *) NULL); + result = XOTclRemoveIMethod(interp, (XOTcl_Class *)cl, nameStr); } else { XOTclAssertionStore *aStore = NULL; - if (objc > 5) { + if (precondition || postcondition) { opt = XOTclRequireClassOpt(cl); if (!opt->assertions) opt->assertions = AssertionCreateStore(); aStore = opt->assertions; } - result = MakeProc(cl->nsPtr, aStore, &(cl->nonposArgsTable), - interp, objc, (Tcl_Obj **) objv, &cl->object, clsns); + result = MakeProc2(cl->nsPtr, aStore, &(cl->nonposArgsTable), + interp, name, args, body, precondition, postcondition, + &cl->object, clsns); } /* could be a filter or filter inheritance ... update filter orders */ @@ -12245,112 +12440,10 @@ return result; } -static int -XOTclCInstProcMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - return makeMethod(clientData, interp, objc, objv, 0); -} -static int -XOTclCInstProcMethodC(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - return makeMethod(clientData, interp, objc, objv, 1); -} -static int -XOTclCInstFilterGuardMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(clientData); - XOTclCmdList *h; - XOTclClassOpt *opt; - - if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); - if (objc != 3) return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], - "filtername filterGuard"); - opt = cl->opt; - if (opt && opt->instfilters) { - h = CmdListFindNameInList(interp, ObjStr(objv[1]), opt->instfilters); - if (h) { - if (h->clientData) - GuardDel(h); - GuardAdd(interp, h, objv[2]); - FilterInvalidateObjOrders(interp, cl); - return TCL_OK; - } - } - return XOTclVarErrMsg(interp, "Instfilterguard: can't find filter ", - ObjStr(objv[1]), " on ", className(cl), - (char *) NULL); -} - - -static int -XOTclCInstMixinGuardMethod(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(clientData); - XOTclCmdList *h; - - if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); - if (objc != 3) return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], - "mixin guard"); - - if (cl->opt && cl->opt->instmixins) { - XOTclClass *mixinCl = XOTclpGetClass(interp, ObjStr(objv[1])); - Tcl_Command mixinCmd = NULL; - if (mixinCl) { - mixinCmd = Tcl_GetCommandFromObj(interp, mixinCl->object.cmdName); - } - if (mixinCmd) { - h = CmdListFindCmdInList(mixinCmd, cl->opt->instmixins); - if (h) { - if (h->clientData) - GuardDel((XOTclCmdList*) h); - GuardAdd(interp, h, objv[2]); - MixinInvalidateObjOrders(interp, cl); - return TCL_OK; - } - } - } - - return XOTclVarErrMsg(interp, "Instmixinguard: can't find mixin ", - ObjStr(objv[1]), " on ", className(cl), - (char *) NULL); -} - -static int -XOTclCInvariantsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(clientData); - XOTclClassOpt *opt; - - if (!cl) return XOTclObjErrType(interp, objv[0], "Class"); - if (objc != 2) - return XOTclObjErrArgCnt(interp, cl->object.cmdName, objv[0], - ""); - opt = XOTclRequireClassOpt(cl); - - if (opt->assertions) - TclObjListFreeList(opt->assertions->invariants); - else - opt->assertions = AssertionCreateStore(); - - opt->assertions->invariants = AssertionNewList(interp, objv[1]); - return TCL_OK; -} - -static int -XOTclCUnknownMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = (XOTclObject*) clientData; - char *self = objectName(obj); - int rc; - - if (objc < 2) return XOTclObjErrArgCnt(interp, obj->cmdName, objv[0], "message ?args .. args?"); - if (isCreateString(self)) - return XOTclVarErrMsg(interp, "error ", self, ": unable to dispatch '", - ObjStr(objv[1]), "'", (char *) NULL); - - rc = callMethod(clientData, interp, XOTclGlobalObjects[XOTE_CREATE], objc+1, objv+1, 0); - return rc; -} - /* * New Tcl Commands */ @@ -13769,16 +13862,16 @@ {"alloc", XOTclCAllocMethodStub}, {"create", XOTclCCreateMethodStub}, {"dealloc", XOTclCDeallocMethodStub}, - {"new", XOTclCNewMethod}, - {"instfilterguard", XOTclCInstFilterGuardMethod}, - {"instinvar", XOTclCInvariantsMethod}, - {"instmixinguard", XOTclCInstMixinGuardMethod}, - {"instparametercmd", XOTclCInstParameterCmdMethod}, - {"instproc", XOTclCInstProcMethod}, - {"classscopedinstproc", XOTclCInstProcMethodC}, - {"instforward", XOTclCInstForwardMethod}, - {"recreate", XOTclCRecreateMethod}, - {"unknown", XOTclCUnknownMethod} + {"new", XOTclCNewMethodStub}, + {"instfilterguard", XOTclCInstFilterGuardMethodStub}, + {"instinvar", XOTclCInvariantsMethodStub}, + {"instmixinguard", XOTclCInstMixinGuardMethodStub}, + {"instparametercmd", XOTclCInstParameterCmdMethodStub}, + {"instproc", XOTclCInstProcMethodStub}, + {"classscopedinstproc", XOTclCInstProcMethodCStub}, + {"instforward", XOTclCInstForwardMethodStub}, + {"recreate", XOTclCRecreateMethodStub}, + {"unknown", XOTclCUnknownMethodStub} }; methodDefinition definitions3[] = { Index: generic/xotcl.decls =================================================================== diff -u -r2111020b49da8ce57758e51accf0b6073037f0d2 -rc990d14157d8434cd5b1ee5f45aa43f82cb911b5 --- generic/xotcl.decls (.../xotcl.decls) (revision 2111020b49da8ce57758e51accf0b6073037f0d2) +++ generic/xotcl.decls (.../xotcl.decls) (revision c990d14157d8434cd5b1ee5f45aa43f82cb911b5) @@ -66,10 +66,10 @@ ClientData cd, Tcl_CmdDeleteProc *dp) } declare 13 generic { - void XOTclRemovePMethod(Tcl_Interp *interp,struct XOTcl_Object *obj, char *nm) + int XOTclRemovePMethod(Tcl_Interp *interp,struct XOTcl_Object *obj, char *nm) } declare 14 generic { - void XOTclRemoveIMethod(Tcl_Interp *interp, struct XOTcl_Class *cl, char *nm) + int XOTclRemoveIMethod(Tcl_Interp *interp, struct XOTcl_Class *cl, char *nm) } declare 15 generic { Tcl_Obj *XOTclOSetInstVar(struct XOTcl_Object *obj, Tcl_Interp *interp, Index: generic/xotcl.h =================================================================== diff -u -r2111020b49da8ce57758e51accf0b6073037f0d2 -rc990d14157d8434cd5b1ee5f45aa43f82cb911b5 --- generic/xotcl.h (.../xotcl.h) (revision 2111020b49da8ce57758e51accf0b6073037f0d2) +++ generic/xotcl.h (.../xotcl.h) (revision c990d14157d8434cd5b1ee5f45aa43f82cb911b5) @@ -68,11 +68,8 @@ #define XOTCL_MEM_COUNT 1 */ -/*#define REFCOUNTED 1*/ - /* #define XOTCLOBJ_TRACE 1 -#define REFCOUNT_TRACE 1 */ /* turn tracing output on/off Index: generic/xotclDecls.h =================================================================== diff -u -r4eafc074cdca60b0089c2a950954c83d519b91d3 -rc990d14157d8434cd5b1ee5f45aa43f82cb911b5 --- generic/xotclDecls.h (.../xotclDecls.h) (revision 4eafc074cdca60b0089c2a950954c83d519b91d3) +++ generic/xotclDecls.h (.../xotclDecls.h) (revision c990d14157d8434cd5b1ee5f45aa43f82cb911b5) @@ -92,13 +92,13 @@ #ifndef XOTclRemovePMethod_TCL_DECLARED #define XOTclRemovePMethod_TCL_DECLARED /* 13 */ -EXTERN void XOTclRemovePMethod (Tcl_Interp * interp, +EXTERN int XOTclRemovePMethod (Tcl_Interp * interp, struct XOTcl_Object * obj, char * nm); #endif #ifndef XOTclRemoveIMethod_TCL_DECLARED #define XOTclRemoveIMethod_TCL_DECLARED /* 14 */ -EXTERN void XOTclRemoveIMethod (Tcl_Interp * interp, +EXTERN int XOTclRemoveIMethod (Tcl_Interp * interp, struct XOTcl_Class * cl, char * nm); #endif #ifndef XOTclOSetInstVar_TCL_DECLARED @@ -297,8 +297,8 @@ int (*xOTclDeleteClass) (Tcl_Interp * interp, struct XOTcl_Class * cl); /* 10 */ Tcl_Command (*xOTclAddPMethod) (Tcl_Interp * interp, struct XOTcl_Object * obj, CONST char* nm, Tcl_ObjCmdProc* proc, ClientData cd, Tcl_CmdDeleteProc * dp); /* 11 */ Tcl_Command (*xOTclAddIMethod) (Tcl_Interp * interp, struct XOTcl_Class * cl, CONST char* nm, Tcl_ObjCmdProc* proc, ClientData cd, Tcl_CmdDeleteProc * dp); /* 12 */ - void (*xOTclRemovePMethod) (Tcl_Interp * interp, struct XOTcl_Object * obj, char * nm); /* 13 */ - void (*xOTclRemoveIMethod) (Tcl_Interp * interp, struct XOTcl_Class * cl, char * nm); /* 14 */ + int (*xOTclRemovePMethod) (Tcl_Interp * interp, struct XOTcl_Object * obj, char * nm); /* 13 */ + int (*xOTclRemoveIMethod) (Tcl_Interp * interp, struct XOTcl_Class * cl, char * nm); /* 14 */ Tcl_Obj * (*xOTclOSetInstVar) (struct XOTcl_Object * obj, Tcl_Interp * interp, Tcl_Obj * name, Tcl_Obj * value, int flgs); /* 15 */ Tcl_Obj * (*xOTclOGetInstVar) (struct XOTcl_Object * obj, Tcl_Interp * interp, Tcl_Obj * name, int flgs); /* 16 */ int (*xOTclInstVar) (struct XOTcl_Object * obj, Tcl_Interp * interp, char * name, char * destName); /* 17 */ Index: generic/xotclInt.h =================================================================== diff -u -r6cea71632dc3d32fabb894f5de7c803145261102 -rc990d14157d8434cd5b1ee5f45aa43f82cb911b5 --- generic/xotclInt.h (.../xotclInt.h) (revision 6cea71632dc3d32fabb894f5de7c803145261102) +++ generic/xotclInt.h (.../xotclInt.h) (revision c990d14157d8434cd5b1ee5f45aa43f82cb911b5) @@ -443,7 +443,6 @@ #define XOTCL_IS_ROOT_CLASS 0x0100 /* DESTROYED set, when object is physically destroyed with PrimitiveODestroy */ #define XOTCL_DESTROYED 0x1000 -#define XOTCL_REFCOUNTED 0x2000 #define XOTCL_RECREATE 0x4000 #define XOTCL_NS_DESTROYED 0x8000 Index: tests/testx.xotcl =================================================================== diff -u -r80dbbc5075b96ca2d25ebf426204398f68411e17 -rc990d14157d8434cd5b1ee5f45aa43f82cb911b5 --- tests/testx.xotcl (.../testx.xotcl) (revision 80dbbc5075b96ca2d25ebf426204398f68411e17) +++ tests/testx.xotcl (.../testx.xotcl) (revision c990d14157d8434cd5b1ee5f45aa43f82cb911b5) @@ -3768,13 +3768,13 @@ } o test1 1 o test1 -x 1 - + o proc test2 {{-x:switch true} y} { my append result "x=$x y=$y, " } o test2 2 o test2 -x 2 - + o proc test3 {{-x:switch false} y} { my append result "x=$x y=$y, " } @@ -3784,83 +3784,84 @@ "x=0 y=1, x=1 y=1, x=true y=2, x=0 y=2, x=false y=3, x=1 y=3, " \ "nonpos args switch" - Object o - o proc x {a b} { - return "$a $b" - } - o proc x {} {a b} { - return "$a $b" - } - o proc y {-x {-a {1 2 3}}} {a b} { - return "$args" - } - o proc z1 {-x:required {-a {1 2 3}}} {a args} { - return "$x -- $args" - } - o proc z2 {-x:required {-a {1 }} {-b {1 2}}} {args} {return "$x -- $args -- $a -- $b"} - o proc z3 {-b:boolean} {arg} { - return "$b $arg" - } - Object colorchecker - colorchecker proc color {var value} { - lappend ::r "color <$var> <$value>" - } - colorchecker proc reddish {var value} { - lappend ::r "reddish <$var> <$value>" - } - - o proc z4 {{{-b: required, checkobj colorchecker,color, reddish, - checkobj xotcl::nonposArgs,required} red} - {{-c: required }}} {arg} { - lappend ::r "$b $arg" - return "$b $arg" - } - o proc z5 {-pos args} { - return [list $pos $args] - } + Object o + o proc x {a b} { + return "$a $b" + } + o proc x {} {a b} { + return "$a $b" + } + o proc y {-x {-a {1 2 3}}} {a b} { + return "$args" + } + o proc z1 {-x:required {-a {1 2 3}}} {a args} { + return "$x -- $args" + } + o proc z2 {-x:required {-a {1 }} {-b {1 2}}} {args} {return "$x -- $args -- $a -- $b"} + o proc z3 {-b:boolean} {arg} { + return "$b $arg" + } + Object colorchecker + colorchecker proc color {var value} { + lappend ::r "color <$var> <$value>" + } + colorchecker proc reddish {var value} { + lappend ::r "reddish <$var> <$value>" + } + + o proc z4 {{{-b: required, checkobj colorchecker,color, reddish, + checkobj xotcl::nonposArgs,required} red} + {{-c: required }}} {arg} { + lappend ::r "$b $arg" + return "$b $arg" + } + o proc z5 {-pos args} { + return [list $pos $args] + } - Class P - P instproc x {a b} { - return "$a $b" - } - P instproc z2 {-x:required {-a 1} {-b {1 2}}} {args} {return "$x -- $args -- $a -- $b"} - - P instproc z3 {-x:required {-a 1} {-b {1 2}}} {a b c} { - return "$x -- $args -- $a -- $b" - } - P p + Class P + P instproc x {a b} { + return "$a $b" + } - errorCheck [o x 1 2] "1 2" "Ordinary Method" - errorCheck [p x 3 4] "3 4" "Ordinary Method (2)" - catch { - o y 4 56 5 - } m - errorCheck $m {unknown argument '5' for method 'y': valid arguments -x {-a {1 2 3}} a b} "wrong \# check 1" - catch { - o y - } m - errorCheck $m "wrong # args for method 'y': valid arguments -x {-a {1 2 3}} a b" "wrong \# check 2" - catch { - o y -x 1 - } m - errorCheck $m "wrong # args for method 'y': valid arguments -x {-a {1 2 3}} a b" "wrong \# check 3" - catch { - o z1 a 1 2 3 - } m - errorCheck $m "required arg: 'x' missing" "required missing" - errorCheck [o z1 -x 1 a 1 2 3] "1 -- 1 2 3" "invocation 1" - errorCheck [o z2 -x 2 a 1 2 3] "2 -- a 1 2 3 -- 1 -- 1 2" "invocation 2" - catch { - o y -x 1 -a 2 2 3 - } m - errorCheck $m "can't read \"args\": no such variable" "args unset?" - errorCheck [o z2 -a 2 -x 1 -b 3 a b c] \ - "1 -- a b c -- 2 -- 3" "invocation 3" - errorCheck [p z2 -x 1 -a 2 -b 3 a b c] \ - "1 -- a b c -- 2 -- 3" "invocation 4" + P instproc z2 {-x:required {-a 1} {-b {1 2}} args} {return "$x -- $args -- $a -- $b"} + P instproc z3 {-x:required {-a 1} {-b {1 2}} a b c} { + return "$x -- $args -- $a -- $b" + } - errorCheck [o z3 -b true -- -b] "true -b" "dash dash" + P p + errorCheck [o x 1 2] "1 2" "Ordinary Method" + errorCheck [p x 3 4] "3 4" "Ordinary Method (2)" + catch { + o y 4 56 5 + } m + errorCheck $m {unknown argument '5' for method 'y': valid arguments -x {-a {1 2 3}} a b} "wrong \# check 1" + catch { + o y + } m + errorCheck $m "wrong # args for method 'y': valid arguments -x {-a {1 2 3}} a b" "wrong \# check 2" + catch { + o y -x 1 + } m + errorCheck $m "wrong # args for method 'y': valid arguments -x {-a {1 2 3}} a b" "wrong \# check 3" + catch { + o z1 a 1 2 3 + } m + errorCheck $m "required arg: 'x' missing" "required missing" + errorCheck [o z1 -x 1 a 1 2 3] "1 -- 1 2 3" "invocation 1" + errorCheck [o z2 -x 2 a 1 2 3] "2 -- a 1 2 3 -- 1 -- 1 2" "invocation 2" + catch { + o y -x 1 -a 2 2 3 + } m + errorCheck $m "can't read \"args\": no such variable" "args unset?" + errorCheck [o z2 -a 2 -x 1 -b 3 a b c] \ + "1 -- a b c -- 2 -- 3" "invocation 3" + errorCheck [p z2 -x 1 -a 2 -b 3 a b c] \ + "1 -- a b c -- 2 -- 3" "invocation 4" + + errorCheck [o z3 -b true -- -b] "true -b" "dash dash" + errorCheck [o z5 -pos 1 a b] "1 {a b}" "nonpos with given args" errorCheck [o z5 -pos 1 a] "1 a" "nonpos with given args" errorCheck [o z5 -pos 1] "1 {}" "nonpos without given args" @@ -3934,12 +3935,14 @@ C create c1 C instproc m2 { {-flag:boolean false} - } {x y {z 15}} { + x y {z 15} + } { return $flag-$z } c1 proc m14 { {-flag:boolean false} - } {x y {z 15}} { + x y {z 15} + } { return $flag-$z } @@ -3963,7 +3966,8 @@ C instproc m3 { {-flag:boolean} - } {x y z} { + x y z + } { return hu3 }