diff options
| -rw-r--r-- | generic/tclOOScript.h | 59 | ||||
| -rw-r--r-- | tools/tclOOScript.tcl | 84 |
2 files changed, 65 insertions, 78 deletions
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 80c4c68..6b0c5bd 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -116,10 +116,8 @@ static const char *tclOOSetupScript = "\t\t}\n" "\t\t::tailcall forward $name myclass $name\n" "\t}\n" -"\tdefine Slot {\n" -"\t\tforward --default-operation my -append\n" -"\t\tunexport destroy\n" -"\t}\n" +"\tdefine Slot forward --default-operation my -append\n" +"\tdefine Slot unexport destroy\n" "\tobjdefine define::superclass forward --default-operation my -set\n" "\tobjdefine define::mixin forward --default-operation my -set\n" "\tobjdefine objdefine::mixin forward --default-operation my -set\n" @@ -154,31 +152,29 @@ static const char *tclOOSetupScript = "\t\tnext $originObject\n" "\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n" "\t}\n" -"\tclass create singleton {\n" -"\t\tsuperclass -set class\n" -"\t\tvariable -set object\n" -"\t\tunexport create createWithNamespace\n" -"\t\tmethod new args {\n" -"\t\t\tif {![info exists object] || ![info object isa object $object]} {\n" -"\t\t\t\tset object [next {*}$args]\n" -"\t\t\t\t::oo::objdefine $object {\n" -"\t\t\t\t\tmethod destroy {} {\n" -"\t\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n" -"\t\t\t\t\t\t\t\"may not destroy a singleton object\"\n" -"\t\t\t\t\t}\n" -"\t\t\t\t\tmethod <cloned> -unexport {originObject} {\n" -"\t\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n" -"\t\t\t\t\t\t\t\"may not clone a singleton object\"\n" -"\t\t\t\t\t}\n" +"\tclass create singleton\n" +"\tdefine singleton superclass -set class\n" +"\tdefine singleton variable -set object\n" +"\tdefine singleton unexport create createWithNamespace\n" +"\tdefine singleton method new args {\n" +"\t\tif {![info exists object] || ![info object isa object $object]} {\n" +"\t\t\tset object [next {*}$args]\n" +"\t\t\t::oo::objdefine $object {\n" +"\t\t\t\tmethod destroy {} {\n" +"\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n" +"\t\t\t\t\t\t\"may not destroy a singleton object\"\n" +"\t\t\t\t}\n" +"\t\t\t\tmethod <cloned> -unexport {originObject} {\n" +"\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n" +"\t\t\t\t\t\t\"may not clone a singleton object\"\n" "\t\t\t\t}\n" "\t\t\t}\n" -"\t\t\treturn $object\n" "\t\t}\n" +"\t\treturn $object\n" "\t}\n" -"\tclass create abstract {\n" -"\t\tsuperclass -set class\n" -"\t\tunexport create createWithNamespace new\n" -"\t}\n" +"\tclass create abstract\n" +"\tdefine abstract superclass -set class\n" +"\tdefine abstract unexport create createWithNamespace new\n" "\tnamespace eval configuresupport::configurableclass {\n" "\t\t::proc properties args {::tailcall property {*}$args}\n" "\t\t::namespace path ::oo::define\n" @@ -193,14 +189,13 @@ static const char *tclOOSetupScript = "\t\tdefinitionnamespace -instance configuresupport::configurableobject\n" "\t\tdefinitionnamespace -class configuresupport::configurableclass\n" "\t}\n" -"\tclass create configurable {\n" -"\t\tsuperclass -set class\n" -"\t\tconstructor {{definitionScript \"\"}} {\n" -"\t\t\tnext {mixin ::oo::configuresupport::configurable}\n" -"\t\t\tnext $definitionScript\n" -"\t\t}\n" -"\t\tdefinitionnamespace -class configuresupport::configurableclass\n" +"\tclass create configurable\n" +"\tdefine configurable superclass -set class\n" +"\tdefine configurable constructor {{definitionScript \"\"}} {\n" +"\t\tnext {mixin ::oo::configuresupport::configurable}\n" +"\t\tnext $definitionScript\n" "\t}\n" +"\tdefine configurable definitionnamespace -class configuresupport::configurableclass\n" "}\n" /* !END!: Do not edit above this line. */ ; diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index e829fcf..2b9e2a4 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -195,22 +195,18 @@ # # ---------------------------------------------------------------------- - define Slot { - # ------------------------------------------------------------------ - # - # Slot --default-operation -- - # - # If a slot can't figure out what method to call directly, it - # uses --default-operation. - # - # ------------------------------------------------------------------ - - # Default handling - forward --default-operation my -append - - # Hide destroy - unexport destroy - } + # ------------------------------------------------------------------ + # + # Slot --default-operation -- + # + # If a slot can't figure out what method to call directly, it + # uses --default-operation. + # + # ------------------------------------------------------------------ + define Slot forward --default-operation my -append + + # Hide destroy + define Slot unexport destroy # Set the default operation differently for these slots objdefine define::superclass forward --default-operation my -set @@ -283,26 +279,25 @@ # # ---------------------------------------------------------------------- - class create singleton { - superclass -set class - variable -set object - unexport create createWithNamespace - method new args { - if {![info exists object] || ![info object isa object $object]} { - set object [next {*}$args] - ::oo::objdefine $object { - method destroy {} { - ::return -code error -errorcode {TCL OO SINGLETON} \ - "may not destroy a singleton object" - } - method <cloned> -unexport {originObject} { - ::return -code error -errorcode {TCL OO SINGLETON} \ - "may not clone a singleton object" - } + class create singleton + define singleton superclass -set class + define singleton variable -set object + define singleton unexport create createWithNamespace + define singleton method new args { + if {![info exists object] || ![info object isa object $object]} { + set object [next {*}$args] + ::oo::objdefine $object { + method destroy {} { + ::return -code error -errorcode {TCL OO SINGLETON} \ + "may not destroy a singleton object" + } + method <cloned> -unexport {originObject} { + ::return -code error -errorcode {TCL OO SINGLETON} \ + "may not clone a singleton object" } } - return $object } + return $object } # ---------------------------------------------------------------------- @@ -314,10 +309,9 @@ # # ---------------------------------------------------------------------- - class create abstract { - superclass -set class - unexport create createWithNamespace new - } + class create abstract + define abstract superclass -set class + define abstract unexport create createWithNamespace new # ---------------------------------------------------------------------- # @@ -397,16 +391,14 @@ # # ---------------------------------------------------------------------- - class create configurable { - superclass -set class - - constructor {{definitionScript ""}} { - next {mixin ::oo::configuresupport::configurable} - next $definitionScript - } - - definitionnamespace -class configuresupport::configurableclass + class create configurable + define configurable superclass -set class + define configurable constructor {{definitionScript ""}} { + next {mixin ::oo::configuresupport::configurable} + next $definitionScript } + + define configurable definitionnamespace -class configuresupport::configurableclass } # Local Variables: |