Index: ChangeLog =================================================================== diff -u -r108d81ec266a27d011953bdc6b7d8b32eb0afcc7 -r321a21cbb0beec854bfc651e167c32ded2707a3a --- ChangeLog (.../ChangeLog) (revision 108d81ec266a27d011953bdc6b7d8b32eb0afcc7) +++ ChangeLog (.../ChangeLog) (revision 321a21cbb0beec854bfc651e167c32ded2707a3a) @@ -67,8 +67,11 @@ - removed compatibility for versions before Tcl 8.4 (was not tested anyhow) This version requires at least Tcl 8.4. - support for generating interface for ::xotcl commands - - generated interface for ::xotcl::alias, ::xotcl::my, ::xotcl::relation, ::xotcl::setinstvar - - from 15356 generic/xotcl.c => 13288 + - support for enumeration types in c-code generator + - use function pointer for type checker instead of strings + - generated interface for ::xotcl::alias, ::xotcl::methodproperty, + ::xotcl::my, ::xotcl::relation, ::xotcl::setinstvar + - from 15356 generic/xotcl.c => 13216 2009-07-01 - moved all definitions of method commands to generated code @@ -80,7 +83,7 @@ - all object methods generated - added reference counting for patternobj - some cleanup and reordering - - from 15356 generic/xotcl.c => 13884 => 13560 + - from 15356 generic/xotcl.c => 13560 2009-06-29 - !!! removed obsolete features Index: generic/gentclAPI.decls =================================================================== diff -u -r108d81ec266a27d011953bdc6b7d8b32eb0afcc7 -r321a21cbb0beec854bfc651e167c32ded2707a3a --- generic/gentclAPI.decls (.../gentclAPI.decls) (revision 108d81ec266a27d011953bdc6b7d8b32eb0afcc7) +++ generic/gentclAPI.decls (.../gentclAPI.decls) (revision 321a21cbb0beec854bfc651e167c32ded2707a3a) @@ -24,14 +24,21 @@ {-argName "-protected"} {-argName "cmdName" -required 1 -type tclobj} } +xotclCmd methodproperty XOTclMethodPropertyCmd { + {-argName "object" -required 1 -type object} + {-argName "methodName" -required 1} + {-argName "-per-object"} + {-argName "methodproperty" -required 1 -type "protected|public|slotobj"} + {-argName "value" -type tclobj} +} xotclCmd my XOTclMyCmd { {-argName "-local"} {-argName "method" -required 1 -type tclobj} {-argName "args" -type args} } xotclCmd relation XOTclRelationCmd { {-argName "object" -required 1 -type object} - {-argName "reltype" -required 1 -type tclobj} + {-argName "relationtype" -required 1 -type "mixin|instmixin|object-mixin|class-mixin|filter|instfilter|object-filter|class_filter|class|superclass|rootclass"} {-argName "value" -required 0 -type tclobj} } xotclCmd setinstvar XOTclSetInstvarCmd { Index: generic/gentclAPI.tcl =================================================================== diff -u -r1b27a533f020bd0c0334abd6b2e1ba02db1eae71 -r321a21cbb0beec854bfc651e167c32ded2707a3a --- generic/gentclAPI.tcl (.../gentclAPI.tcl) (revision 1b27a533f020bd0c0334abd6b2e1ba02db1eae71) +++ generic/gentclAPI.tcl (.../gentclAPI.tcl) (revision 321a21cbb0beec854bfc651e167c32ded2707a3a) @@ -7,21 +7,60 @@ # Gustaf Neumann, fecit in June 2009 # -set objCmdProc "(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv \[\]);" +set ::converter "" +set ::objCmdProc "(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv \[\]);" + +proc convertername {type argname} { + #return [string totitle [string map [list | _] $type]] + return [string totitle $argname] +} + +proc createconverter {type argname} { + set name [convertername $type $argname] + if {[info exists ::created($name)]} { + return "" + } + set domain [split $type |] + set opts "static CONST char *opts\[\] = {\"[join $domain {", "}]\", NULL};" + set enums [list] + foreach d $domain {lappend enums $argname[string totitle [string map [list - _] $d]]Idx} + subst { +static int convertTo${name}(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientData) { + $opts + return Tcl_GetIndexFromObj(interp, objPtr, opts, "$argname", 0, (int *)clientData); +} +enum ${argname}Idx {[join $enums {, }]}; + } +} + proc genifd {argDefinitions} { set l [list] foreach argDefinition $argDefinitions { array set "" $argDefinition switch $(-type) { "" {set type NULL} - default {set type "\"$(-type)\""} + default {set type $(-type)} } - lappend l "{\"$(-argName)\", $(-required), $(-nrargs), $type}" + switch -glob $type { + "NULL" {set converter String} + "class" {set converter Class} + "object" {set converter Object} + "tclobj" {set converter Tclobj} + "args" {set converter Nothing} + "allargs" {set converter Nothing} + "objpattern" {set converter Objpattern} + *|* { + set converter [convertername $type $(-argName)] + append ::converter [createconverter $type $(-argName)] + set (-argName) $type + } + } + lappend l "{\"$(-argName)\", $(-required), $(-nrargs), convertTo$converter}" } join $l ",\n " } -proc gencall {argDefinitions clientData cDefsVar ifDefVar arglistVar preVar postVar introVar} { +proc gencall {fn argDefinitions clientData cDefsVar ifDefVar arglistVar preVar postVar introVar} { upvar $cDefsVar cDefs $ifDefVar ifDef $arglistVar arglist $preVar pre $postVar post \ $introVar intro set c [list] @@ -71,7 +110,7 @@ } else { set varName $(-argName) set calledArg $varName - switch $(-type) { + switch -glob $(-type) { "" {set type "char *"} "class" {set type "XOTclClass *"} "object" {set type "XOTclObject *"} @@ -111,7 +150,10 @@ }] # end of obj pattern } - default {error "type '$(-type)' not allowed for argument"} + *|* {set type "int "} + default { + error "type '$(-type)' not allowed for argument" + } } } if {!$ifSet} {lappend if "$type$varName"} @@ -136,7 +178,7 @@ lappend enums $d(idx) lappend ifds "{\"$::ns($d(methodType))::$d(methodName)\", $d(stub), {\n [genifd $d(argDefinitions)]}\n}" - gencall $d(argDefinitions) $d(clientData) cDefs ifDef arglist pre post intro + gencall $d(stub) $d(argDefinitions) $d(clientData) cDefs ifDef arglist pre post intro append decls "static int $d(implementation)(Tcl_Interp *interp, $ifDef);\n" if {$post ne ""} { append cDefs "\n int returnCode;" @@ -162,6 +204,7 @@ }] } + puts $::converter puts { typedef struct { char *methodName; Index: generic/tclAPI.h =================================================================== diff -u -r108d81ec266a27d011953bdc6b7d8b32eb0afcc7 -r321a21cbb0beec854bfc651e167c32ded2707a3a --- generic/tclAPI.h (.../tclAPI.h) (revision 108d81ec266a27d011953bdc6b7d8b32eb0afcc7) +++ generic/tclAPI.h (.../tclAPI.h) (revision 321a21cbb0beec854bfc651e167c32ded2707a3a) @@ -1,4 +1,17 @@ +static int convertToMethodproperty(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientData) { + static CONST char *opts[] = {"protected", "public", "slotobj", NULL}; + return Tcl_GetIndexFromObj(interp, objPtr, opts, "methodproperty", 0, (int *)clientData); +} +enum methodpropertyIdx {methodpropertyProtectedIdx, methodpropertyPublicIdx, methodpropertySlotobjIdx}; + +static int convertToRelationtype(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientData) { + static CONST char *opts[] = {"mixin", "instmixin", "object-mixin", "class-mixin", "filter", "instfilter", "object-filter", "class_filter", "class", "superclass", "rootclass", NULL}; + return Tcl_GetIndexFromObj(interp, objPtr, opts, "relationtype", 0, (int *)clientData); +} +enum relationtypeIdx {relationtypeMixinIdx, relationtypeInstmixinIdx, relationtypeObject_mixinIdx, relationtypeClass_mixinIdx, relationtypeFilterIdx, relationtypeInstfilterIdx, relationtypeObject_filterIdx, relationtypeClass_filterIdx, relationtypeClassIdx, relationtypeSuperclassIdx, relationtypeRootclassIdx}; + + typedef struct { char *methodName; Tcl_ObjCmdProc *proc; @@ -110,6 +123,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 XOTclMethodPropertyCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclMyCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclRelationCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclSetInstvarCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); @@ -206,8 +220,9 @@ 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, int withProtected, Tcl_Obj *cmdName); +static int XOTclMethodPropertyCmd(Tcl_Interp *interp, XOTclObject *object, char *methodName, int withPer_object, int methodproperty, Tcl_Obj *value); static int XOTclMyCmd(Tcl_Interp *interp, int withLocal, Tcl_Obj *method, int nobjc, Tcl_Obj *CONST nobjv[]); -static int XOTclRelationCmd(Tcl_Interp *interp, XOTclObject *object, Tcl_Obj *reltype, Tcl_Obj *value); +static int XOTclRelationCmd(Tcl_Interp *interp, XOTclObject *object, int relationtype, Tcl_Obj *value); static int XOTclSetInstvarCmd(Tcl_Interp *interp, XOTclObject *object, Tcl_Obj *variable, Tcl_Obj *value); enum { @@ -303,6 +318,7 @@ XOTclOVolatileMethodIdx, XOTclOVwaitMethodIdx, XOTclAliasCmdIdx, + XOTclMethodPropertyCmdIdx, XOTclMyCmdIdx, XOTclRelationCmdIdx, XOTclSetInstvarCmdIdx @@ -1826,6 +1842,24 @@ } static int +XOTclMethodPropertyCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + parseContext pc; + + if (parseObjv(interp, objc, objv, XOTclMethodPropertyCmdIdx, &pc) != TCL_OK) { + return TCL_ERROR; + } else { + XOTclObject *object = (XOTclObject *)pc.clientData[0]; + char *methodName = (char *)pc.clientData[1]; + int withPer_object = (int )pc.clientData[2]; + int methodproperty = (int )pc.clientData[3]; + Tcl_Obj *value = (Tcl_Obj *)pc.clientData[4]; + + return XOTclMethodPropertyCmd(interp, object, methodName, withPer_object, methodproperty, value); + + } +} + +static int XOTclMyCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; @@ -1848,10 +1882,10 @@ return TCL_ERROR; } else { XOTclObject *object = (XOTclObject *)pc.clientData[0]; - Tcl_Obj *reltype = (Tcl_Obj *)pc.clientData[1]; + int relationtype = (int )pc.clientData[1]; Tcl_Obj *value = (Tcl_Obj *)pc.clientData[2]; - return XOTclRelationCmd(interp, object, reltype, value); + return XOTclRelationCmd(interp, object, relationtype, value); } } @@ -1874,403 +1908,410 @@ static methodDefinition method_definitions[] = { {"::xotcl::cmd::NonposArgs::type=boolean", XOTclCheckBooleanArgsStub, { - {"name", 1, 0, NULL}, - {"value", 0, 0, "tclobj"}} + {"name", 1, 0, convertToString}, + {"value", 0, 0, convertToTclobj}} }, {"::xotcl::cmd::NonposArgs::type=required", XOTclCheckRequiredArgsStub, { - {"name", 1, 0, NULL}, - {"value", 0, 0, "tclobj"}} + {"name", 1, 0, convertToString}, + {"value", 0, 0, convertToTclobj}} }, {"::xotcl::cmd::Class::alloc", XOTclCAllocMethodStub, { - {"name", 1, 0, NULL}} + {"name", 1, 0, convertToString}} }, {"::xotcl::cmd::Class::create", XOTclCCreateMethodStub, { - {"name", 1, 0, NULL}, - {"args", 0, 0, "allargs"}} + {"name", 1, 0, convertToString}, + {"args", 0, 0, convertToNothing}} }, {"::xotcl::cmd::Class::dealloc", XOTclCDeallocMethodStub, { - {"object", 1, 0, "tclobj"}} + {"object", 1, 0, convertToTclobj}} }, {"::xotcl::cmd::Class::instfilterguard", XOTclCInstFilterGuardMethodStub, { - {"filter", 1, 0, NULL}, - {"guard", 1, 0, "tclobj"}} + {"filter", 1, 0, convertToString}, + {"guard", 1, 0, convertToTclobj}} }, {"::xotcl::cmd::Class::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"}} + {"method", 1, 0, convertToTclobj}, + {"-default", 0, 1, convertToTclobj}, + {"-earlybinding", 0, 0, convertToString}, + {"-methodprefix", 0, 1, convertToTclobj}, + {"-objscope", 0, 0, convertToString}, + {"-onerror", 0, 1, convertToTclobj}, + {"-verbose", 0, 0, convertToString}, + {"target", 0, 0, convertToTclobj}, + {"args", 0, 0, convertToNothing}} }, {"::xotcl::cmd::Class::instmixinguard", XOTclCInstMixinGuardMethodStub, { - {"mixin", 1, 0, NULL}, - {"guard", 1, 0, "tclobj"}} + {"mixin", 1, 0, convertToString}, + {"guard", 1, 0, convertToTclobj}} }, {"::xotcl::cmd::Class::instparametercmd", XOTclCInstParametercmdMethodStub, { - {"name", 1, 0, NULL}} + {"name", 1, 0, convertToString}} }, {"::xotcl::cmd::Class::instproc", XOTclCInstProcMethodStub, { - {"name", 1, 0, "tclobj"}, - {"args", 1, 0, "tclobj"}, - {"body", 1, 0, "tclobj"}, - {"precondition", 0, 0, "tclobj"}, - {"postcondition", 0, 0, "tclobj"}} + {"name", 1, 0, convertToTclobj}, + {"args", 1, 0, convertToTclobj}, + {"body", 1, 0, convertToTclobj}, + {"precondition", 0, 0, convertToTclobj}, + {"postcondition", 0, 0, convertToTclobj}} }, {"::xotcl::cmd::Class::classscopedinstproc", XOTclCInstProcMethodCStub, { - {"name", 1, 0, "tclobj"}, - {"args", 1, 0, "tclobj"}, - {"body", 1, 0, "tclobj"}, - {"precondition", 0, 0, "tclobj"}, - {"postcondition", 0, 0, "tclobj"}} + {"name", 1, 0, convertToTclobj}, + {"args", 1, 0, convertToTclobj}, + {"body", 1, 0, convertToTclobj}, + {"precondition", 0, 0, convertToTclobj}, + {"postcondition", 0, 0, convertToTclobj}} }, {"::xotcl::cmd::Class::instinvar", XOTclCInvariantsMethodStub, { - {"invariantlist", 1, 0, "tclobj"}} + {"invariantlist", 1, 0, convertToTclobj}} }, {"::xotcl::cmd::Class::new", XOTclCNewMethodStub, { - {"-childof", 0, 1, "object"}, - {"args", 0, 0, "args"}} + {"-childof", 0, 1, convertToObject}, + {"args", 0, 0, convertToNothing}} }, {"::xotcl::cmd::Class::recreate", XOTclCRecreateMethodStub, { - {"name", 1, 0, "tclobj"}, - {"args", 0, 0, "allargs"}} + {"name", 1, 0, convertToTclobj}, + {"args", 0, 0, convertToNothing}} }, {"::xotcl::cmd::Class::unknown", XOTclCUnknownMethodStub, { - {"name", 1, 0, NULL}, - {"args", 0, 0, "allargs"}} + {"name", 1, 0, convertToString}, + {"args", 0, 0, convertToNothing}} }, {"::xotcl::cmd::ClassInfo::heritage", XOTclClassInfoHeritageMethodStub, { - {"class", 1, 0, "class"}, - {"pattern", 0, 0, NULL}} + {"class", 1, 0, convertToClass}, + {"pattern", 0, 0, convertToString}} }, {"::xotcl::cmd::ClassInfo::instances", XOTclClassInfoInstancesMethodStub, { - {"class", 1, 0, "class"}, - {"-closure", 0, 0, NULL}, - {"pattern", 0, 0, "objpattern"}} + {"class", 1, 0, convertToClass}, + {"-closure", 0, 0, convertToString}, + {"pattern", 0, 0, convertToObjpattern}} }, {"::xotcl::cmd::ClassInfo::instargs", XOTclClassInfoInstargsMethodStub, { - {"class", 1, 0, "class"}, - {"methodName", 1, 0, NULL}} + {"class", 1, 0, convertToClass}, + {"methodName", 1, 0, convertToString}} }, {"::xotcl::cmd::ClassInfo::instbody", XOTclClassInfoInstbodyMethodStub, { - {"class", 1, 0, "class"}, - {"methodName", 1, 0, NULL}} + {"class", 1, 0, convertToClass}, + {"methodName", 1, 0, convertToString}} }, {"::xotcl::cmd::ClassInfo::instcommands", XOTclClassInfoInstcommandsMethodStub, { - {"class", 1, 0, "class"}, - {"pattern", 0, 0, NULL}} + {"class", 1, 0, convertToClass}, + {"pattern", 0, 0, convertToString}} }, {"::xotcl::cmd::ClassInfo::instdefault", XOTclClassInfoInstdefaultMethodStub, { - {"class", 1, 0, "class"}, - {"methodName", 1, 0, NULL}, - {"arg", 1, 0, NULL}, - {"var", 1, 0, "tclobj"}} + {"class", 1, 0, convertToClass}, + {"methodName", 1, 0, convertToString}, + {"arg", 1, 0, convertToString}, + {"var", 1, 0, convertToTclobj}} }, {"::xotcl::cmd::ClassInfo::instfilter", XOTclClassInfoInstfilterMethodStub, { - {"class", 1, 0, "class"}, - {"-guards", 0, 0, NULL}, - {"pattern", 0, 0, NULL}} + {"class", 1, 0, convertToClass}, + {"-guards", 0, 0, convertToString}, + {"pattern", 0, 0, convertToString}} }, {"::xotcl::cmd::ClassInfo::instfilterguard", XOTclClassInfoInstfilterguardMethodStub, { - {"class", 1, 0, "class"}, - {"filter", 1, 0, NULL}} + {"class", 1, 0, convertToClass}, + {"filter", 1, 0, convertToString}} }, {"::xotcl::cmd::ClassInfo::instforward", XOTclClassInfoInstforwardMethodStub, { - {"class", 1, 0, "class"}, - {"-definition", 0, 0, NULL}, - {"pattern", 0, 0, NULL}} + {"class", 1, 0, convertToClass}, + {"-definition", 0, 0, convertToString}, + {"pattern", 0, 0, convertToString}} }, {"::xotcl::cmd::ClassInfo::instinvar", XOTclClassInfoInstinvarMethodStub, { - {"class", 1, 0, "class"}} + {"class", 1, 0, convertToClass}} }, {"::xotcl::cmd::ClassInfo::instmixin", XOTclClassInfoInstmixinMethodStub, { - {"class", 1, 0, "class"}, - {"-closure", 0, 0, NULL}, - {"-guards", 0, 0, NULL}, - {"pattern", 0, 0, "objpattern"}} + {"class", 1, 0, convertToClass}, + {"-closure", 0, 0, convertToString}, + {"-guards", 0, 0, convertToString}, + {"pattern", 0, 0, convertToObjpattern}} }, {"::xotcl::cmd::ClassInfo::instmixinguard", XOTclClassInfoInstmixinguardMethodStub, { - {"class", 1, 0, "class"}, - {"mixin", 1, 0, NULL}} + {"class", 1, 0, convertToClass}, + {"mixin", 1, 0, convertToString}} }, {"::xotcl::cmd::ClassInfo::instmixinof", XOTclClassInfoInstmixinofMethodStub, { - {"class", 1, 0, "class"}, - {"-closure", 0, 0, NULL}, - {"pattern", 0, 0, "objpattern"}} + {"class", 1, 0, convertToClass}, + {"-closure", 0, 0, convertToString}, + {"pattern", 0, 0, convertToObjpattern}} }, {"::xotcl::cmd::ClassInfo::instnonposargs", XOTclClassInfoInstnonposargsMethodStub, { - {"class", 1, 0, "class"}, - {"methodName", 1, 0, NULL}} + {"class", 1, 0, convertToClass}, + {"methodName", 1, 0, convertToString}} }, {"::xotcl::cmd::ClassInfo::instparametercmd", XOTclClassInfoInstparametercmdMethodStub, { - {"class", 1, 0, "class"}, - {"pattern", 0, 0, NULL}} + {"class", 1, 0, convertToClass}, + {"pattern", 0, 0, convertToString}} }, {"::xotcl::cmd::ClassInfo::instpost", XOTclClassInfoInstpostMethodStub, { - {"class", 1, 0, "class"}, - {"methodName", 1, 0, NULL}} + {"class", 1, 0, convertToClass}, + {"methodName", 1, 0, convertToString}} }, {"::xotcl::cmd::ClassInfo::instpre", XOTclClassInfoInstpreMethodStub, { - {"class", 1, 0, "class"}, - {"methodName", 1, 0, NULL}} + {"class", 1, 0, convertToClass}, + {"methodName", 1, 0, convertToString}} }, {"::xotcl::cmd::ClassInfo::instprocs", XOTclClassInfoInstprocsMethodStub, { - {"class", 1, 0, "class"}, - {"pattern", 0, 0, NULL}} + {"class", 1, 0, convertToClass}, + {"pattern", 0, 0, convertToString}} }, {"::xotcl::cmd::ClassInfo::mixinof", XOTclClassInfoMixinofMethodStub, { - {"class", 1, 0, "class"}, - {"-closure", 0, 0, NULL}, - {"pattern", 0, 0, "objpattern"}} + {"class", 1, 0, convertToClass}, + {"-closure", 0, 0, convertToString}, + {"pattern", 0, 0, convertToObjpattern}} }, {"::xotcl::cmd::ClassInfo::parameter", XOTclClassInfoParameterMethodStub, { - {"class", 1, 0, "class"}} + {"class", 1, 0, convertToClass}} }, {"::xotcl::cmd::ClassInfo::slots", XOTclClassInfoSlotsMethodStub, { - {"class", 1, 0, "class"}} + {"class", 1, 0, convertToClass}} }, {"::xotcl::cmd::ClassInfo::subclass", XOTclClassInfoSubclassMethodStub, { - {"class", 1, 0, "class"}, - {"-closure", 0, 0, NULL}, - {"pattern", 0, 0, "objpattern"}} + {"class", 1, 0, convertToClass}, + {"-closure", 0, 0, convertToString}, + {"pattern", 0, 0, convertToObjpattern}} }, {"::xotcl::cmd::ClassInfo::superclass", XOTclClassInfoSuperclassMethodStub, { - {"class", 1, 0, "class"}, - {"-closure", 0, 0, NULL}, - {"pattern", 0, 0, "tclobj"}} + {"class", 1, 0, convertToClass}, + {"-closure", 0, 0, convertToString}, + {"pattern", 0, 0, convertToTclobj}} }, {"::xotcl::cmd::ObjectInfo::args", XOTclObjInfoArgsMethodStub, { - {"object", 1, 0, "object"}, - {"methodName", 1, 0, NULL}} + {"object", 1, 0, convertToObject}, + {"methodName", 1, 0, convertToString}} }, {"::xotcl::cmd::ObjectInfo::body", XOTclObjInfoBodyMethodStub, { - {"object", 1, 0, "object"}, - {"methodName", 1, 0, NULL}} + {"object", 1, 0, convertToObject}, + {"methodName", 1, 0, convertToString}} }, {"::xotcl::cmd::ObjectInfo::check", XOTclObjInfoCheckMethodStub, { - {"object", 1, 0, "object"}} + {"object", 1, 0, convertToObject}} }, {"::xotcl::cmd::ObjectInfo::children", XOTclObjInfoChildrenMethodStub, { - {"object", 1, 0, "object"}, - {"pattern", 0, 0, NULL}} + {"object", 1, 0, convertToObject}, + {"pattern", 0, 0, convertToString}} }, {"::xotcl::cmd::ObjectInfo::class", XOTclObjInfoClassMethodStub, { - {"object", 1, 0, "object"}} + {"object", 1, 0, convertToObject}} }, {"::xotcl::cmd::ObjectInfo::commands", XOTclObjInfoCommandsMethodStub, { - {"object", 1, 0, "object"}, - {"pattern", 0, 0, NULL}} + {"object", 1, 0, convertToObject}, + {"pattern", 0, 0, convertToString}} }, {"::xotcl::cmd::ObjectInfo::default", XOTclObjInfoDefaultMethodStub, { - {"object", 1, 0, "object"}, - {"methodName", 1, 0, NULL}, - {"arg", 1, 0, NULL}, - {"var", 1, 0, "tclobj"}} + {"object", 1, 0, convertToObject}, + {"methodName", 1, 0, convertToString}, + {"arg", 1, 0, convertToString}, + {"var", 1, 0, convertToTclobj}} }, {"::xotcl::cmd::ObjectInfo::filter", XOTclObjInfoFilterMethodStub, { - {"object", 1, 0, "object"}, - {"-order", 0, 0, NULL}, - {"-guards", 0, 0, NULL}, - {"pattern", 0, 0, NULL}} + {"object", 1, 0, convertToObject}, + {"-order", 0, 0, convertToString}, + {"-guards", 0, 0, convertToString}, + {"pattern", 0, 0, convertToString}} }, {"::xotcl::cmd::ObjectInfo::filterguard", XOTclObjInfoFilterguardMethodStub, { - {"object", 1, 0, "object"}, - {"filter", 1, 0, NULL}} + {"object", 1, 0, convertToObject}, + {"filter", 1, 0, convertToString}} }, {"::xotcl::cmd::ObjectInfo::forward", XOTclObjInfoForwardMethodStub, { - {"object", 1, 0, "object"}, - {"-definition", 0, 0, NULL}, - {"pattern", 0, 0, NULL}} + {"object", 1, 0, convertToObject}, + {"-definition", 0, 0, convertToString}, + {"pattern", 0, 0, convertToString}} }, {"::xotcl::cmd::ObjectInfo::hasnamespace", XOTclObjInfoHasnamespaceMethodStub, { - {"object", 1, 0, "object"}} + {"object", 1, 0, convertToObject}} }, {"::xotcl::cmd::ObjectInfo::invar", XOTclObjInfoInvarMethodStub, { - {"object", 1, 0, "object"}} + {"object", 1, 0, convertToObject}} }, {"::xotcl::cmd::ObjectInfo::methods", XOTclObjInfoMethodsMethodStub, { - {"object", 1, 0, "object"}, - {"-noprocs", 0, 0, NULL}, - {"-nocmds", 0, 0, NULL}, - {"-nomixins", 0, 0, NULL}, - {"-incontext", 0, 0, NULL}, - {"pattern", 0, 0, NULL}} + {"object", 1, 0, convertToObject}, + {"-noprocs", 0, 0, convertToString}, + {"-nocmds", 0, 0, convertToString}, + {"-nomixins", 0, 0, convertToString}, + {"-incontext", 0, 0, convertToString}, + {"pattern", 0, 0, convertToString}} }, {"::xotcl::cmd::ObjectInfo::mixin", XOTclObjInfoMixinMethodStub, { - {"object", 1, 0, "object"}, - {"-guards", 0, 0, NULL}, - {"-order", 0, 0, NULL}, - {"pattern", 0, 0, "objpattern"}} + {"object", 1, 0, convertToObject}, + {"-guards", 0, 0, convertToString}, + {"-order", 0, 0, convertToString}, + {"pattern", 0, 0, convertToObjpattern}} }, {"::xotcl::cmd::ObjectInfo::mixinguard", XOTclObjInfoMixinguardMethodStub, { - {"object", 1, 0, "object"}, - {"mixin", 1, 0, NULL}} + {"object", 1, 0, convertToObject}, + {"mixin", 1, 0, convertToString}} }, {"::xotcl::cmd::ObjectInfo::nonposargs", XOTclObjInfoNonposargsMethodStub, { - {"object", 1, 0, "object"}, - {"methodName", 1, 0, NULL}} + {"object", 1, 0, convertToObject}, + {"methodName", 1, 0, convertToString}} }, {"::xotcl::cmd::ObjectInfo::parametercmd", XOTclObjInfoParametercmdMethodStub, { - {"object", 1, 0, "object"}, - {"pattern", 0, 0, NULL}} + {"object", 1, 0, convertToObject}, + {"pattern", 0, 0, convertToString}} }, {"::xotcl::cmd::ObjectInfo::parent", XOTclObjInfoParentMethodStub, { - {"object", 1, 0, "object"}} + {"object", 1, 0, convertToObject}} }, {"::xotcl::cmd::ObjectInfo::post", XOTclObjInfoPostMethodStub, { - {"object", 1, 0, "object"}, - {"methodName", 1, 0, NULL}} + {"object", 1, 0, convertToObject}, + {"methodName", 1, 0, convertToString}} }, {"::xotcl::cmd::ObjectInfo::pre", XOTclObjInfoPreMethodStub, { - {"object", 1, 0, "object"}, - {"methodName", 1, 0, NULL}} + {"object", 1, 0, convertToObject}, + {"methodName", 1, 0, convertToString}} }, {"::xotcl::cmd::ObjectInfo::precedence", XOTclObjInfoPrecedenceMethodStub, { - {"object", 1, 0, "object"}, - {"-intrinsic", 0, 0, NULL}, - {"pattern", 0, 0, NULL}} + {"object", 1, 0, convertToObject}, + {"-intrinsic", 0, 0, convertToString}, + {"pattern", 0, 0, convertToString}} }, {"::xotcl::cmd::ObjectInfo::procs", XOTclObjInfoProcsMethodStub, { - {"object", 1, 0, "object"}, - {"pattern", 0, 0, NULL}} + {"object", 1, 0, convertToObject}, + {"pattern", 0, 0, convertToString}} }, {"::xotcl::cmd::ObjectInfo::slotobjects", XOTclObjInfoSlotObjectsMethodStub, { - {"object", 1, 0, "object"}, - {"pattern", 0, 0, NULL}} + {"object", 1, 0, convertToObject}, + {"pattern", 0, 0, convertToString}} }, {"::xotcl::cmd::ObjectInfo::vars", XOTclObjInfoVarsMethodStub, { - {"object", 1, 0, "object"}, - {"pattern", 0, 0, NULL}} + {"object", 1, 0, convertToObject}, + {"pattern", 0, 0, convertToString}} }, {"::xotcl::cmd::Object::autoname", XOTclOAutonameMethodStub, { - {"-instance", 0, 0, NULL}, - {"-reset", 0, 0, NULL}, - {"name", 1, 0, "tclobj"}} + {"-instance", 0, 0, convertToString}, + {"-reset", 0, 0, convertToString}, + {"name", 1, 0, convertToTclobj}} }, {"::xotcl::cmd::Object::check", XOTclOCheckMethodStub, { - {"flag", 1, 0, "tclobj"}} + {"flag", 1, 0, convertToTclobj}} }, {"::xotcl::cmd::Object::cleanup", XOTclOCleanupMethodStub, { } }, {"::xotcl::cmd::Object::configure", XOTclOConfigureMethodStub, { - {"args", 0, 0, "allargs"}} + {"args", 0, 0, convertToNothing}} }, {"::xotcl::cmd::Object::destroy", XOTclODestroyMethodStub, { } }, {"::xotcl::cmd::Object::exists", XOTclOExistsMethodStub, { - {"var", 1, 0, NULL}} + {"var", 1, 0, convertToString}} }, {"::xotcl::cmd::Object::filterguard", XOTclOFilterGuardMethodStub, { - {"filter", 1, 0, NULL}, - {"guard", 1, 0, "tclobj"}} + {"filter", 1, 0, convertToString}, + {"guard", 1, 0, convertToTclobj}} }, {"::xotcl::cmd::Object::filtersearch", XOTclOFilterSearchMethodStub, { - {"filter", 1, 0, NULL}} + {"filter", 1, 0, convertToString}} }, {"::xotcl::cmd::Object::forward", XOTclOForwardMethodStub, { - {"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"}} + {"method", 1, 0, convertToTclobj}, + {"-default", 0, 1, convertToTclobj}, + {"-earlybinding", 0, 0, convertToString}, + {"-methodprefix", 0, 1, convertToTclobj}, + {"-objscope", 0, 0, convertToString}, + {"-onerror", 0, 1, convertToTclobj}, + {"-verbose", 0, 0, convertToString}, + {"target", 0, 0, convertToTclobj}, + {"args", 0, 0, convertToNothing}} }, {"::xotcl::cmd::Object::instvar", XOTclOInstVarMethodStub, { - {"args", 0, 0, "allargs"}} + {"args", 0, 0, convertToNothing}} }, {"::xotcl::cmd::Object::invar", XOTclOInvariantsMethodStub, { - {"invariantlist", 1, 0, "tclobj"}} + {"invariantlist", 1, 0, convertToTclobj}} }, {"::xotcl::cmd::Object::isclass", XOTclOIsClassMethodStub, { - {"class", 0, 0, "tclobj"}} + {"class", 0, 0, convertToTclobj}} }, {"::xotcl::cmd::Object::ismetaclass", XOTclOIsMetaClassMethodStub, { - {"metaclass", 0, 0, "tclobj"}} + {"metaclass", 0, 0, convertToTclobj}} }, {"::xotcl::cmd::Object::ismixin", XOTclOIsMixinMethodStub, { - {"class", 1, 0, "tclobj"}} + {"class", 1, 0, convertToTclobj}} }, {"::xotcl::cmd::Object::isobject", XOTclOIsObjectMethodStub, { - {"object", 1, 0, "tclobj"}} + {"object", 1, 0, convertToTclobj}} }, {"::xotcl::cmd::Object::istype", XOTclOIsTypeMethodStub, { - {"class", 1, 0, "tclobj"}} + {"class", 1, 0, convertToTclobj}} }, {"::xotcl::cmd::Object::mixinguard", XOTclOMixinGuardMethodStub, { - {"mixin", 1, 0, NULL}, - {"guard", 1, 0, "tclobj"}} + {"mixin", 1, 0, convertToString}, + {"guard", 1, 0, convertToTclobj}} }, {"::xotcl::cmd::Object::__next", XOTclONextMethodStub, { - {"args", 0, 0, "allargs"}} + {"args", 0, 0, convertToNothing}} }, {"::xotcl::cmd::Object::noinit", XOTclONoinitMethodStub, { } }, {"::xotcl::cmd::Object::parametercmd", XOTclOParametercmdMethodStub, { - {"name", 1, 0, NULL}} + {"name", 1, 0, convertToString}} }, {"::xotcl::cmd::Object::proc", XOTclOProcMethodStub, { - {"name", 1, 0, "tclobj"}, - {"args", 1, 0, "tclobj"}, - {"body", 1, 0, "tclobj"}, - {"precondition", 0, 0, "tclobj"}, - {"postcondition", 0, 0, "tclobj"}} + {"name", 1, 0, convertToTclobj}, + {"args", 1, 0, convertToTclobj}, + {"body", 1, 0, convertToTclobj}, + {"precondition", 0, 0, convertToTclobj}, + {"postcondition", 0, 0, convertToTclobj}} }, {"::xotcl::cmd::Object::procsearch", XOTclOProcSearchMethodStub, { - {"name", 1, 0, NULL}} + {"name", 1, 0, convertToString}} }, {"::xotcl::cmd::Object::requireNamespace", XOTclORequireNamespaceMethodStub, { } }, {"::xotcl::cmd::Object::set", XOTclOSetMethodStub, { - {"var", 1, 0, "tclobj"}, - {"value", 0, 0, "tclobj"}} + {"var", 1, 0, convertToTclobj}, + {"value", 0, 0, convertToTclobj}} }, {"::xotcl::cmd::Object::setvalues", XOTclOSetvaluesMethodStub, { - {"args", 0, 0, "allargs"}} + {"args", 0, 0, convertToNothing}} }, {"::xotcl::cmd::Object::uplevel", XOTclOUplevelMethodStub, { - {"args", 0, 0, "allargs"}} + {"args", 0, 0, convertToNothing}} }, {"::xotcl::cmd::Object::upvar", XOTclOUpvarMethodStub, { - {"args", 0, 0, "allargs"}} + {"args", 0, 0, convertToNothing}} }, {"::xotcl::cmd::Object::volatile", XOTclOVolatileMethodStub, { } }, {"::xotcl::cmd::Object::vwait", XOTclOVwaitMethodStub, { - {"varname", 1, 0, NULL}} + {"varname", 1, 0, convertToString}} }, {"::xotcl::alias", XOTclAliasCmdStub, { - {"object", 1, 0, "object"}, - {"methodName", 1, 0, NULL}, - {"-objscope", 0, 0, NULL}, - {"-per-object", 0, 0, NULL}, - {"-protected", 0, 0, NULL}, - {"cmdName", 1, 0, "tclobj"}} + {"object", 1, 0, convertToObject}, + {"methodName", 1, 0, convertToString}, + {"-objscope", 0, 0, convertToString}, + {"-per-object", 0, 0, convertToString}, + {"-protected", 0, 0, convertToString}, + {"cmdName", 1, 0, convertToTclobj}} }, +{"::xotcl::methodproperty", XOTclMethodPropertyCmdStub, { + {"object", 1, 0, convertToObject}, + {"methodName", 1, 0, convertToString}, + {"-per-object", 0, 0, convertToString}, + {"protected|public|slotobj", 1, 0, convertToMethodproperty}, + {"value", 0, 0, convertToTclobj}} +}, {"::xotcl::my", XOTclMyCmdStub, { - {"-local", 0, 0, NULL}, - {"method", 1, 0, "tclobj"}, - {"args", 0, 0, "args"}} + {"-local", 0, 0, convertToString}, + {"method", 1, 0, convertToTclobj}, + {"args", 0, 0, convertToNothing}} }, {"::xotcl::relation", XOTclRelationCmdStub, { - {"object", 1, 0, "object"}, - {"reltype", 1, 0, "tclobj"}, - {"value", 0, 0, "tclobj"}} + {"object", 1, 0, convertToObject}, + {"mixin|instmixin|object-mixin|class-mixin|filter|instfilter|object-filter|class_filter|class|superclass|rootclass", 1, 0, convertToRelationtype}, + {"value", 0, 0, convertToTclobj}} }, {"::xotcl::setinstvar", XOTclSetInstvarCmdStub, { - {"object", 1, 0, "object"}, - {"variable", 1, 0, "tclobj"}, - {"value", 0, 0, "tclobj"}} + {"object", 1, 0, convertToObject}, + {"variable", 1, 0, convertToTclobj}, + {"value", 0, 0, convertToTclobj}} } }; Index: generic/xotcl.c =================================================================== diff -u -r108d81ec266a27d011953bdc6b7d8b32eb0afcc7 -r321a21cbb0beec854bfc651e167c32ded2707a3a --- generic/xotcl.c (.../xotcl.c) (revision 108d81ec266a27d011953bdc6b7d8b32eb0afcc7) +++ generic/xotcl.c (.../xotcl.c) (revision 321a21cbb0beec854bfc651e167c32ded2707a3a) @@ -155,11 +155,13 @@ int lastobjc; } parseContext; +typedef int (XOTclTypeConverter) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *obj, ClientData *clientData)); + typedef struct { char *name; int required; int nrargs; - char *type; + XOTclTypeConverter *type; char *defaultValue; } argDefinition; @@ -8353,22 +8355,11 @@ GetInstVarIntoCurrentScope(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *varName, Tcl_Obj *newName) { Var *varPtr = NULL, *otherPtr = NULL, *arrayPtr; - int new; + int new, flgs = TCL_LEAVE_ERR_MSG; Tcl_CallFrame *varFramePtr; TclVarHashTable *tablePtr; XOTcl_FrameDecls; - int flgs = TCL_LEAVE_ERR_MSG | - /* PARSE_PART1 needed for 8.0.5 */ TCL_PARSE_PART1; -#if 0 - /* why do we need to deal with vars with namepaces paths? */ - if (newName && strstr(varName, "::")) { - /* the source variable name contains a namespace path. to locate it, we need a namespace */ - requireObjNamespace(interp, obj); - } - /*fprintf(stderr,"GetIntoScope obj=%s ns=%p newName=%s\n", objectName(obj), obj->nsPtr, newName);*/ -#endif - XOTcl_PushFrame(interp, obj); if (obj->nsPtr) { flgs = flgs|TCL_NAMESPACE_ONLY; @@ -8982,135 +8973,6 @@ } static int -XOTclMethodPropertyCmd(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = NULL; - XOTclClass *cl = NULL; - Tcl_Command cmd = NULL; - char allocation, *methodName, *optionName; - int protected = 0, i, opt; - - static CONST char *opts[] = {"protected", "public", "slotobj", NULL}; - enum subCmdIdx {protectedIdx, publicIdx, soltobjIdx}; - - /* TODO: introspection for method properties */ - - if (objc < 4 || objc > 6) { - return XOTclObjErrArgCnt(interp, objv[0], NULL, - "| ?-per-object? ??"); - } - - GetXOTclClassFromObj(interp, objv[1], &cl, 0); - if (!cl) { - XOTclObjConvertObject(interp, objv[1], &obj); - if (!obj) - return XOTclVarErrMsg(interp, ObjStr(objv[0]), - " should be called on Class|Object, not ", - ObjStr(objv[1]), NULL); - allocation = 'o'; - } else { - obj = &cl->object; - allocation = 'c'; - } - - methodName = ObjStr(objv[2]); - - for (i=3; i<5 && i < objc; i++) { - optionName = ObjStr(objv[i]); - if (*optionName != '-') break; - if (!strcmp("-per-object", optionName)) { - allocation = 'o'; - if (cl) obj = &(cl->object); - } else { - return XOTclErrBadVal(interp, "::xotcl::methodproperty", - "option -per-object", optionName); - } - } - - if (Tcl_GetIndexFromObj(interp, objv[i], opts, "methodproperty", 0, &opt) != TCL_OK) { - return TCL_ERROR; - } - - /*fprintf(stderr, "allocation for %s = %c\n", ObjStr(objv[1]), allocation);*/ - - if (allocation == 'o') { /* xxx */ - if (obj->nsPtr) - cmd = FindMethod(methodName, obj->nsPtr); - if (!cmd) { - return XOTclVarErrMsg(interp, ObjStr(objv[0]), - " cannot lookup object method '", - methodName, "' for object ", ObjStr(objv[1]), - (char *) NULL); - } - } else { - if (cl->nsPtr) - cmd = FindMethod(methodName, cl->nsPtr); - if (!cmd) - return XOTclVarErrMsg(interp, ObjStr(objv[0]), " cannot lookup method '", - methodName, "' from class ", ObjStr(objv[1]), - (char *) NULL); - } - - if (opt == protectedIdx || opt == publicIdx) { - protected = (opt == protectedIdx); - - if (protected) { - Tcl_Command_flags(cmd) |= XOTCL_PROTECTED_METHOD; - } else { - Tcl_Command_flags(cmd) &= XOTCL_PROTECTED_METHOD; - } - } else { /* slotobj */ - Tcl_HashTable **nonposArgsTable = allocation == 'o' ? - &(obj->nonposArgsTable) : - &(cl->nonposArgsTable); - XOTclNonposArgs *nonposArgs; - - if (i + 2 != objc) { - return XOTclObjErrArgCnt(interp, objv[0], NULL, - "| ?-per-object? slotobj "); - } - - if (*nonposArgsTable == 0) { - *nonposArgsTable = NonposArgsCreateTable(); - fprintf(stderr,"this can only happen if we define a slotobj for a class/object without nonposargs\n"); - } - nonposArgs = NonposArgsGet(*nonposArgsTable, methodName); - if (nonposArgs == NULL) { - int nw; - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(*nonposArgsTable, methodName, &nw); - assert(nw); - - fprintf(stderr,"this can only happen if we define a slotobj for a method without nonpospargs\n slotobj = %s\n", ObjStr(objv[i+1])); - - MEM_COUNT_ALLOC("nonposArg", nonposArgs); - nonposArgs = (XOTclNonposArgs*)ckalloc(sizeof(XOTclNonposArgs)); - nonposArgs->slotObj = NULL; - nonposArgs->nonposArgs = NULL; - nonposArgs->ordinaryArgs = NULL; - Tcl_SetHashValue(hPtr, (ClientData)nonposArgs); - - /* TODO check: - problem with nonposArgs->nonposArgs = NULL ? - problem with nonposArgs->ordinaryArgs = NULL ? - - what happens if first method property and then method. - what happens if method then property then new method? - */ - } else { - - fprintf(stderr,"define slotobj for a method with nonpospargs\n slotobj = %s \n", ObjStr(objv[i+1])); - if (nonposArgs->slotObj) { - DECR_REF_COUNT(nonposArgs->slotObj); - } - } - nonposArgs->slotObj = objv[i+1]; - INCR_REF_COUNT(nonposArgs->slotObj); - } - - return TCL_OK; -} - -static int XOTclDispatchCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { int result; @@ -9469,72 +9331,58 @@ /*********************************** * objv parser and objv converter ***********************************/ +static int convertToString(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientData) { + *clientData = (char *)ObjStr(objPtr); + return TCL_OK; +} +static int convertToTclobj(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientData) { + *clientData = (ClientData)objPtr; + return TCL_OK; +} -static int -convertToType(Tcl_Interp *interp, Tcl_Obj *objPtr, char *type, ClientData *clientData) { +static int convertToNothing(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientData) { + return TCL_OK; +} - if (type == NULL) { - *clientData = (char *)ObjStr(objPtr); +static int convertToClass(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientData) { + if (GetXOTclClassFromObj(interp, objPtr, (XOTclClass **)clientData, 0) == TCL_OK) return TCL_OK; - } + return XOTclObjErrType(interp, objPtr, "class"); +} - switch (*type) { - case 'a': - if (strcmp(type,"allargs") == 0 || strcmp(type,"args") == 0) { - break; - } - case 'c': - if (strcmp(type,"class") == 0) { - if (GetXOTclClassFromObj(interp, objPtr, (XOTclClass **)clientData, 0) == TCL_OK) - break; - return XOTclObjErrType(interp, objPtr, type); - } - case 'o': - { - if (strcmp(type,"object") == 0) { - if (XOTclObjConvertObject(interp, objPtr, (XOTclObject **)clientData) == TCL_OK) - break; - return XOTclObjErrType(interp, objPtr, type); - } +static int convertToObject(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientData) { + if (XOTclObjConvertObject(interp, objPtr, (XOTclObject **)clientData) == TCL_OK) + return TCL_OK; + return XOTclObjErrType(interp, objPtr, "object"); +} - if (strcmp(type,"objpattern") == 0) { - Tcl_Obj *patternObj = objPtr; - char *pattern = ObjStr(objPtr); +static int convertToObjpattern(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientData) { + Tcl_Obj *patternObj = objPtr; + char *pattern = ObjStr(objPtr); - if (noMetaChars(pattern)) { - /* we have no meta characters, we try to check for an existing object */ - XOTclObject *obj = NULL; - XOTclObjConvertObject(interp, objPtr, &obj); - if (obj) { - patternObj = obj->cmdName; - } - } else { - /* - * We have a pattern and meta characters, we might have - * to prefix it to ovoid abvious errors: since all object - * names are prefixed with ::, we add this prefix automatically - * to the match pattern, if it does not exist - */ - if (*pattern != ':' && *pattern+1 != ':') { - patternObj = Tcl_NewStringObj("::", 2); - Tcl_AppendToObj(patternObj, pattern, -1); - } - } - if (patternObj) { - INCR_REF_COUNT(patternObj); - } - *clientData = (ClientData)patternObj; - } - break; + if (noMetaChars(pattern)) { + /* we have no meta characters, we try to check for an existing object */ + XOTclObject *obj = NULL; + XOTclObjConvertObject(interp, objPtr, &obj); + if (obj) { + patternObj = obj->cmdName; } - case 't': - if (strcmp(type,"tclobj") == 0) { - *clientData = (ClientData)objPtr; - break; - } - default: - return TCL_ERROR; + } else { + /* + * We have a pattern and meta characters, we might have + * to prefix it to ovoid abvious errors: since all object + * names are prefixed with ::, we add this prefix automatically + * to the match pattern, if it does not exist + */ + if (*pattern != ':' && *pattern+1 != ':') { + patternObj = Tcl_NewStringObj("::", 2); + Tcl_AppendToObj(patternObj, pattern, -1); + } } + if (patternObj) { + INCR_REF_COUNT(patternObj); + } + *clientData = (ClientData)patternObj; return TCL_OK; } @@ -9577,7 +9425,7 @@ /*fprintf(stderr, "flag '%s' o=%d p=%d, objc=%d\n",objStr,o,p,objc);*/ if (otype, &pc->clientData[bPtr-ifdPtr[0]]) != TCL_OK) { + if ((*aPtr->type)(interp, objv[o], &pc->clientData[bPtr-ifdPtr[0]]) != TCL_OK) { return TCL_ERROR; } } else { @@ -9610,7 +9458,7 @@ /*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 (convertToType(interp, objv[o], aPtr->type, &pc->clientData[i]) != TCL_OK) { + if ((*aPtr->type)(interp, objv[o], &pc->clientData[i]) != TCL_OK) { return TCL_ERROR; } @@ -9632,8 +9480,7 @@ /* is last argument a vararg? */ aPtr--; - if (!varArgs && aPtr->type && - (strcmp(aPtr->type,"args") == 0 || strcmp(aPtr->type,"allargs") == 0)) { + if (!varArgs && aPtr->type == convertToNothing) { varArgs = 1; /*fprintf(stderr, "last arg is varargs\n");*/ } @@ -9919,7 +9766,7 @@ char *patternString = NULL; int rc; - if (pattern && convertToType(interp, pattern, "objpattern", (ClientData *)&patternObj) == TCL_OK) { + if (pattern && convertToObjpattern(interp, pattern, (ClientData *)&patternObj) == TCL_OK) { if (getMatchObject(interp, patternObj, pattern, &matchObject, &patternString) == -1) { if (patternObj) { DECR_REF_COUNT(patternObj); @@ -10119,6 +9966,103 @@ return TCL_OK; } +static int XOTclMethodPropertyCmd(Tcl_Interp *interp, XOTclObject *object, char *methodName, + int withPer_object, int methodproperty, Tcl_Obj *value) { + XOTclClass *cl; + Tcl_Command cmd = NULL; + char allocation; + int protected = 0; + + /* TODO: introspection for method properties */ + + if (XOTclObjectIsClass(object)) { + cl = (XOTclClass *)object; + allocation = 'c'; + } else { + cl = NULL; + allocation = 'o'; + } + + if (withPer_object) { + allocation = 'o'; + } + + if (allocation == 'o') { + if (object->nsPtr) + cmd = FindMethod(methodName, object->nsPtr); + if (!cmd) { + return XOTclVarErrMsg(interp, "Cannot lookup object method '", + methodName, "' for object ", objectName(object), + (char *) NULL); + } + } else { + if (cl->nsPtr) + cmd = FindMethod(methodName, cl->nsPtr); + if (!cmd) + return XOTclVarErrMsg(interp, "Cannot lookup method '", + methodName, "' from class ", objectName(object), + (char *) NULL); + } + + if (methodproperty == methodpropertyProtectedIdx || methodproperty == methodpropertyPublicIdx) { + protected = (methodproperty == methodpropertyProtectedIdx); + + if (protected) { + Tcl_Command_flags(cmd) |= XOTCL_PROTECTED_METHOD; + } else { + Tcl_Command_flags(cmd) &= XOTCL_PROTECTED_METHOD; + } + } else { /* slotobj */ + Tcl_HashTable **nonposArgsTable = allocation == 'o' ? + &(object->nonposArgsTable) : + &(cl->nonposArgsTable); + XOTclNonposArgs *nonposArgs; + + if (value == NULL) { + return XOTclVarErrMsg(interp, "Option 'slotobj' of method ",methodName, + " requires argument '", (char *) NULL); + } + + if (*nonposArgsTable == 0) { + *nonposArgsTable = NonposArgsCreateTable(); + fprintf(stderr,"this can only happen if we define a slotobj for a class/object without nonposargs\n"); + } + nonposArgs = NonposArgsGet(*nonposArgsTable, methodName); + if (nonposArgs == NULL) { + int nw; + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(*nonposArgsTable, methodName, &nw); + assert(nw); + + fprintf(stderr,"this can only happen if we define a slotobj for a method without nonpospargs\n slotobj = %s\n", ObjStr(value)); + + MEM_COUNT_ALLOC("nonposArg", nonposArgs); + nonposArgs = (XOTclNonposArgs*)ckalloc(sizeof(XOTclNonposArgs)); + nonposArgs->slotObj = NULL; + nonposArgs->nonposArgs = NULL; + nonposArgs->ordinaryArgs = NULL; + Tcl_SetHashValue(hPtr, (ClientData)nonposArgs); + + /* TODO check: + problem with nonposArgs->nonposArgs = NULL ? + problem with nonposArgs->ordinaryArgs = NULL ? + + what happens if first method property and then method. + what happens if method then property then new method? + */ + } else { + + fprintf(stderr,"define slotobj for a method with nonpospargs\n slotobj = %s \n", ObjStr(value)); + if (nonposArgs->slotObj) { + DECR_REF_COUNT(nonposArgs->slotObj); + } + } + nonposArgs->slotObj = value; + INCR_REF_COUNT(nonposArgs->slotObj); + } + + return TCL_OK; +} + static int XOTclMyCmd(Tcl_Interp *interp, int withLocal, Tcl_Obj *method, int nobjc, Tcl_Obj *CONST nobjv[]) { XOTclObject *self = GetSelfObj(interp); int result; @@ -10145,52 +10089,37 @@ } -static int XOTclRelationCmd(Tcl_Interp *interp, XOTclObject *object, Tcl_Obj *reltype, Tcl_Obj *value) { +static int XOTclRelationCmd(Tcl_Interp *interp, XOTclObject *object, int relationtype, Tcl_Obj *value) { int oc; Tcl_Obj **ov; XOTclObject *nobj = NULL; XOTclClass *cl = NULL; XOTclObjectOpt *objopt = NULL; XOTclClassOpt *clopt = NULL, *nclopt = NULL; - int i, opt; - static CONST char *opts[] = { - "mixin", "instmixin", "object-mixin", "class-mixin", - "filter", "instfilter", "object-filter", "class-filter", - "class", "superclass", "rootclass", - NULL - }; - enum subCmdIdx { - mixinIdx, instmixinIdx, pomIdx, pcmIdx, - filterIdx, instfilterIdx, pofIdx, pcfIdx, - classIdx, superclassIdx, rootclassIdx - }; - - if (Tcl_GetIndexFromObj(interp, reltype, opts, "relation type", 0, &opt) != TCL_OK) { - return TCL_ERROR; - } + int i; - switch (opt) { - case pomIdx: - case mixinIdx: - case pofIdx: - case filterIdx: + switch (relationtype) { + case relationtypeObject_mixinIdx: + case relationtypeMixinIdx: + case relationtypeObject_filterIdx: + case relationtypeFilterIdx: if (value == NULL) { objopt = object->opt; - switch (opt) { - case pomIdx: - case mixinIdx: return objopt ? MixinInfo(interp, objopt->mixins, NULL, 1, NULL) : TCL_OK; - case pofIdx: - case filterIdx: return objopt ? FilterInfo(interp, objopt->filters, NULL, 1, 0) : TCL_OK; + switch (relationtype) { + case relationtypeObject_mixinIdx: + case relationtypeMixinIdx: return objopt ? MixinInfo(interp, objopt->mixins, NULL, 1, NULL) : TCL_OK; + case relationtypeObject_filterIdx: + case relationtypeFilterIdx: return objopt ? FilterInfo(interp, objopt->filters, NULL, 1, 0) : TCL_OK; } } if (Tcl_ListObjGetElements(interp, value, &oc, &ov) != TCL_OK) return TCL_ERROR; objopt = XOTclRequireObjectOpt(object); break; - case pcmIdx: - case instmixinIdx: - case pcfIdx: - case instfilterIdx: + case relationtypeClass_mixinIdx: + case relationtypeInstmixinIdx: + case relationtypeClass_filterIdx: + case relationtypeInstfilterIdx: if (XOTclObjectIsClass(object)) { cl = (XOTclClass *)object; } else { @@ -10199,11 +10128,11 @@ if (value == NULL) { clopt = cl->opt; - switch (opt) { - case pcmIdx: - case instmixinIdx: return clopt ? MixinInfo(interp, clopt->instmixins, NULL, 1, NULL) : TCL_OK; - case pcfIdx: - case instfilterIdx: return objopt ? FilterInfo(interp, clopt->instfilters, NULL, 1, 0) : TCL_OK; + switch (relationtype) { + case relationtypeClass_mixinIdx: + case relationtypeInstmixinIdx: return clopt ? MixinInfo(interp, clopt->instmixins, NULL, 1, NULL) : TCL_OK; + case relationtypeClass_filterIdx: + case relationtypeInstfilterIdx: return objopt ? FilterInfo(interp, clopt->instfilters, NULL, 1, 0) : TCL_OK; } } @@ -10212,7 +10141,7 @@ clopt = XOTclRequireClassOpt(cl); break; - case superclassIdx: + case relationtypeSuperclassIdx: if (!XOTclObjectIsClass(object)) return XOTclObjErrType(interp, object->cmdName, "Class"); cl = (XOTclClass *)object; @@ -10223,7 +10152,7 @@ return TCL_ERROR; return SuperclassAdd(interp, cl, oc, ov, value, cl->object.cl); - case classIdx: + case relationtypeClassIdx: if (value == NULL) { Tcl_SetObjResult(interp, object->cl->object.cmdName); return TCL_OK; @@ -10232,7 +10161,7 @@ if (!cl) return XOTclErrBadVal(interp, "class", "a class", objectName(object)); return changeClass(interp, object, cl); - case rootclassIdx: + case relationtypeRootclassIdx: { XOTclClass *metaClass; @@ -10259,9 +10188,9 @@ } } - switch (opt) { - case pomIdx: - case mixinIdx: + switch (relationtype) { + case relationtypeObject_mixinIdx: + case relationtypeMixinIdx: if (objopt->mixins) { XOTclCmdList *cmdlist, *del; for (cmdlist = objopt->mixins; cmdlist; cmdlist = cmdlist->nextPtr) { @@ -10311,8 +10240,8 @@ FilterComputeDefined(interp, object); break; - case pofIdx: - case filterIdx: + case relationtypeObject_filterIdx: + case relationtypeFilterIdx: if (objopt->filters) CmdListRemoveList(&objopt->filters, GuardDel); @@ -10324,8 +10253,8 @@ /*FilterComputeDefined(interp, obj);*/ break; - case pcmIdx: - case instmixinIdx: + case relationtypeClass_mixinIdx: + case relationtypeInstmixinIdx: if (clopt->instmixins) { RemoveFromClassMixinsOf(cl->object.id, clopt->instmixins); @@ -10358,8 +10287,8 @@ } break; - case pcfIdx: - case instfilterIdx: + case relationtypeClass_filterIdx: + case relationtypeInstfilterIdx: if (clopt->instfilters) CmdListRemoveList(&clopt->instfilters, GuardDel); @@ -11504,7 +11433,7 @@ static int XOTclObjInfoNonposargsMethod(Tcl_Interp *interp, XOTclObject *object, char *methodName) { if (object->nonposArgsTable) { XOTclNonposArgs *nonposArgs = NonposArgsGet(object->nonposArgsTable, methodName); - if (nonposArgs) { + if (nonposArgs && nonposArgs->nonposArgs) { Tcl_SetObjResult(interp, NonposArgsFormat(interp, nonposArgs->nonposArgs)); } } @@ -12896,7 +12825,7 @@ * I know, I know, this is not really elegant. But... I'd need a * standard way of invoking some code at interpreter delete time * but JUST BEFORE the actual deletion process starts. Sadly, - * there is no such hook in Tcl as of Tcl8.3.2, that I know of. + * there is no such hook in Tcl as of Tcl8.4.*, that I know of. * * So, for the rest of procedure, assume the interp is alive ! */ @@ -13208,7 +13137,6 @@ Tcl_CreateObjCommand(interp, "::xotcl::createobjectsystem", XOTclCreateObjectSystemCmd, 0, 0); Tcl_CreateObjCommand(interp, "::xotcl::dispatch", XOTclDispatchCmd, 0, 0); - Tcl_CreateObjCommand(interp, "::xotcl::methodproperty", XOTclMethodPropertyCmd, 0, 0); Tcl_CreateObjCommand(interp, "::xotcl::configure", XOTclConfigureCmd, 0, 0); Tcl_CreateObjCommand(interp, "::xotcl::deprecated", XOTcl_DeprecatedCmd, 0, 0); Tcl_CreateObjCommand(interp, "::xotcl::finalize", XOTclFinalizeObjCmd, 0, 0); Index: library/serialize/Serializer.xotcl =================================================================== diff -u -r5229e26202a93f58dfcec181cf633882b7849f16 -r321a21cbb0beec854bfc651e167c32ded2707a3a --- library/serialize/Serializer.xotcl (.../Serializer.xotcl) (revision 5229e26202a93f58dfcec181cf633882b7849f16) +++ library/serialize/Serializer.xotcl (.../Serializer.xotcl) (revision 321a21cbb0beec854bfc651e167c32ded2707a3a) @@ -426,6 +426,7 @@ } Serializer instproc deepSerialize o { # assumes $o to be fully qualified +puts stderr CALL-allChildren my serialize-objects [my allChildren $o] 1 } Serializer instproc serializeMethod {object kind name} { @@ -530,7 +531,7 @@ set s [my new -childof [self] -volatile] foreach o [eval $s configure $args] { append r [$s deepSerialize [$o]] - } + } if {[$s exists map]} {return [string map [$s map] $r]} return $r }