summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclAssembly.c2
-rw-r--r--generic/tclCompCmds.c40
-rw-r--r--generic/tclCompile.c8
-rw-r--r--generic/tclCompile.h4
-rw-r--r--generic/tclExecute.c28
-rw-r--r--generic/tclInt.h6
-rw-r--r--generic/tclOOInfo.c85
7 files changed, 119 insertions, 54 deletions
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index f5f2469..19d6232 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -480,6 +480,8 @@ static const TalInstDesc TalInstructionTable[] = {
{"strmatch", ASSEM_BOOL, INST_STR_MATCH, 2, 1},
{"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1},
{"sub", ASSEM_1BYTE, INST_SUB, 2, 1},
+ {"tclooClass", ASSEM_1BYTE, INST_TCLOO_CLASS, 1, 1},
+ {"tclooNamespace", ASSEM_1BYTE, INST_TCLOO_NS, 1, 1},
{"tclooSelf", ASSEM_1BYTE, INST_TCLOO_SELF, 0, 1},
{"tryCvtToNumeric", ASSEM_1BYTE, INST_TRY_CVT_TO_NUMERIC,1, 1},
{"uminus", ASSEM_1BYTE, INST_UMINUS, 1, 1},
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 96bb9a4..7c1a4aa 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -3666,6 +3666,46 @@ TclCompileInfoLevelCmd(
}
return TCL_OK;
}
+
+int
+TclCompileInfoObjectClassCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ TclEmitOpcode( INST_TCLOO_CLASS, envPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileInfoObjectNamespaceCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ TclEmitOpcode( INST_TCLOO_NS, envPtr);
+ return TCL_OK;
+}
/*
*----------------------------------------------------------------------
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 188b3f8..7036f6a 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -491,6 +491,14 @@ InstructionDesc const tclInstructionTable[] = {
{"tclooNext", 2, INT_MIN, 1, {OPERAND_UINT1}},
/* Push the identity of the current TclOO object (i.e., the name of
* its current public access command) on the stack. */
+ {"tclooClass", 1, 0, 0, {OPERAND_NONE}},
+ /* Push the class of the TclOO object named at the top of the stack
+ * onto the stack.
+ * Stack: ... object => ... class */
+ {"tclooNamespace", 1, 0, 0, {OPERAND_NONE}},
+ /* Push the namespace of the TclOO object named at the top of the
+ * stack onto the stack.
+ * Stack: ... object => ... namespace */
{NULL, 0, 0, 0, {OPERAND_NONE}}
};
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index e623e87..cab517d 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -702,9 +702,11 @@ typedef struct ByteCode {
/* For compilation relating to TclOO */
#define INST_TCLOO_SELF 153
#define INST_TCLOO_NEXT 154
+#define INST_TCLOO_CLASS 155
+#define INST_TCLOO_NS 156
/* The last opcode */
-#define LAST_INST_OPCODE 154
+#define LAST_INST_OPCODE 156
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index f6b99bf..21c7d91 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4285,6 +4285,34 @@ TEBCresume(
return TclNRObjectContextInvokeNext(interp,
(Tcl_ObjectContext) contextPtr, opnd, &OBJ_AT_DEPTH(opnd-1), 1);
}
+ {
+ Object *oPtr;
+
+ case INST_TCLOO_CLASS:
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS);
+ if (oPtr == NULL) {
+ TRACE(("%.30s => ERROR: not object\n", O2S(OBJ_AT_TOS)));
+ goto gotError;
+ }
+ objResultPtr = TclOOObjectName(interp, oPtr->selfCls->thisPtr);
+ TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr);
+ NEXT_INST_F(1, 1, 1);
+ case INST_TCLOO_NS:
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS);
+ if (oPtr == NULL) {
+ TRACE(("%.30s => ERROR: not object\n", O2S(OBJ_AT_TOS)));
+ goto gotError;
+ }
+
+ /*
+ * TclOO objects *never* have the global namespace as their NS.
+ */
+
+ TclNewStringObj(objResultPtr, oPtr->namespacePtr->fullName,
+ strlen(oPtr->namespacePtr->fullName));
+ TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr);
+ NEXT_INST_F(1, 1, 1);
+ }
/*
* End of TclOO support instructions.
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 549ada9..41ca5d2 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3576,6 +3576,12 @@ MODULE_SCOPE int TclCompileInfoExistsCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileInfoLevelCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileInfoObjectClassCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileInfoObjectNamespaceCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileIncrCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index 1a94e69..ff3e1e5 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -43,47 +43,45 @@ static Tcl_ObjCmdProc InfoClassSubsCmd;
static Tcl_ObjCmdProc InfoClassSupersCmd;
static Tcl_ObjCmdProc InfoClassVariablesCmd;
-struct NameProcMap { const char *name; Tcl_ObjCmdProc *proc; };
-
/*
* List of commands that are used to implement the [info object] subcommands.
*/
-static const struct NameProcMap infoObjectCmds[] = {
- {"::oo::InfoObject::call", InfoObjectCallCmd},
- {"::oo::InfoObject::class", InfoObjectClassCmd},
- {"::oo::InfoObject::definition", InfoObjectDefnCmd},
- {"::oo::InfoObject::filters", InfoObjectFiltersCmd},
- {"::oo::InfoObject::forward", InfoObjectForwardCmd},
- {"::oo::InfoObject::isa", InfoObjectIsACmd},
- {"::oo::InfoObject::methods", InfoObjectMethodsCmd},
- {"::oo::InfoObject::methodtype", InfoObjectMethodTypeCmd},
- {"::oo::InfoObject::mixins", InfoObjectMixinsCmd},
- {"::oo::InfoObject::namespace", InfoObjectNsCmd},
- {"::oo::InfoObject::variables", InfoObjectVariablesCmd},
- {"::oo::InfoObject::vars", InfoObjectVarsCmd},
- {NULL, NULL}
+static const EnsembleImplMap infoObjectCmds[] = {
+ {"call", InfoObjectCallCmd, NULL, NULL, NULL, 0},
+ {"class", InfoObjectClassCmd, TclCompileInfoObjectClassCmd, NULL, NULL, 0},
+ {"definition", InfoObjectDefnCmd, NULL, NULL, NULL, 0},
+ {"filters", InfoObjectFiltersCmd, NULL, NULL, NULL, 0},
+ {"forward", InfoObjectForwardCmd, NULL, NULL, NULL, 0},
+ {"isa", InfoObjectIsACmd, NULL, NULL, NULL, 0},
+ {"methods", InfoObjectMethodsCmd, NULL, NULL, NULL, 0},
+ {"methodtype", InfoObjectMethodTypeCmd, NULL, NULL, NULL, 0},
+ {"mixins", InfoObjectMixinsCmd, NULL, NULL, NULL, 0},
+ {"namespace", InfoObjectNsCmd, TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0},
+ {"variables", InfoObjectVariablesCmd, NULL, NULL, NULL, 0},
+ {"vars", InfoObjectVarsCmd, NULL, NULL, NULL, 0},
+ {NULL, NULL, NULL, NULL, NULL, 0}
};
/*
* List of commands that are used to implement the [info class] subcommands.
*/
-static const struct NameProcMap infoClassCmds[] = {
- {"::oo::InfoClass::call", InfoClassCallCmd},
- {"::oo::InfoClass::constructor", InfoClassConstrCmd},
- {"::oo::InfoClass::definition", InfoClassDefnCmd},
- {"::oo::InfoClass::destructor", InfoClassDestrCmd},
- {"::oo::InfoClass::filters", InfoClassFiltersCmd},
- {"::oo::InfoClass::forward", InfoClassForwardCmd},
- {"::oo::InfoClass::instances", InfoClassInstancesCmd},
- {"::oo::InfoClass::methods", InfoClassMethodsCmd},
- {"::oo::InfoClass::methodtype", InfoClassMethodTypeCmd},
- {"::oo::InfoClass::mixins", InfoClassMixinsCmd},
- {"::oo::InfoClass::subclasses", InfoClassSubsCmd},
- {"::oo::InfoClass::superclasses", InfoClassSupersCmd},
- {"::oo::InfoClass::variables", InfoClassVariablesCmd},
- {NULL, NULL}
+static const EnsembleImplMap infoClassCmds[] = {
+ {"call", InfoClassCallCmd, NULL, NULL, NULL, 0},
+ {"constructor", InfoClassConstrCmd, NULL, NULL, NULL, 0},
+ {"definition", InfoClassDefnCmd, NULL, NULL, NULL, 0},
+ {"destructor", InfoClassDestrCmd, NULL, NULL, NULL, 0},
+ {"filters", InfoClassFiltersCmd, NULL, NULL, NULL, 0},
+ {"forward", InfoClassForwardCmd, NULL, NULL, NULL, 0},
+ {"instances", InfoClassInstancesCmd, NULL, NULL, NULL, 0},
+ {"methods", InfoClassMethodsCmd, NULL, NULL, NULL, 0},
+ {"methodtype", InfoClassMethodTypeCmd, NULL, NULL, NULL, 0},
+ {"mixins", InfoClassMixinsCmd, NULL, NULL, NULL, 0},
+ {"subclasses", InfoClassSubsCmd, NULL, NULL, NULL, 0},
+ {"superclasses", InfoClassSupersCmd, NULL, NULL, NULL, 0},
+ {"variables", InfoClassVariablesCmd, NULL, NULL, NULL, 0},
+ {NULL, NULL, NULL, NULL, NULL, 0}
};
/*
@@ -101,33 +99,14 @@ void
TclOOInitInfo(
Tcl_Interp *interp)
{
- Tcl_Namespace *nsPtr;
Tcl_Command infoCmd;
- int i;
-
- /*
- * Build the ensemble used to implement [info object].
- */
-
- nsPtr = Tcl_CreateNamespace(interp, "::oo::InfoObject", NULL, NULL);
- Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, TCL_ENSEMBLE_PREFIX);
- Tcl_Export(interp, nsPtr, "[a-z]*", 1);
- for (i=0 ; infoObjectCmds[i].name!=NULL ; i++) {
- Tcl_CreateObjCommand(interp, infoObjectCmds[i].name,
- infoObjectCmds[i].proc, NULL, NULL);
- }
/*
- * Build the ensemble used to implement [info class].
+ * Build the ensembles used to implement [info object] and [info class].
*/
- nsPtr = Tcl_CreateNamespace(interp, "::oo::InfoClass", NULL, NULL);
- Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, TCL_ENSEMBLE_PREFIX);
- Tcl_Export(interp, nsPtr, "[a-z]*", 1);
- for (i=0 ; infoClassCmds[i].name!=NULL ; i++) {
- Tcl_CreateObjCommand(interp, infoClassCmds[i].name,
- infoClassCmds[i].proc, NULL, NULL);
- }
+ TclMakeEnsemble(interp, "::oo::InfoObject", infoObjectCmds);
+ TclMakeEnsemble(interp, "::oo::InfoClass", infoClassCmds);
/*
* Install into the master [info] ensemble.
generated by cgit v0.12 at 2024-11-17 01:45:00 (GMT)