Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Changes In Branch tip-257-implementation-branch Excluding Merge-Ins
This is equivalent to a diff from 254dc62eaa to 29c0ed87e2
2006-10-31
| ||
09:20 | Renamed functions to reduce confusion and added to header file. Closed-Leaf check-in: 29c0ed87e2 user: dkf tags: tip-257-implementation-branch | |
09:14 | Added more API as requested by Arnulf Wiedermann <[email protected]> Also added more comment... check-in: 4a234b23e9 user: dkf tags: tip-257-implementation-branch | |
2006-02-02
| ||
09:54 | Space/style improvements check-in: 48e0d2a0b6 user: dkf tags: trunk | |
2006-02-01
| ||
23:57 | Check in the working version of the OO code. This is *definitely* still broken and incomplete, but ... check-in: 9966504530 user: dkf tags: tip-257-implementation-branch | |
23:34 | Restore formatting goodness check-in: 254dc62eaa user: dkf tags: trunk | |
20:17 |
* generic/tclProc.c: minor improvements to [apply] * tests/apply.test: new tests; apply-5.1 curren...check-in: 0ddc34dbb9 user: msofer tags: trunk | |
Changes to generic/tcl.h.
︙ | ︙ | |||
9 10 11 12 13 14 15 | * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * Copyright (c) 2002 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * Copyright (c) 2002 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tcl.h,v 1.210.2.7 2006/10/21 01:11:51 dkf Exp $ */ #ifndef _TCL #define _TCL /* * For C++ compilers, use extern "C" |
︙ | ︙ | |||
500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 | * line number within the command where the * error occurred (1 if first line). */ } Tcl_Interp; typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; typedef struct Tcl_Channel_ *Tcl_Channel; typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion; typedef struct Tcl_Command_ *Tcl_Command; typedef struct Tcl_Condition_ *Tcl_Condition; typedef struct Tcl_Dict_ *Tcl_Dict; typedef struct Tcl_EncodingState_ *Tcl_EncodingState; typedef struct Tcl_Encoding_ *Tcl_Encoding; typedef struct Tcl_Event Tcl_Event; typedef struct Tcl_InterpState_ *Tcl_InterpState; typedef struct Tcl_LoadHandle_ *Tcl_LoadHandle; typedef struct Tcl_Mutex_ *Tcl_Mutex; typedef struct Tcl_Pid_ *Tcl_Pid; typedef struct Tcl_RegExp_ *Tcl_RegExp; typedef struct Tcl_ThreadDataKey_ *Tcl_ThreadDataKey; typedef struct Tcl_ThreadId_ *Tcl_ThreadId; typedef struct Tcl_TimerToken_ *Tcl_TimerToken; typedef struct Tcl_Trace_ *Tcl_Trace; typedef struct Tcl_Var_ *Tcl_Var; | > > > > | 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 | * line number within the command where the * error occurred (1 if first line). */ } Tcl_Interp; typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; typedef struct Tcl_Channel_ *Tcl_Channel; typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion; typedef struct Tcl_Class_ *Tcl_Class; typedef struct Tcl_Command_ *Tcl_Command; typedef struct Tcl_Condition_ *Tcl_Condition; typedef struct Tcl_Dict_ *Tcl_Dict; typedef struct Tcl_EncodingState_ *Tcl_EncodingState; typedef struct Tcl_Encoding_ *Tcl_Encoding; typedef struct Tcl_Event Tcl_Event; typedef struct Tcl_InterpState_ *Tcl_InterpState; typedef struct Tcl_LoadHandle_ *Tcl_LoadHandle; typedef struct Tcl_Method_ *Tcl_Method; typedef struct Tcl_Mutex_ *Tcl_Mutex; typedef struct Tcl_Object_ *Tcl_Object; typedef struct Tcl_ObjectContext_ *Tcl_ObjectContext; typedef struct Tcl_Pid_ *Tcl_Pid; typedef struct Tcl_RegExp_ *Tcl_RegExp; typedef struct Tcl_ThreadDataKey_ *Tcl_ThreadDataKey; typedef struct Tcl_ThreadId_ *Tcl_ThreadId; typedef struct Tcl_TimerToken_ *Tcl_TimerToken; typedef struct Tcl_Trace_ *Tcl_Trace; typedef struct Tcl_Var_ *Tcl_Var; |
︙ | ︙ | |||
949 950 951 952 953 954 955 956 957 958 959 960 961 962 | char *dummy4; char *dummy5; int dummy6; char *dummy7; char *dummy8; int dummy9; char* dummy10; } Tcl_CallFrame; /* * Information about commands that is returned by Tcl_GetCommandInfo and * passed to Tcl_SetCommandInfo. objProc is an objc/objv object-based command * function while proc is a traditional Tcl argc/argv string-based function. * Tcl_CreateObjCommand and Tcl_CreateCommand ensure that both objProc and | > > | 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 | char *dummy4; char *dummy5; int dummy6; char *dummy7; char *dummy8; int dummy9; char* dummy10; void* dummy11; /*int dummy12;*/ } Tcl_CallFrame; /* * Information about commands that is returned by Tcl_GetCommandInfo and * passed to Tcl_SetCommandInfo. objProc is an objc/objv object-based command * function while proc is a traditional Tcl argc/argv string-based function. * Tcl_CreateObjCommand and Tcl_CreateCommand ensure that both objProc and |
︙ | ︙ | |||
2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 | #define MP_INT_DECLARED #endif #ifndef MP_DIGIT_DECLARED typedef unsigned long mp_digit; #define MP_DIGIT_DECLARED #endif #ifndef TCL_NO_DEPRECATED /* * Deprecated Tcl functions: */ # define Tcl_EvalObj(interp,objPtr) \ Tcl_EvalObjEx((interp),(objPtr),0) | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 | #define MP_INT_DECLARED #endif #ifndef MP_DIGIT_DECLARED typedef unsigned long mp_digit; #define MP_DIGIT_DECLARED #endif /* * Public datatypes for callbacks and structures used in the TIP#257 (OO) * implementation. These are used to implement custom types of method calls * and to allow the attachment of arbitrary data to objects and classes. */ typedef int (*Tcl_MethodCallProc)_ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext objectContext, int objc, Tcl_Obj *const *objv)); typedef void (*Tcl_MethodDeleteProc)_ANSI_ARGS_((ClientData clientData)); typedef int (*Tcl_MethodCloneProc)_ANSI_ARGS_((ClientData oldClientData, ClientData *newClientData)); typedef void (*Tcl_ObjectMetadataDeleteProc)_ANSI_ARGS_(( ClientData clientData)); typedef ClientData (*Tcl_ObjectMetadataCloneProc)_ANSI_ARGS_(( ClientData clientData)); /* * The type of a method implementation. This describes how to call the method * implementation, how to delete it (when the object or class is deleted) and * how to create a clone of it (when the object or class is copied). */ typedef struct { int version; /* Structure version field. Always to be equal * to TCL_OO_METHOD_VERSION_CURRENT in * declarations. */ const char *name; /* Name of this type of method, mostly for * debugging purposes. */ Tcl_MethodCallProc callProc;/* How to invoke this method. */ Tcl_MethodDeleteProc deleteProc; /* How to delete this method's type-specific * data, or NULL if the type-specific data * does not need deleting. */ Tcl_MethodCloneProc cloneProc; /* How to copy this method's type-specific * data, or NULL if the type-specific data can * be copied directly. */ } Tcl_MethodType; /* * The correct value for the version field of the Tcl_MethodType structure. * This allows new versions of the structure to be introduced without breaking * binary compatability. */ #define TCL_OO_METHOD_VERSION_CURRENT 1 /* * The type of some object (or class) metadata. This describes how to delete * the metadata (when the object or class is deleted) and how to create a * clone of it (when the object or class is copied). */ typedef struct { int version; /* Structure version field. Always to be equal * to TCL_OO_METADATA_VERSION_CURRENT in * declarations. */ const char *name; Tcl_ObjectMetadataDeleteProc deleteProc; /* How to delete the metadata. This must not * be NULL. */ Tcl_ObjectMetadataCloneProc cloneProc; /* How to clone the metadata. If NULL, the * metadata will not be copied. */ } Tcl_ObjectMetadataType; /* * The correct value for the version field of the Tcl_ObjectMetadataType * structure. This allows new versions of the structure to be introduced * without breaking binary compatability. */ #define TCL_OO_METADATA_VERSION_CURRENT 1 #ifndef TCL_NO_DEPRECATED /* * Deprecated Tcl functions: */ # define Tcl_EvalObj(interp,objPtr) \ Tcl_EvalObjEx((interp),(objPtr),0) |
︙ | ︙ |
Changes to generic/tclBasic.c.
︙ | ︙ | |||
9 10 11 12 13 14 15 | * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclBasic.c,v 1.189.2.2 2006/09/27 13:23:35 dkf Exp $ */ #include "tclInt.h" #include "tclCompile.h" #include <float.h> #include <math.h> #include "tommath.h" |
︙ | ︙ | |||
528 529 530 531 532 533 534 | TclInterpInit(interp); #ifndef TCL_GENERIC_ONLY TclSetupEnv(interp); #endif /* | | < > > > > > > | 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 | TclInterpInit(interp); #ifndef TCL_GENERIC_ONLY TclSetupEnv(interp); #endif /* * TIP #59: Make embedded configuration information available. */ TclInitEmbeddedConfigurationInformation(interp); /* * TIP #257: Install the OO engine (for testing). */ TclOOInit(interp); /* * Compute the byte order of this machine. */ order.s = 1; Tcl_SetVar2(interp, "tcl_platform", "byteOrder", ((order.c[0] == 1) ? "littleEndian" : "bigEndian"), |
︙ | ︙ | |||
1939 1940 1941 1942 1943 1944 1945 | * *---------------------------------------------------------------------- */ int TclRenameCommand( Tcl_Interp *interp, /* Current interpreter. */ | | | | < | 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 | * *---------------------------------------------------------------------- */ int TclRenameCommand( Tcl_Interp *interp, /* Current interpreter. */ const char *oldName, /* Existing command name. */ const char *newName) /* New command name. */ { Interp *iPtr = (Interp *) interp; CONST char *newTail; Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2; Tcl_Command cmd; Command *cmdPtr; Tcl_HashEntry *hPtr, *oldHPtr; int new, result; Tcl_Obj* oldFullName; Tcl_DString newFullName; /* * Find the existing command. An error is returned if cmdName can't be * found. */ cmd = Tcl_FindCommand(interp, oldName, NULL, /*flags*/ 0); cmdPtr = (Command *) cmd; if (cmdPtr == NULL) { Tcl_AppendResult(interp, "can't ", ((newName == NULL)||(*newName == '\0'))? "delete":"rename", " \"", oldName, "\": command doesn't exist", NULL); return TCL_ERROR; } |
︙ | ︙ |
Changes to generic/tclCmdIL.c.
︙ | ︙ | |||
12 13 14 15 16 17 18 | * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2005 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2005 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclCmdIL.c,v 1.86.2.1 2006/08/30 14:23:01 dkf Exp $ */ #include "tclInt.h" #include "tclRegexp.h" /* * During execution of the "lsort" command, structures of the following type |
︙ | ︙ | |||
353 354 355 356 357 358 359 | Tcl_InfoObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Arbitrary value passed to the command. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { static CONST char *subCmds[] = { | | | | | | | | 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 | Tcl_InfoObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Arbitrary value passed to the command. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { static CONST char *subCmds[] = { "args", "body", "class", "cmdcount", "commands", "complete", "default", "exists", "functions", "globals", "hostname", "level", "library", "loaded", "locals", "nameofexecutable", "object", "patchlevel", "procs", "script", "sharedlibextension", "tclversion", "vars", (char *) NULL}; enum ISubCmdIdx { IArgsIdx, IBodyIdx, IClassIdx, ICmdCountIdx, ICommandsIdx, ICompleteIdx, IDefaultIdx, IExistsIdx, IFunctionsIdx, IGlobalsIdx, IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx, ILocalsIdx, INameOfExecutableIdx, IObjectIdx, IPatchLevelIdx, IProcsIdx, IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx }; int index, result; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); return TCL_ERROR; |
︙ | ︙ | |||
386 387 388 389 390 391 392 393 394 395 396 397 398 399 | switch (index) { case IArgsIdx: result = InfoArgsCmd(clientData, interp, objc, objv); break; case IBodyIdx: result = InfoBodyCmd(clientData, interp, objc, objv); break; case ICmdCountIdx: result = InfoCmdCountCmd(clientData, interp, objc, objv); break; case ICommandsIdx: result = InfoCommandsCmd(clientData, interp, objc, objv); break; case ICompleteIdx: | > > > | 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 | switch (index) { case IArgsIdx: result = InfoArgsCmd(clientData, interp, objc, objv); break; case IBodyIdx: result = InfoBodyCmd(clientData, interp, objc, objv); break; case IClassIdx: result = TclInfoClassCmd(clientData, interp, objc, objv); break; case ICmdCountIdx: result = InfoCmdCountCmd(clientData, interp, objc, objv); break; case ICommandsIdx: result = InfoCommandsCmd(clientData, interp, objc, objv); break; case ICompleteIdx: |
︙ | ︙ | |||
425 426 427 428 429 430 431 432 433 434 435 436 437 438 | break; case ILocalsIdx: result = InfoLocalsCmd(clientData, interp, objc, objv); break; case INameOfExecutableIdx: result = InfoNameOfExecutableCmd(clientData, interp, objc, objv); break; case IPatchLevelIdx: result = InfoPatchLevelCmd(clientData, interp, objc, objv); break; case IProcsIdx: result = InfoProcsCmd(clientData, interp, objc, objv); break; case IScriptIdx: | > > > | 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 | break; case ILocalsIdx: result = InfoLocalsCmd(clientData, interp, objc, objv); break; case INameOfExecutableIdx: result = InfoNameOfExecutableCmd(clientData, interp, objc, objv); break; case IObjectIdx: result = TclInfoObjectCmd(clientData, interp, objc, objv); break; case IPatchLevelIdx: result = InfoPatchLevelCmd(clientData, interp, objc, objv); break; case IProcsIdx: result = InfoProcsCmd(clientData, interp, objc, objv); break; case IScriptIdx: |
︙ | ︙ |
Changes to generic/tclInt.decls.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: tclInt.decls,v 1.94.2.1 2006/09/27 13:23:35 dkf Exp $ library tcl # Define the unsupported generic interfaces. interface tclInt |
︙ | ︙ | |||
386 387 388 389 390 391 392 | # int argc, CONST84 char **argv) #} # Replaced by Tcl_FSStat in 8.4: #declare 95 generic { # int TclpStat(CONST char *path, Tcl_StatBuf *buf) #} declare 96 generic { | | > | 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 | # int argc, CONST84 char **argv) #} # Replaced by Tcl_FSStat in 8.4: #declare 95 generic { # int TclpStat(CONST char *path, Tcl_StatBuf *buf) #} declare 96 generic { int TclRenameCommand(Tcl_Interp *interp, CONST char *oldName, CONST char *newName) } declare 97 generic { void TclResetShadowedCmdRefs(Tcl_Interp *interp, Command *newCmdPtr) } declare 98 generic { int TclServiceIdle(void) } |
︙ | ︙ |
Changes to generic/tclInt.h.
︙ | ︙ | |||
8 9 10 11 12 13 14 | * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 1998-19/99 by Scriptics Corporation. * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 1998-19/99 by Scriptics Corporation. * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclInt.h,v 1.267.2.12 2006/10/21 01:11:51 dkf Exp $ */ #ifndef _TCLINT #define _TCLINT /* * Some numerics configuration options |
︙ | ︙ | |||
107 108 109 110 111 112 113 114 115 116 117 118 119 120 | /* * When Tcl_WideInt and long are the same type, there's no value in * having a tclWideIntType separate from the tclIntType. */ #ifdef TCL_WIDE_INT_IS_LONG #define NO_WIDE_TYPE #endif /* * The following procedures allow namespaces to be customized to support * special name resolution rules for commands/variables. */ struct Tcl_ResolvedVarInfo; | > > | 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 | /* * When Tcl_WideInt and long are the same type, there's no value in * having a tclWideIntType separate from the tclIntType. */ #ifdef TCL_WIDE_INT_IS_LONG #define NO_WIDE_TYPE #endif struct Foundation; /* Forward decl for OO support. */ /* * The following procedures allow namespaces to be customized to support * special name resolution rules for commands/variables. */ struct Tcl_ResolvedVarInfo; |
︙ | ︙ | |||
886 887 888 889 890 891 892 893 894 | * Initially NULL and created if needed. */ int numCompiledLocals; /* Count of local variables recognized by the * compiler including arguments. */ Var* compiledLocals; /* Points to the array of local variables * recognized by the compiler. The compiler * emits code that refers to these variables * using an index into this array. */ } CallFrame; | > | > > > > > | 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 | * Initially NULL and created if needed. */ int numCompiledLocals; /* Count of local variables recognized by the * compiler including arguments. */ Var* compiledLocals; /* Points to the array of local variables * recognized by the compiler. The compiler * emits code that refers to these variables * using an index into this array. */ void *ooContextPtr; /* TODO: Docme */ } CallFrame; #define FRAME_IS_PROC 0x1 #define FRAME_IS_METHOD 0x2 /* TODO: Docme */ #define FRAME_IS_FILTER 0x4 /* TODO: Docme */ #define FRAME_IS_OO_DEFINE 0x8 /* TODO: Docme */ #define FRAME_IS_CONSTRUCTOR 0x10 #define FRAME_IS_DESTRUCTOR 0x20 /* *---------------------------------------------------------------- * Data structures and procedures related to TclHandles, which are a very * lightweight method of preserving enough information to determine if an * arbitrary malloc'd block has been deleted. *---------------------------------------------------------------- |
︙ | ︙ | |||
1506 1507 1508 1509 1510 1511 1512 | * inserted by an ensemble. */ } ensembleRewrite; /* * TIP #219 ... Global info for the I/O system ... */ | | > > > > > > > > > > > | 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 | * inserted by an ensemble. */ } ensembleRewrite; /* * TIP #219 ... Global info for the I/O system ... */ Tcl_Obj *chanMsg; /* Error message set by channel drivers, for * the propagation of arbitrary Tcl errors. * This information, if present (chanMsg not * NULL), takes precedence over a posix error * code returned by a channel operation. */ /* * TIP #257 - Object Orientation Programming Infrastructure. */ struct Foundation *ooFoundation; /* Pointer to the structure that manages the * core of the object-orientation support. * The actual definition of this structure is * in tclOO.h, so this is just an opaque * pointer if that file isn't #included. */ /* * Statistical information about the bytecode compiler and interpreter's * operation. */ #ifdef TCL_COMPILE_STATS ByteCodeStats stats; /* Holds compilation and execution statistics |
︙ | ︙ | |||
2091 2092 2093 2094 2095 2096 2097 | Tcl_Interp *interp); MODULE_SCOPE void TclInitEncodingSubsystem(void); MODULE_SCOPE void TclInitIOSubsystem(void); MODULE_SCOPE void TclInitLimitSupport(Tcl_Interp *interp); MODULE_SCOPE void TclInitNamespaceSubsystem(void); MODULE_SCOPE void TclInitNotifier(void); MODULE_SCOPE void TclInitObjSubsystem(void); | | | 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 | Tcl_Interp *interp); MODULE_SCOPE void TclInitEncodingSubsystem(void); MODULE_SCOPE void TclInitIOSubsystem(void); MODULE_SCOPE void TclInitLimitSupport(Tcl_Interp *interp); MODULE_SCOPE void TclInitNamespaceSubsystem(void); MODULE_SCOPE void TclInitNotifier(void); MODULE_SCOPE void TclInitObjSubsystem(void); MODULE_SCOPE void TclInitSubsystems(void); MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp); MODULE_SCOPE int TclIsLocalScalar(CONST char *src, int len); MODULE_SCOPE int TclJoinThread(Tcl_ThreadId id, int* result); MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp* interp, Tcl_Obj* listPtr, Tcl_Obj* argPtr); MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp* interp, Tcl_Obj* listPtr, |
︙ | ︙ | |||
2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 | Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_IncrObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_InfoObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_InterpObjCmd(ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_JoinObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); | > > > > > > | 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 | Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_IncrObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_InfoObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int TclInfoClassCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int TclInfoObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_InterpObjCmd(ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_JoinObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); |
︙ | ︙ | |||
2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 | MODULE_SCOPE int Tcl_VwaitObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_WhileObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); /* *---------------------------------------------------------------- * Compilation procedures for commands in the generic core: *---------------------------------------------------------------- */ MODULE_SCOPE int TclCompileAppendCmd(Tcl_Interp *interp, | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 | MODULE_SCOPE int Tcl_VwaitObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_WhileObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); /* *---------------------------------------------------------------- * Commands relating to OO support. *---------------------------------------------------------------- */ MODULE_SCOPE int TclOOInit(Tcl_Interp *interp); MODULE_SCOPE int TclOODefineObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineConstructorObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineDestructorObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineExportObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineFilterObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineForwardObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineMethodObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineMixinObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); #ifdef SUPPORT_OO_PARAMETERS MODULE_SCOPE int TclOODefineParameterObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); #endif MODULE_SCOPE int TclOODefineSuperclassObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineUnexportObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineSelfClassObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); /* *---------------------------------------------------------------- * Compilation procedures for commands in the generic core: *---------------------------------------------------------------- */ MODULE_SCOPE int TclCompileAppendCmd(Tcl_Interp *interp, |
︙ | ︙ | |||
3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 | #ifdef _MSC_VER #define TclIsInfinite(d) ( ! (_finite((d))) ) #define TclIsNaN(d) (_isnan((d))) #else #define TclIsInfinite(d) ( (d) > DBL_MAX || (d) < -DBL_MAX ) #define TclIsNaN(d) ((d) != (d)) #endif #include "tclPort.h" #include "tclIntDecls.h" #include "tclIntPlatDecls.h" #include "tclTomMathDecls.h" #endif /* _TCLINT */ | > > > > > > | 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 | #ifdef _MSC_VER #define TclIsInfinite(d) ( ! (_finite((d))) ) #define TclIsNaN(d) (_isnan((d))) #else #define TclIsInfinite(d) ( (d) > DBL_MAX || (d) < -DBL_MAX ) #define TclIsNaN(d) ((d) != (d)) #endif // vvvvvvvvvvvvvvvvvvvvvv MOVE TO TCLINT.DECLS vvvvvvvvvvvvvvvvvvvvvv void TclSetNsPath(Namespace *nsPtr, int pathLength, Tcl_Namespace *pathAry[]); Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); // ^^^^^^^^^^^^^^^^^^^^^^ MOVE TO TCLINT.DECLS ^^^^^^^^^^^^^^^^^^^^^^ #include "tclPort.h" #include "tclIntDecls.h" #include "tclIntPlatDecls.h" #include "tclTomMathDecls.h" #endif /* _TCLINT */ |
︙ | ︙ |
Changes to generic/tclIntDecls.h.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclIntDecls.h -- * * This file contains the declarations for all unsupported * functions that are exported by the Tcl library. These * interfaces are not guaranteed to remain the same between * versions. Use at your own risk. * * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | /* * tclIntDecls.h -- * * This file contains the declarations for all unsupported * functions that are exported by the Tcl library. These * interfaces are not guaranteed to remain the same between * versions. Use at your own risk. * * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclIntDecls.h,v 1.85.2.1 2006/09/27 13:24:02 dkf Exp $ */ #ifndef _TCLINTDECLS #define _TCLINTDECLS #include "tclPort.h" |
︙ | ︙ | |||
440 441 442 443 444 445 446 | #endif /* Slot 94 is reserved */ /* Slot 95 is reserved */ #ifndef TclRenameCommand_TCL_DECLARED #define TclRenameCommand_TCL_DECLARED /* 96 */ EXTERN int TclRenameCommand _ANSI_ARGS_((Tcl_Interp * interp, | | | 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 | #endif /* Slot 94 is reserved */ /* Slot 95 is reserved */ #ifndef TclRenameCommand_TCL_DECLARED #define TclRenameCommand_TCL_DECLARED /* 96 */ EXTERN int TclRenameCommand _ANSI_ARGS_((Tcl_Interp * interp, CONST char * oldName, CONST char * newName)); #endif #ifndef TclResetShadowedCmdRefs_TCL_DECLARED #define TclResetShadowedCmdRefs_TCL_DECLARED /* 97 */ EXTERN void TclResetShadowedCmdRefs _ANSI_ARGS_(( Tcl_Interp * interp, Command * newCmdPtr)); #endif |
︙ | ︙ | |||
1169 1170 1171 1172 1173 1174 1175 | int (*tclPreventAliasLoop) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Interp * cmdInterp, Tcl_Command cmd)); /* 89 */ void *reserved90; void (*tclProcCleanupProc) _ANSI_ARGS_((Proc * procPtr)); /* 91 */ int (*tclProcCompileProc) _ANSI_ARGS_((Tcl_Interp * interp, Proc * procPtr, Tcl_Obj * bodyPtr, Namespace * nsPtr, CONST char * description, CONST char * procName)); /* 92 */ void (*tclProcDeleteProc) _ANSI_ARGS_((ClientData clientData)); /* 93 */ void *reserved94; void *reserved95; | | | 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 | int (*tclPreventAliasLoop) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Interp * cmdInterp, Tcl_Command cmd)); /* 89 */ void *reserved90; void (*tclProcCleanupProc) _ANSI_ARGS_((Proc * procPtr)); /* 91 */ int (*tclProcCompileProc) _ANSI_ARGS_((Tcl_Interp * interp, Proc * procPtr, Tcl_Obj * bodyPtr, Namespace * nsPtr, CONST char * description, CONST char * procName)); /* 92 */ void (*tclProcDeleteProc) _ANSI_ARGS_((ClientData clientData)); /* 93 */ void *reserved94; void *reserved95; int (*tclRenameCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * oldName, CONST char * newName)); /* 96 */ void (*tclResetShadowedCmdRefs) _ANSI_ARGS_((Tcl_Interp * interp, Command * newCmdPtr)); /* 97 */ int (*tclServiceIdle) _ANSI_ARGS_((void)); /* 98 */ void *reserved99; void *reserved100; char * (*tclSetPreInitScript) _ANSI_ARGS_((char * string)); /* 101 */ void (*tclSetupEnv) _ANSI_ARGS_((Tcl_Interp * interp)); /* 102 */ int (*tclSockGetPort) _ANSI_ARGS_((Tcl_Interp * interp, char * str, char * proto, int * portPtr)); /* 103 */ |
︙ | ︙ |
Changes to generic/tclNamesp.c.
︙ | ︙ | |||
18 19 20 21 22 23 24 | * Michael J. McLennan * Bell Labs Innovations for Lucent Technologies * [email protected] * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | * Michael J. McLennan * Bell Labs Innovations for Lucent Technologies * [email protected] * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclNamesp.c,v 1.93.2.3 2006/07/10 01:17:32 dkf Exp $ */ #include "tclInt.h" /* * Initial size of stack allocated space for tail list - used when resetting * shadowed command references in the functin: TclResetShadowedCmdRefs. |
︙ | ︙ | |||
113 114 115 116 117 118 119 | struct EnsembleConfig *next;/* The next ensemble in the linked list of * ensembles associated with a namespace. If * this field points to this ensemble, the * structure has already been unlinked from * all lists, and cannot be found by scanning * the list from the namespace's ensemble * field. */ | | | | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 | struct EnsembleConfig *next;/* The next ensemble in the linked list of * ensembles associated with a namespace. If * this field points to this ensemble, the * structure has already been unlinked from * all lists, and cannot be found by scanning * the list from the namespace's ensemble * field. */ int flags; /* ORed combo of TCL_ENSEMBLE_PREFIX and * ENS_DEAD. */ /* OBJECT FIELDS FOR ENSEMBLE CONFIGURATION */ Tcl_Obj *subcommandDict; /* Dictionary providing mapping from * subcommands to their implementing command * prefixes, or NULL if we are to build the * map automatically from the namespace |
︙ | ︙ | |||
247 248 249 250 251 252 253 | static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr, EnsembleConfig *ensemblePtr, CONST char *subcmdName, Tcl_Obj *prefixObjPtr); static void FreeEnsembleCmdRep(Tcl_Obj *objPtr); static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr); static void UnlinkNsPath(Namespace *nsPtr); | < < | 247 248 249 250 251 252 253 254 255 256 257 258 259 260 | static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr, EnsembleConfig *ensemblePtr, CONST char *subcmdName, Tcl_Obj *prefixObjPtr); static void FreeEnsembleCmdRep(Tcl_Obj *objPtr); static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr); static void UnlinkNsPath(Namespace *nsPtr); /* * This structure defines a Tcl object type that contains a namespace * reference. It is used in commands that take the name of a namespace as an * argument. The namespace reference is resolved, and the result in cached in * the object. */ |
︙ | ︙ | |||
3772 3773 3774 3775 3776 3777 3778 | NamespaceInscopeCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *CONST objv[]) /* Argument objects. */ { Tcl_Namespace *namespacePtr; | | | 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 | NamespaceInscopeCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *CONST objv[]) /* Argument objects. */ { Tcl_Namespace *namespacePtr; CallFrame *framePtr, **framePtrPtr; int i, result; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); return TCL_ERROR; } |
︙ | ︙ | |||
3798 3799 3800 3801 3802 3803 3804 | return TCL_ERROR; } /* * Make the specified namespace the current namespace. */ | > | | 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 | return TCL_ERROR; } /* * Make the specified namespace the current namespace. */ framePtrPtr = &framePtr; result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, namespacePtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { return result; } framePtr->objc = objc; framePtr->objv = objv; |
︙ | ︙ | |||
4076 4077 4078 4079 4080 4081 4082 | } } /* * Now we have the list of valid namespaces, install it as the path. */ | | | | | | 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 | } } /* * Now we have the list of valid namespaces, install it as the path. */ TclSetNsPath(nsPtr, nsObjc, namespaceList); result = TCL_OK; badNamespace: if (namespaceList != NULL && namespaceList != staticNs) { ckfree((char *) namespaceList); } return result; } /* *---------------------------------------------------------------------- * * TclSetNsPath -- * * Sets the namespace command name resolution path to the given list of * namespaces. If the list is empty (of zero length) the path is set to * empty and the default old-style behaviour of command name resolution * is used. * * Results: * nothing * * Side effects: * Invalidates the command name resolution caches for any command * resolved in the given namespace. * *---------------------------------------------------------------------- */ /* EXPOSE ME? */ void TclSetNsPath( Namespace *nsPtr, /* Namespace whose path is to be set. */ int pathLength, /* Length of pathAry */ Tcl_Namespace *pathAry[]) /* Array of namespaces that are the path. */ { NamespacePathEntry *tmpPathArray; int i; |
︙ | ︙ |
Added generic/tclOO.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 | /* * tclOO.c -- * * This file contains the object-system core (NB: not Tcl_Obj, but ::oo) * * Copyright (c) 2005-2006 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclOO.c,v 1.1.2.69 2006/10/31 09:20:33 dkf Exp $ */ #include "tclInt.h" #include "tclOO.h" /* * Commands in oo::define. */ static const struct { const char *name; Tcl_ObjCmdProc *objProc; int flag; } defineCmds[] = { {"constructor", TclOODefineConstructorObjCmd, 0}, {"destructor", TclOODefineDestructorObjCmd, 0}, {"export", TclOODefineExportObjCmd, 0}, {"self.export", TclOODefineExportObjCmd, 1}, {"filter", TclOODefineFilterObjCmd, 0}, {"self.filter", TclOODefineFilterObjCmd, 1}, {"forward", TclOODefineForwardObjCmd, 0}, {"self.forward", TclOODefineForwardObjCmd, 1}, {"method", TclOODefineMethodObjCmd, 0}, {"self.method", TclOODefineMethodObjCmd, 1}, {"mixin", TclOODefineMixinObjCmd, 0}, {"self.mixin", TclOODefineMixinObjCmd, 1}, {"superclass", TclOODefineSuperclassObjCmd, 0}, {"unexport", TclOODefineUnexportObjCmd, 0}, {"self.unexport", TclOODefineUnexportObjCmd, 1}, {"self.class", TclOODefineSelfClassObjCmd, 1}, {NULL, NULL, 0} }; /* * Structure containing definition information about class methods. */ typedef struct DeclaredClassMethod { const char *name; /* Name of the method in question. */ int isPublic; /* Whether the method is public by default. */ Tcl_MethodCallProc callProc;/* How to call the method. */ } DeclaredClassMethod; /* * What sort of size of things we like to allocate. */ #define ALLOC_CHUNK 8 /* * Function declarations for things defined in this file. */ static Class * AllocClass(Tcl_Interp *interp, Object *useThisObj); static Object * AllocObject(Tcl_Interp *interp, const char *nameStr); static Method * CloneClassMethod(Tcl_Interp *interp, Class *clsPtr, Method *mPtr, Tcl_Obj *namePtr); static Method * CloneObjectMethod(Tcl_Interp *interp, Object *oPtr, Method *mPtr, Tcl_Obj *namePtr); static void DeclareClassMethod(Tcl_Interp *interp, Class *clsPtr, const DeclaredClassMethod *dcm); static void KillFoundation(ClientData clientData, Tcl_Interp *interp); static int ObjectCmd(Object *oPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, int publicOnly, Tcl_HashTable *cachePtr); static void ObjectNamespaceDeleted(ClientData clientData); static void ObjectDeletedTrace(ClientData clientData, Tcl_Interp *interp, const char *oldName, const char *newName, int flags); static void ReleaseClassContents(Tcl_Interp *interp,Object *oPtr); static int CopyObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int PublicObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int PrivateObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DeclaredClassMethodInvoke(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); static int InvokeProcedureMethod(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); static void DeleteProcedureMethod(ClientData clientData); static int CloneProcedureMethod(ClientData clientData, ClientData *newClientData); static int InvokeForwardMethod(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); static void DeleteForwardMethod(ClientData clientData); static int CloneForwardMethod(ClientData clientData, ClientData *newClientData); static Tcl_Obj ** InitEnsembleRewrite(Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, int toRewrite, int rewriteLength, Tcl_Obj *const *rewriteObjs, int *lengthPtr); static int ClassCreate(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); static int ClassNew(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); static int ObjectDestroy(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); static int ObjectEval(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); static int ObjectLinkVar(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); static int ObjectUnknown(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); static int ObjectVarName(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); static int NextObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int SelfObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); /* * The types of methods defined by the core OO system. */ static const Tcl_MethodType procMethodType = { TCL_OO_METHOD_VERSION_CURRENT, "procedural method", InvokeProcedureMethod, DeleteProcedureMethod, CloneProcedureMethod }; static const Tcl_MethodType fwdMethodType = { TCL_OO_METHOD_VERSION_CURRENT, "forward", InvokeForwardMethod, DeleteForwardMethod, CloneForwardMethod }; static const Tcl_MethodType coreMethodType = { TCL_OO_METHOD_VERSION_CURRENT, "core method", DeclaredClassMethodInvoke, NULL, NULL }; /* * Methods in the oo::object class. */ static const DeclaredClassMethod objMethods[] = { {"destroy", 1, ObjectDestroy}, {"eval", 0, ObjectEval}, {"unknown", 0, ObjectUnknown}, {"variable", 0, ObjectLinkVar}, {"varname", 0, ObjectVarName}, {NULL, 0, NULL} }; /* * Additional methods in the oo::class class. */ static const DeclaredClassMethod clsMethods[] = { {"create", 1, ClassCreate}, {"new", 1, ClassNew}, {NULL, 0, NULL} }; /* * ---------------------------------------------------------------------- * * TclOOInit -- * * Called to initialise the OO system within an interpreter. * * Result: * TCL_OK if the setup succeeded. Currently assumed to always work. * * Side effects: * Creates namespaces, commands, several classes and a number of * callbacks. Upon return, the OO system is ready for use. * * ---------------------------------------------------------------------- */ int TclOOInit( Tcl_Interp *interp) /* The interpreter to install into. */ { Interp *iPtr = (Interp *) interp; Foundation *fPtr; int i; Tcl_DString buffer; /* * Construct the foundation of the object system. This is a structure * holding references to the magical bits that need to be known about in * other places. */ fPtr = iPtr->ooFoundation = (Foundation *) ckalloc(sizeof(Foundation)); memset(fPtr, 0, sizeof(Foundation)); fPtr->ooNs = Tcl_CreateNamespace(interp, "::oo", fPtr, NULL); Tcl_Export(interp, fPtr->ooNs, "[a-z]*", 1); fPtr->defineNs = Tcl_CreateNamespace(interp, "::oo::define", NULL, NULL); fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", NULL, NULL); Tcl_CreateObjCommand(interp, "::oo::Helpers::next", NextObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "::oo::Helpers::self", SelfObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "::oo::copy", CopyObjectCmd, NULL, NULL); Tcl_DStringInit(&buffer); for (i=0 ; defineCmds[i].name ; i++) { Tcl_DStringAppend(&buffer, "::oo::define::", 14); Tcl_DStringAppend(&buffer, defineCmds[i].name, -1); Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), defineCmds[i].objProc, (void *) defineCmds[i].flag, NULL); Tcl_DStringFree(&buffer); } fPtr->epoch = 0; fPtr->nsCount = 0; fPtr->unknownMethodNameObj = Tcl_NewStringObj("unknown", -1); Tcl_IncrRefCount(fPtr->unknownMethodNameObj); Tcl_CallWhenDeleted(interp, KillFoundation, fPtr); /* * Create the objects at the core of the object system. These need to be * spliced manually. */ fPtr->objectCls = AllocClass(interp, AllocObject(interp, "::oo::object")); fPtr->classCls = AllocClass(interp, AllocObject(interp, "::oo::class")); fPtr->objectCls->thisPtr->selfCls = fPtr->classCls; fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT; fPtr->objectCls->superclasses.num = 0; ckfree((char *) fPtr->objectCls->superclasses.list); fPtr->objectCls->superclasses.list = NULL; fPtr->classCls->thisPtr->selfCls = fPtr->classCls; TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls); TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls); /* * Basic method declarations for the core classes. */ for (i=0 ; objMethods[i].name ; i++) { DeclareClassMethod(interp, fPtr->objectCls, &objMethods[i]); } for (i=0 ; clsMethods[i].name ; i++) { DeclareClassMethod(interp, fPtr->classCls, &clsMethods[i]); } /* * Finish setting up the class of classes. */ { Tcl_Obj *namePtr, *argsPtr, *bodyPtr; /* * Mark the 'new' method in oo::class as private; classes, unlike * general objects, must have explicit names. */ namePtr = Tcl_NewStringObj("new", -1); Tcl_NewMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr, namePtr, 0 /* ==private */, NULL, NULL); argsPtr = Tcl_NewStringObj("{definitionScript {}}", -1); bodyPtr = Tcl_NewStringObj( "if {[catch {define [self] $definitionScript} msg opt]} {\n" "set ei [split [dict get $opt -errorinfo] \\n]\n" "dict set opt -errorinfo [join [lrange $ei 0 end-2] \\n]\n" "dict set opt -errorline 0xdeadbeef\n" "}\n" "return -options $opt $msg", -1); fPtr->classCls->constructorPtr = TclOONewProcClassMethod(interp, fPtr->classCls, 0, NULL, argsPtr, bodyPtr); } /* * Finish setting up the [info object] and [info class] commands. */ TclOOInitInfo(interp); return TCL_OK; } /* * ---------------------------------------------------------------------- * * KillFoundation -- * * Delete those parts of the OO core that are not deleted automatically * when the objects and classes themselves are destroyed. * * ---------------------------------------------------------------------- */ static void KillFoundation( ClientData clientData, /* Pointer to the OO system foundation * structure. */ Tcl_Interp *interp) /* The interpreter containing the OO system * foundation. */ { Foundation *fPtr = clientData; TclDecrRefCount(fPtr->unknownMethodNameObj); ckfree((char *) fPtr); } /* * ---------------------------------------------------------------------- * * AllocObject -- * * Allocate an object of basic type. Does not splice the object into its * class's instance list. * * ---------------------------------------------------------------------- */ static Object * AllocObject( Tcl_Interp *interp, /* Interpreter within which to create the * object. */ const char *nameStr) /* The name of the object to create, or NULL * if the OO system should pick the object * name itself. */ { Foundation *fPtr = ((Interp *) interp)->ooFoundation; Tcl_Obj *cmdnameObj; Tcl_DString buffer; Object *oPtr; oPtr = (Object *) ckalloc(sizeof(Object)); memset(oPtr, 0, sizeof(Object)); while (1) { char objName[10 + TCL_INTEGER_SPACE]; sprintf(objName, "::oo::Obj%d", ++fPtr->nsCount); oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr, ObjectNamespaceDeleted); if (oPtr->namespacePtr != NULL) { break; } /* * Could not make that namespace, so we make another. But first we * have to get rid of the error message from Tcl_CreateNamespace, * since that's something that should not be exposed to the user. */ Tcl_ResetResult(interp); } TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs); oPtr->selfCls = fPtr->objectCls; Tcl_InitObjHashTable(&oPtr->methods); Tcl_InitObjHashTable(&oPtr->publicContextCache); Tcl_InitObjHashTable(&oPtr->privateContextCache); oPtr->filters.num = 0; oPtr->filters.list = NULL; oPtr->mixins.num = 0; oPtr->mixins.list = NULL; oPtr->classPtr = NULL; oPtr->flags = 0; oPtr->metadataPtr = NULL; /* * Initialize the traces. */ Tcl_DStringInit(&buffer); if (nameStr) { if (nameStr[0] != ':' || nameStr[1] != ':') { Tcl_DStringAppend(&buffer, Tcl_GetCurrentNamespace(interp)->fullName, -1); Tcl_DStringAppend(&buffer, "::", 2); } Tcl_DStringAppend(&buffer, nameStr, -1); } else { Tcl_DStringAppend(&buffer, oPtr->namespacePtr->fullName, -1); } oPtr->command = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), PublicObjectCmd, oPtr, NULL); if (nameStr) { Tcl_DStringFree(&buffer); Tcl_DStringAppend(&buffer, oPtr->namespacePtr->fullName, -1); } Tcl_DStringAppend(&buffer, "::my", 4); oPtr->myCommand = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), PrivateObjectCmd, oPtr, NULL); Tcl_DStringFree(&buffer); TclNewObj(cmdnameObj); Tcl_GetCommandFullName(interp, oPtr->command, cmdnameObj); Tcl_TraceCommand(interp, TclGetString(cmdnameObj), TCL_TRACE_DELETE, ObjectDeletedTrace, oPtr); TclDecrRefCount(cmdnameObj); return oPtr; } /* * ---------------------------------------------------------------------- * * ObjectDeletedTrace -- * * This callback is triggered when the object is deleted by any * mechanism. It runs the destructors and arranges for the actual cleanup * of the object's namespace, which in turn triggers cleansing of the * object data structures. * * ---------------------------------------------------------------------- */ static void ObjectDeletedTrace( ClientData clientData, /* The object being deleted. */ Tcl_Interp *interp, /* The interpreter containing the object. */ const char *oldName, /* What the object was (last) called. */ const char *newName, /* Always NULL. */ int flags) /* Why was the object deleted? */ { Interp *iPtr = (Interp *) interp; Object *oPtr = clientData; Class *clsPtr; Tcl_Preserve(oPtr); oPtr->flags |= OBJECT_DELETED; if (!Tcl_InterpDeleted(interp)) { CallContext *contextPtr = TclOOGetCallContext(iPtr->ooFoundation, oPtr, NULL, DESTRUCTOR, NULL); if (contextPtr != NULL) { int result; Tcl_InterpState state; contextPtr->flags |= DESTRUCTOR; contextPtr->skip = 0; state = Tcl_SaveInterpState(interp, TCL_OK); result = TclOOInvokeContext(interp, contextPtr, 0, NULL); if (result != TCL_OK) { Tcl_BackgroundError(interp); } (void) Tcl_RestoreInterpState(interp, state); TclOODeleteContext(contextPtr); } } clsPtr = oPtr->classPtr; if (clsPtr != NULL) { ReleaseClassContents(interp, oPtr); } Tcl_DeleteNamespace(oPtr->namespacePtr); if (clsPtr) { Tcl_Release(clsPtr); } Tcl_Release(oPtr); /* * What else to do to delete an object? */ } /* * ---------------------------------------------------------------------- * * ReleaseClassContents -- * * Tear down the special class data structure, including deleting all * dependent classes and objects. * * ---------------------------------------------------------------------- */ static void ReleaseClassContents( Tcl_Interp *interp, /* The interpreter containing the class. */ Object *oPtr) /* The object representing the class. */ { int i, n; Class *clsPtr, **list; Object **insts; clsPtr = oPtr->classPtr; Tcl_Preserve(clsPtr); /* * Must empty list before processing the members of the list so that * things happen in the correct order even if something tries to play * fast-and-loose. */ list = clsPtr->mixinSubs.list; n = clsPtr->mixinSubs.num; clsPtr->mixinSubs.list = NULL; clsPtr->mixinSubs.num = 0; clsPtr->mixinSubs.size = 0; for (i=0 ; i<n ; i++) { Tcl_Preserve(list[i]); } for (i=0 ; i<n ; i++) { if (!(list[i]->flags & OBJECT_DELETED) && interp != NULL) { Tcl_DeleteCommandFromToken(interp, list[i]->thisPtr->command); } Tcl_Release(list[i]); } if (list != NULL) { ckfree((char *) list); } list = clsPtr->subclasses.list; n = clsPtr->subclasses.num; clsPtr->subclasses.list = NULL; clsPtr->subclasses.num = 0; clsPtr->subclasses.size = 0; for (i=0 ; i<n ; i++) { Tcl_Preserve(list[i]); } for (i=0 ; i<n ; i++) { if (!(list[i]->flags & OBJECT_DELETED) && interp != NULL) { Tcl_DeleteCommandFromToken(interp, list[i]->thisPtr->command); } Tcl_Release(list[i]); } if (list != NULL) { ckfree((char *) list); } insts = clsPtr->instances.list; n = clsPtr->instances.num; clsPtr->instances.list = NULL; clsPtr->instances.num = 0; clsPtr->instances.size = 0; for (i=0 ; i<n ; i++) { Tcl_Preserve(insts[i]); } for (i=0 ; i<n ; i++) { if (!(insts[i]->flags & OBJECT_DELETED) && interp != NULL) { Tcl_DeleteCommandFromToken(interp, insts[i]->command); } Tcl_Release(insts[i]); } if (insts != NULL) { ckfree((char *) insts); } if (clsPtr->filters.num) { Tcl_Obj *filterObj; FOREACH(filterObj, clsPtr->filters) { TclDecrRefCount(filterObj); } ckfree((char *) clsPtr->filters.list); clsPtr->filters.num = 0; } if (clsPtr->metadataPtr != NULL) { FOREACH_HASH_DECLS; Tcl_ObjectMetadataType *metadataTypePtr; ClientData value; FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) { metadataTypePtr->deleteProc(value); } Tcl_DeleteHashTable(clsPtr->metadataPtr); ckfree((char *) clsPtr->metadataPtr); clsPtr->metadataPtr = NULL; } } /* * ---------------------------------------------------------------------- * * ObjectNamespaceDeleted -- * * Callback when the object's namespace is deleted. Used to clean up the * data structures associated with the object. The complicated bit is * that this can sometimes happen before the object's command is deleted * (interpreter teardown is complex!) * * ---------------------------------------------------------------------- */ static void ObjectNamespaceDeleted( ClientData clientData) /* Pointer to the class whose namespace is * being deleted. */ { Object *oPtr = clientData; FOREACH_HASH_DECLS; Class *clsPtr, *mixinPtr; CallContext *contextPtr; Method *mPtr; Tcl_Obj *filterObj; int i; /* * Instruct everyone to no longer use any allocated fields of the object. */ if (!(oPtr->flags & OBJECT_DELETED)) { Tcl_Preserve(oPtr); if (oPtr->classPtr != NULL) { ReleaseClassContents(NULL, oPtr); } } oPtr->flags |= OBJECT_DELETED; /* * Splice the object out of its context. After this, we must *not* call * methods on the object. */ if (!(oPtr->flags & ROOT_OBJECT)) { TclOORemoveFromInstances(oPtr, oPtr->selfCls); } FOREACH(mixinPtr, oPtr->mixins) { TclOORemoveFromInstances(oPtr, mixinPtr); } if (i) { ckfree((char *)oPtr->mixins.list); } FOREACH(filterObj, oPtr->filters) { TclDecrRefCount(filterObj); } if (i) { ckfree((char *)oPtr->filters.list); } FOREACH_HASH_VALUE(mPtr, &oPtr->methods) { TclOODeleteMethod(mPtr); } Tcl_DeleteHashTable(&oPtr->methods); FOREACH_HASH_VALUE(contextPtr, &oPtr->publicContextCache) { if (contextPtr) { TclOODeleteContext(contextPtr); } } Tcl_DeleteHashTable(&oPtr->publicContextCache); FOREACH_HASH_VALUE(contextPtr, &oPtr->privateContextCache) { if (contextPtr) { TclOODeleteContext(contextPtr); } } Tcl_DeleteHashTable(&oPtr->privateContextCache); if (oPtr->metadataPtr != NULL) { FOREACH_HASH_DECLS; Tcl_ObjectMetadataType *metadataTypePtr; ClientData value; FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) { metadataTypePtr->deleteProc(value); } Tcl_DeleteHashTable(oPtr->metadataPtr); ckfree((char *) oPtr->metadataPtr); oPtr->metadataPtr = NULL; } clsPtr = oPtr->classPtr; if (clsPtr != NULL && !(oPtr->flags & ROOT_OBJECT)) { Class *superPtr, *mixinPtr; clsPtr->flags |= OBJECT_DELETED; FOREACH(mixinPtr, clsPtr->mixins) { if (!(mixinPtr->flags & OBJECT_DELETED)) { TclOORemoveFromSubclasses(clsPtr, mixinPtr); } } if (i) { ckfree((char *) clsPtr->mixins.list); clsPtr->mixins.num = 0; } FOREACH(superPtr, clsPtr->superclasses) { if (!(superPtr->flags & OBJECT_DELETED)) { TclOORemoveFromSubclasses(clsPtr, superPtr); } } if (i) { ckfree((char *) clsPtr->superclasses.list); clsPtr->superclasses.num = 0; } if (clsPtr->subclasses.list) { ckfree((char *) clsPtr->subclasses.list); clsPtr->subclasses.num = 0; } if (clsPtr->instances.list) { ckfree((char *) clsPtr->instances.list); clsPtr->instances.num = 0; } if (clsPtr->mixinSubs.list) { ckfree((char *) clsPtr->mixinSubs.list); clsPtr->mixinSubs.num = 0; } if (clsPtr->classHierarchy.list) { ckfree((char *) clsPtr->classHierarchy.list); clsPtr->classHierarchy.num = 0; } FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) { TclOODeleteMethod(mPtr); } Tcl_DeleteHashTable(&clsPtr->classMethods); TclOODeleteMethod(clsPtr->constructorPtr); TclOODeleteMethod(clsPtr->destructorPtr); Tcl_EventuallyFree(clsPtr, TCL_DYNAMIC); } /* * Delete the object structure itself. */ if (!(oPtr->flags & OBJECT_DELETED)) { Tcl_EventuallyFree(oPtr, TCL_DYNAMIC); Tcl_Release(oPtr); } else { Tcl_EventuallyFree(oPtr, TCL_DYNAMIC); } } /* * ---------------------------------------------------------------------- * * TclOORemoveFromInstances -- * * Utility function to remove an object from the list of instances within * a class. * * ---------------------------------------------------------------------- */ void TclOORemoveFromInstances( Object *oPtr, /* The instance to remove. */ Class *clsPtr) /* The class (possibly) containing the * reference to the instance. */ { int i; Object *instPtr; FOREACH(instPtr, clsPtr->instances) { if (oPtr == instPtr) { goto removeInstance; } } return; removeInstance: clsPtr->instances.num--; if (i < clsPtr->instances.num) { clsPtr->instances.list[i] = clsPtr->instances.list[clsPtr->instances.num]; } clsPtr->instances.list[clsPtr->instances.num] = NULL; } /* * ---------------------------------------------------------------------- * * TclOOAddToInstances -- * * Utility function to add an object to the list of instances within a * class. * * ---------------------------------------------------------------------- */ void TclOOAddToInstances( Object *oPtr, /* The instance to add. */ Class *clsPtr) /* The class to add the instance to. It is * assumed that the class is not already * present as an instance in the class. */ { if (clsPtr->instances.num >= clsPtr->instances.size) { clsPtr->instances.size += ALLOC_CHUNK; if (clsPtr->instances.size == ALLOC_CHUNK) { clsPtr->instances.list = (Object **) ckalloc(sizeof(Object *) * ALLOC_CHUNK); } else { clsPtr->instances.list = (Object **) ckrealloc((char *) clsPtr->instances.list, sizeof(Object *) * clsPtr->instances.size); } } clsPtr->instances.list[clsPtr->instances.num++] = oPtr; } /* * ---------------------------------------------------------------------- * * TclOORemoveFromSubclasses -- * * Utility function to remove a class from the list of subclasses within * another class. * * ---------------------------------------------------------------------- */ void TclOORemoveFromSubclasses( Class *subPtr, /* The subclass to remove. */ Class *superPtr) /* The superclass to (possibly) remove the * subclass reference from. */ { int i; Class *subclsPtr; FOREACH(subclsPtr, superPtr->subclasses) { if (subPtr == subclsPtr) { goto removeSubclass; } } return; removeSubclass: superPtr->subclasses.num--; if (i < superPtr->subclasses.num) { superPtr->subclasses.list[i] = superPtr->subclasses.list[superPtr->subclasses.num]; } superPtr->subclasses.list[superPtr->subclasses.num] = NULL; } /* * ---------------------------------------------------------------------- * * TclOOAddToSubclasses -- * * Utility function to add a class to the list of subclasses within * another class. * * ---------------------------------------------------------------------- */ void TclOOAddToSubclasses( Class *subPtr, /* The subclass to add. */ Class *superPtr) /* The superclass to add the subclass to. It * is assumed that the class is not already * present as a subclass in the superclass. */ { if (superPtr->subclasses.num >= superPtr->subclasses.size) { superPtr->subclasses.size += ALLOC_CHUNK; if (superPtr->subclasses.size == ALLOC_CHUNK) { superPtr->subclasses.list = (Class **) ckalloc(sizeof(Class *) * ALLOC_CHUNK); } else { superPtr->subclasses.list = (Class **) ckrealloc((char *) superPtr->subclasses.list, sizeof(Class *) * superPtr->subclasses.size); } } superPtr->subclasses.list[superPtr->subclasses.num++] = subPtr; } /* * ---------------------------------------------------------------------- * * TclOORemoveFromMixinSubs -- * * Utility function to remove a class from the list of mixinSubs within * another class. * * ---------------------------------------------------------------------- */ void TclOORemoveFromMixinSubs( Class *subPtr, /* The subclass to remove. */ Class *superPtr) /* The superclass to (possibly) remove the * subclass reference from. */ { int i; Class *subclsPtr; FOREACH(subclsPtr, superPtr->mixinSubs) { if (subPtr == subclsPtr) { goto removeSubclass; } } return; removeSubclass: superPtr->mixinSubs.num--; if (i < superPtr->mixinSubs.num) { superPtr->mixinSubs.list[i] = superPtr->mixinSubs.list[superPtr->mixinSubs.num]; } superPtr->mixinSubs.list[superPtr->mixinSubs.num] = NULL; } /* * ---------------------------------------------------------------------- * * TclOOAddToMixinSubs -- * * Utility function to add a class to the list of mixinSubs within * another class. * * ---------------------------------------------------------------------- */ void TclOOAddToMixinSubs( Class *subPtr, /* The subclass to add. */ Class *superPtr) /* The superclass to add the subclass to. It * is assumed that the class is not already * present as a subclass in the superclass. */ { if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) { superPtr->mixinSubs.size += ALLOC_CHUNK; if (superPtr->mixinSubs.size == ALLOC_CHUNK) { superPtr->mixinSubs.list = (Class **) ckalloc(sizeof(Class *) * ALLOC_CHUNK); } else { superPtr->mixinSubs.list = (Class **) ckrealloc((char *) superPtr->mixinSubs.list, sizeof(Class *) * superPtr->mixinSubs.size); } } superPtr->mixinSubs.list[superPtr->mixinSubs.num++] = subPtr; } /* * ---------------------------------------------------------------------- * * AllocClass -- * * Allocate a basic class. Does not splice the class object into its * class's instance list. * * ---------------------------------------------------------------------- */ static Class * AllocClass( Tcl_Interp *interp, /* Interpreter within which to allocate the * class. */ Object *useThisObj) /* Object that is to act as the class * representation, or NULL if a new object * (with automatic name) is to be used. */ { Class *clsPtr; Foundation *fPtr = ((Interp *) interp)->ooFoundation; clsPtr = (Class *) ckalloc(sizeof(Class)); memset(clsPtr, 0, sizeof(Class)); if (useThisObj == NULL) { clsPtr->thisPtr = AllocObject(interp, NULL); } else { clsPtr->thisPtr = useThisObj; } clsPtr->thisPtr->selfCls = fPtr->classCls; if (fPtr->classCls != NULL) { TclOOAddToInstances(clsPtr->thisPtr, fPtr->classCls); TclOOAddToSubclasses(clsPtr, fPtr->objectCls); } { Tcl_Namespace *path[2]; path[0] = fPtr->helpersNs; path[1] = fPtr->ooNs; TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path); } clsPtr->thisPtr->classPtr = clsPtr; clsPtr->flags = 0; clsPtr->superclasses.num = 1; clsPtr->superclasses.list = (Class **) ckalloc(sizeof(Class *)); clsPtr->superclasses.list[0] = fPtr->objectCls; clsPtr->subclasses.num = 0; clsPtr->subclasses.list = NULL; clsPtr->subclasses.size = 0; clsPtr->instances.num = 0; clsPtr->instances.list = NULL; clsPtr->instances.size = 0; clsPtr->filters.list = NULL; clsPtr->filters.num = 0; clsPtr->mixins.list = NULL; clsPtr->mixins.num = 0; clsPtr->mixinSubs.list = NULL; clsPtr->mixinSubs.num = 0; clsPtr->mixinSubs.size = 0; clsPtr->classHierarchy.list = NULL; clsPtr->classHierarchy.num = 0; clsPtr->classHierarchyEpoch = fPtr->epoch-1; Tcl_InitObjHashTable(&clsPtr->classMethods); clsPtr->constructorPtr = NULL; clsPtr->destructorPtr = NULL; clsPtr->metadataPtr = NULL; return clsPtr; } /* * ---------------------------------------------------------------------- * * Tcl_NewObjectInstance -- * * Allocate a new instance of an object. * * ---------------------------------------------------------------------- */ Tcl_Object Tcl_NewObjectInstance( Tcl_Interp *interp, /* Interpreter context. */ Tcl_Class cls, /* Class to create an instance of. */ const char *name, /* Name of object to create, or NULL to ask * the code to pick its own unique name. */ int objc, /* Number of arguments. Negative value means * do not call constructor. */ Tcl_Obj *const *objv, /* Argument list. */ int skip) /* Number of arguments to _not_ pass to the * constructor. */ { Object *oPtr = AllocObject(interp, NULL); CallContext *contextPtr; oPtr->selfCls = (Class *) cls; TclOOAddToInstances(oPtr, (Class *) cls); if (name != NULL) { Tcl_Obj *cmdnameObj; TclNewObj(cmdnameObj); Tcl_GetCommandFullName(interp, oPtr->command, cmdnameObj); if (TclRenameCommand(interp, TclGetString(cmdnameObj), name) != TCL_OK) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "can't create object \"", name, "\": command already exists with that name", NULL); TclDecrRefCount(cmdnameObj); Tcl_DeleteCommandFromToken(interp, oPtr->command); return NULL; } TclDecrRefCount(cmdnameObj); } /* * Check to see if we're really creating a class. If so, allocate the * class structure as well. */ if (TclOOIsReachable((((Interp *) interp)->ooFoundation)->classCls, (Class *) cls)) { /* * Is a class, so attach a class structure. Note that the AllocClass * function splices the structure into the object, so we don't have * to. Once that's done, we need to repatch the object to have the * right class since AllocClass interferes with that. */ AllocClass(interp, oPtr); oPtr->selfCls = (Class *) cls; } if (objc >= 0) { contextPtr = TclOOGetCallContext(((Interp *)interp)->ooFoundation, oPtr, NULL, CONSTRUCTOR, NULL); if (contextPtr != NULL) { int result; Tcl_InterpState state; Tcl_Preserve(oPtr); state = Tcl_SaveInterpState(interp, TCL_OK); contextPtr->flags |= CONSTRUCTOR; contextPtr->skip = skip; result = TclOOInvokeContext(interp, contextPtr, objc, objv); TclOODeleteContext(contextPtr); Tcl_Release(oPtr); if (result != TCL_OK) { Tcl_DiscardInterpState(state); Tcl_DeleteCommandFromToken(interp, oPtr->command); return NULL; } (void) Tcl_RestoreInterpState(interp, state); } } return (Tcl_Object) oPtr; } /* * ---------------------------------------------------------------------- * * Tcl_CopyObjectInstance -- * * Creates a copy of an object. Does not copy the backing namespace, * since the correct way to do that (e.g., shallow/deep) depends on the * object/class's own policies. * * ---------------------------------------------------------------------- */ Tcl_Object Tcl_CopyObjectInstance( Tcl_Interp *interp, Tcl_Object sourceObject, const char *targetName) { Object *oPtr = (Object *) sourceObject, *o2Ptr; Interp *iPtr = (Interp *) interp; FOREACH_HASH_DECLS; Method *mPtr; Class *mixinPtr; Tcl_Obj *keyPtr, *filterObj; int i; /* * Sanity checks. */ if (targetName == NULL && oPtr->classPtr != NULL) { Tcl_AppendResult(interp, "must supply a name when copying a class", NULL); return NULL; } if (oPtr->classPtr == iPtr->ooFoundation->classCls) { Tcl_AppendResult(interp, "may not clone the class of classes", NULL); return NULL; } /* * Build the instance. Note that this does not run any constructors. */ o2Ptr = (Object *) Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->selfCls, targetName, -1, NULL, -1); if (o2Ptr == NULL) { return NULL; } /* * Copy the object-local methods to the new object. */ FOREACH_HASH(keyPtr, mPtr, &oPtr->methods) { (void) CloneObjectMethod(interp, o2Ptr, mPtr, keyPtr); } /* * Copy the object's mixin references to the new object. */ FOREACH(mixinPtr, o2Ptr->mixins) { if (mixinPtr != o2Ptr->selfCls) { TclOORemoveFromInstances(o2Ptr, mixinPtr); } } DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *); FOREACH(mixinPtr, o2Ptr->mixins) { if (mixinPtr != o2Ptr->selfCls) { TclOOAddToInstances(o2Ptr, mixinPtr); } } /* * Copy the object's filter list to the new object. */ DUPLICATE(o2Ptr->filters, oPtr->filters, Tcl_Obj *); FOREACH(filterObj, o2Ptr->filters) { Tcl_IncrRefCount(filterObj); } /* * Copy the object's flags to the new object, clearing those that must be * kept object-local. The duplicate is never deleted at this point, nor is * it the root of the object system or in the midst of processing a filter * call. */ o2Ptr->flags = oPtr->flags & ~( OBJECT_DELETED | ROOT_OBJECT | FILTER_HANDLING); /* * Copy the object's metadata. */ if (oPtr->metadataPtr != NULL) { Tcl_ObjectMetadataType *metadataTypePtr; ClientData value, duplicate; FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) { if (metadataTypePtr->cloneProc == NULL) { continue; } duplicate = metadataTypePtr->cloneProc(value); if (duplicate != NULL) { Tcl_ObjectSetMetadata((Tcl_Object) o2Ptr, metadataTypePtr, duplicate); } } } /* * Copy the class, if present. Note that if there is a class present in * the source object, there must also be one in the copy. */ if (oPtr->classPtr != NULL) { Class *clsPtr = oPtr->classPtr; Class *cls2Ptr = o2Ptr->classPtr; Class *superPtr; /* * Copy the class flags across. */ cls2Ptr->flags = clsPtr->flags; /* * Ensure that the new class's superclass structure is the same as the * old class's. */ FOREACH(superPtr, cls2Ptr->superclasses) { TclOORemoveFromSubclasses(cls2Ptr, superPtr); } if (cls2Ptr->superclasses.num) { cls2Ptr->superclasses.list = (Class **) ckrealloc((char *) cls2Ptr->superclasses.list, sizeof(Class *) * clsPtr->superclasses.num); } else { cls2Ptr->superclasses.list = (Class **) ckalloc(sizeof(Class *) * clsPtr->superclasses.num); } memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list, sizeof(Class *) * clsPtr->superclasses.num); cls2Ptr->superclasses.num = clsPtr->superclasses.num; FOREACH(superPtr, cls2Ptr->superclasses) { TclOOAddToSubclasses(cls2Ptr, superPtr); } /* * Duplicate the source class's filters. */ DUPLICATE(cls2Ptr->filters, clsPtr->filters, Tcl_Obj *); FOREACH(filterObj, cls2Ptr->filters) { Tcl_IncrRefCount(filterObj); } /* * Duplicate the source class's mixins (which cannot be circular * references to the duplicate). */ FOREACH(mixinPtr, cls2Ptr->mixins) { TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr); } if (cls2Ptr->mixins.num != 0) { ckfree((char *) clsPtr->mixins.list); } DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *); FOREACH(mixinPtr, cls2Ptr->mixins) { TclOOAddToMixinSubs(cls2Ptr, mixinPtr); } /* * Duplicate the source class's methods, constructor and destructor. */ FOREACH_HASH(keyPtr, mPtr, &clsPtr->classMethods) { (void) CloneClassMethod(interp, cls2Ptr, mPtr, keyPtr); } if (clsPtr->constructorPtr) { cls2Ptr->constructorPtr = CloneClassMethod(interp, cls2Ptr, clsPtr->constructorPtr, NULL); } if (clsPtr->destructorPtr) { cls2Ptr->destructorPtr = CloneClassMethod(interp, cls2Ptr, clsPtr->destructorPtr, NULL); } /* * Duplicate the class's metadata. */ if (clsPtr->metadataPtr != NULL) { Tcl_ObjectMetadataType *metadataTypePtr; ClientData value, duplicate; FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) { if (metadataTypePtr->cloneProc == NULL) { continue; } duplicate = metadataTypePtr->cloneProc(value); if (duplicate != NULL) { Tcl_ClassSetMetadata((Tcl_Class) cls2Ptr, metadataTypePtr, duplicate); } } } } return (Tcl_Object) o2Ptr; } /* * ---------------------------------------------------------------------- * * CloneObjectMethod, CloneClassMethod -- * * Helper functions used for cloning methods. They work identically to * each other, except for the difference between them in how they * register the cloned method on a successful clone. * * ---------------------------------------------------------------------- */ static Method * CloneObjectMethod( Tcl_Interp *interp, Object *oPtr, Method *mPtr, Tcl_Obj *namePtr) { if (mPtr->typePtr == NULL) { return (Method *) Tcl_NewMethod(interp, (Tcl_Object) oPtr, namePtr, mPtr->flags & PUBLIC_METHOD, NULL, NULL); } else if (mPtr->typePtr->cloneProc) { ClientData newClientData; if (mPtr->typePtr->cloneProc(mPtr->clientData, &newClientData) != TCL_OK) { return NULL; } return (Method *) Tcl_NewMethod(interp, (Tcl_Object) oPtr, namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, newClientData); } else { return (Method *) Tcl_NewMethod(interp, (Tcl_Object) oPtr, namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, mPtr->clientData); } } static Method * CloneClassMethod( Tcl_Interp *interp, Class *clsPtr, Method *mPtr, Tcl_Obj *namePtr) { if (mPtr->typePtr == NULL) { return (Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr, namePtr, mPtr->flags & PUBLIC_METHOD, NULL, NULL); } else if (mPtr->typePtr->cloneProc) { ClientData newClientData; if (mPtr->typePtr->cloneProc(mPtr->clientData, &newClientData) != TCL_OK) { return NULL; } return (Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr, namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, newClientData); } else { return (Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr, namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, mPtr->clientData); } } /* * ---------------------------------------------------------------------- * * Tcl_NewMethod -- * * Attach a method to an object. * * ---------------------------------------------------------------------- */ Tcl_Method Tcl_NewMethod( Tcl_Interp *interp, /* Unused? */ Tcl_Object object, /* The object that has the method attached to * it. */ Tcl_Obj *nameObj, /* The name of the method. May be NULL; if so, * up to caller to manage storage (e.g., when * it is a constructor or destructor). */ int flags, /* Whether this is a public method. */ const Tcl_MethodType *typePtr, /* The type of method this is, which defines * how to invoke, delete and clone the * method. */ ClientData clientData) /* Some data associated with the particular * method to be created. */ { register Object *oPtr = (Object *) object; register Method *mPtr; Tcl_HashEntry *hPtr; int isNew; if (nameObj == NULL) { mPtr = (Method *) ckalloc(sizeof(Method)); mPtr->namePtr = NULL; goto populate; } hPtr = Tcl_CreateHashEntry(&oPtr->methods, (char *) nameObj, &isNew); if (isNew) { mPtr = (Method *) ckalloc(sizeof(Method)); mPtr->namePtr = nameObj; Tcl_IncrRefCount(nameObj); Tcl_SetHashValue(hPtr, mPtr); } else { mPtr = Tcl_GetHashValue(hPtr); if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) { mPtr->typePtr->deleteProc(mPtr->clientData); } } populate: mPtr->typePtr = typePtr; mPtr->clientData = clientData; mPtr->flags = 0; mPtr->declaringObjectPtr = oPtr; mPtr->declaringClassPtr = NULL; if (flags) { mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD); } oPtr->epoch++; return (Tcl_Method) mPtr; } /* * ---------------------------------------------------------------------- * * Tcl_NewClassMethod -- * * Attach a method to a class. * * ---------------------------------------------------------------------- */ Tcl_Method Tcl_NewClassMethod( Tcl_Interp *interp, /* The interpreter containing the class. */ Tcl_Class cls, /* The class to attach the method to. */ Tcl_Obj *nameObj, /* The name of the object. May be NULL (e.g., * for constructors or destructors); if so, up * to caller to manage storage. */ int flags, /* Whether this is a public method. */ const Tcl_MethodType *typePtr, /* The type of method this is, which defines * how to invoke, delete and clone the * method. */ ClientData clientData) /* Some data associated with the particular * method to be created. */ { register Class *clsPtr = (Class *) cls; register Method *mPtr; Tcl_HashEntry *hPtr; int isNew; if (nameObj == NULL) { mPtr = (Method *) ckalloc(sizeof(Method)); mPtr->namePtr = NULL; goto populate; } hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char *)nameObj,&isNew); if (isNew) { mPtr = (Method *) ckalloc(sizeof(Method)); mPtr->namePtr = nameObj; Tcl_IncrRefCount(nameObj); Tcl_SetHashValue(hPtr, mPtr); } else { mPtr = Tcl_GetHashValue(hPtr); if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) { mPtr->typePtr->deleteProc(mPtr->clientData); } } populate: ((Interp *) interp)->ooFoundation->epoch++; mPtr->typePtr = typePtr; mPtr->clientData = clientData; mPtr->flags = 0; mPtr->declaringObjectPtr = NULL; mPtr->declaringClassPtr = clsPtr; if (flags) { mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD); } return (Tcl_Method) mPtr; } /* * ---------------------------------------------------------------------- * * DeleteMethodStruct -- * * Function used when deleting a method. Always called indirectly via * Tcl_EventuallyFree(). * * ---------------------------------------------------------------------- */ static void DeleteMethodStruct( char *buffer) { Method *mPtr = (Method *) buffer; if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) { mPtr->typePtr->deleteProc(mPtr->clientData); } if (mPtr->namePtr != NULL) { TclDecrRefCount(mPtr->namePtr); } ckfree(buffer); } /* * ---------------------------------------------------------------------- * * TclOODeleteMethod -- * * How to delete a method. * * ---------------------------------------------------------------------- */ void TclOODeleteMethod( Method *mPtr) { if (mPtr != NULL) { Tcl_EventuallyFree(mPtr, DeleteMethodStruct); } } /* * ---------------------------------------------------------------------- * * DeclareClassMethod -- * * Helper that makes it cleaner to create very simple methods during * basic system initialization. Not suitable for general use. * * ---------------------------------------------------------------------- */ static void DeclareClassMethod( Tcl_Interp *interp, Class *clsPtr, /* Class to attach the method to. */ const DeclaredClassMethod *dcm) /* Name of the method, whether it is public, * and the function to implement it. */ { Tcl_Obj *namePtr; TclNewStringObj(namePtr, dcm->name, strlen(dcm->name)); Tcl_IncrRefCount(namePtr); Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr, namePtr, (dcm->isPublic ? PUBLIC_METHOD : 0), &coreMethodType, (ClientData) dcm); TclDecrRefCount(namePtr); } /* * ---------------------------------------------------------------------- * * DeclaredClassMethodInvoke -- * * How to invoke a simple method. * * ---------------------------------------------------------------------- */ static int DeclaredClassMethodInvoke( ClientData clientData, /* Pointer to function that implements the * method. */ Tcl_Interp *interp, Tcl_ObjectContext context, /* The method calling context. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Arguments as actually seen. */ { const DeclaredClassMethod *dcm = clientData; return (dcm->callProc)(NULL, interp, context, objc, objv); } /* * ---------------------------------------------------------------------- * * TclOONewProcMethod -- * * Create a new procedure-like method for an object. * * ---------------------------------------------------------------------- */ Method * TclOONewProcMethod( Tcl_Interp *interp, /* The interpreter containing the object. */ Object *oPtr, /* The object to modify. */ int flags, /* Whether this is a public method. */ Tcl_Obj *nameObj, /* The name of the method, which must not be * NULL. */ Tcl_Obj *argsObj, /* The formal argument list for the method, * which must not be NULL. */ Tcl_Obj *bodyObj) /* The body of the method, which must not be * NULL. */ { int argsc; Tcl_Obj **argsv; register ProcedureMethod *pmPtr; const char *procName; if (Tcl_ListObjGetElements(interp, argsObj, &argsc, &argsv) != TCL_OK) { return NULL; } pmPtr = (ProcedureMethod *) ckalloc(sizeof(ProcedureMethod)); procName = TclGetString(nameObj); if (TclCreateProc(interp, NULL, procName, argsObj, bodyObj, &pmPtr->procPtr) != TCL_OK) { ckfree((char *) pmPtr); return NULL; } return (Method *) Tcl_NewMethod(interp, (Tcl_Object) oPtr, nameObj, flags, &procMethodType, pmPtr); } /* * ---------------------------------------------------------------------- * * TclOONewProcClassMethod -- * * Create a new procedure-like method for a class. * * ---------------------------------------------------------------------- */ Method * TclOONewProcClassMethod( Tcl_Interp *interp, /* The interpreter containing the class. */ Class *clsPtr, /* The class to modify. */ int flags, /* Whether this is a public method. */ Tcl_Obj *nameObj, /* The name of the method, which may be NULL; * if so, up to caller to manage storage * (e.g., because it is a constructor or * destructor). */ Tcl_Obj *argsObj, /* The formal argument list for the method, * which may be NULL; if so, it is equivalent * to an empty list. */ Tcl_Obj *bodyObj) /* The body of the method, which must not be * NULL. */ { int argsLen; /* -1 => delete argsObj before exit */ register ProcedureMethod *pmPtr; const char *procName; if (argsObj == NULL) { argsLen = -1; TclNewObj(argsObj); Tcl_IncrRefCount(argsObj); procName = "<destructor>"; } else if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) { return NULL; } else { procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj)); } pmPtr = (ProcedureMethod *) ckalloc(sizeof(ProcedureMethod)); if (TclCreateProc(interp, NULL, procName, argsObj, bodyObj, &pmPtr->procPtr) != TCL_OK) { if (argsLen == -1) { TclDecrRefCount(argsObj); } ckfree((char *) pmPtr); return NULL; } if (argsLen == -1) { TclDecrRefCount(argsObj); } return (Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, &procMethodType, pmPtr); } /* * ---------------------------------------------------------------------- * * InvokeProcedureMethod -- * * How to invoke a procedure-like method. * * ---------------------------------------------------------------------- */ static int InvokeProcedureMethod( ClientData clientData, /* Pointer to some per-method context. */ Tcl_Interp *interp, Tcl_ObjectContext context, /* The method calling context. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Arguments as actually seen. */ { CallContext *contextPtr = (CallContext *) context; ProcedureMethod *pmPtr = (ProcedureMethod *) clientData; int result, flags = FRAME_IS_METHOD, skip = contextPtr->skip; CallFrame *framePtr, **framePtrPtr; Object *oPtr = contextPtr->oPtr; Command cmd; const char *namePtr; Tcl_Obj *nameObj; cmd.nsPtr = (Namespace *) oPtr->namespacePtr; pmPtr->procPtr->cmdPtr = &cmd; if (contextPtr->flags & CONSTRUCTOR) { namePtr = "<constructor>"; flags |= FRAME_IS_CONSTRUCTOR; nameObj = Tcl_NewStringObj("<constructor>", -1); Tcl_IncrRefCount(nameObj); } else if (contextPtr->flags & DESTRUCTOR) { namePtr = "<destructor>"; flags |= FRAME_IS_DESTRUCTOR; nameObj = Tcl_NewStringObj("<destructor>", -1); Tcl_IncrRefCount(nameObj); } else { nameObj = objv[contextPtr->skip-1]; namePtr = TclGetString(nameObj); } result = TclProcCompileProc(interp, pmPtr->procPtr, pmPtr->procPtr->bodyPtr, (Namespace *) oPtr->namespacePtr, "body of method", namePtr); if (result != TCL_OK) { return result; } if (contextPtr->callChain[contextPtr->index].isFilter) { flags |= FRAME_IS_FILTER; } framePtrPtr = &framePtr; result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, oPtr->namespacePtr, flags); if (result != TCL_OK) { return result; } framePtr->ooContextPtr = contextPtr; framePtr->objc = objc; framePtr->objv = objv; /* ref counts for args are incremented below */ framePtr->procPtr = pmPtr->procPtr; if (contextPtr->flags & OO_UNKNOWN_METHOD) { skip--; } result = TclObjInterpProcCore(interp, framePtr, nameObj, skip); if (contextPtr->flags & (CONSTRUCTOR | DESTRUCTOR)) { TclDecrRefCount(nameObj); } return result; } /* * ---------------------------------------------------------------------- * * DeleteProcedureMethod, CloneProcedureMethod -- * * How to delete and clone procedure-like methods. * * ---------------------------------------------------------------------- */ static void DeleteProcedureMethod( ClientData clientData) { register ProcedureMethod *pmPtr = (ProcedureMethod *) clientData; TclProcDeleteProc(pmPtr->procPtr); ckfree((char *) pmPtr); } static int CloneProcedureMethod( ClientData clientData, ClientData *newClientData) { ProcedureMethod *pmPtr = (ProcedureMethod *) clientData; ProcedureMethod *pm2Ptr = (ProcedureMethod *) ckalloc(sizeof(ProcedureMethod)); pm2Ptr->procPtr = pmPtr->procPtr; pm2Ptr->procPtr->refCount++; *newClientData = pm2Ptr; return TCL_OK; } /* * ---------------------------------------------------------------------- * * TclOONewForwardMethod -- * * Create a forwarded method for an object. * * ---------------------------------------------------------------------- */ Method * TclOONewForwardMethod( Tcl_Interp *interp, /* Interpreter for error reporting. */ Object *oPtr, /* The object to attach the method to. */ int flags, /* Whether the method is public or not. */ Tcl_Obj *nameObj, /* The name of the method. */ Tcl_Obj *prefixObj) /* List of arguments that form the command * prefix to forward to. */ { int prefixLen; register ForwardMethod *fmPtr; if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) { return NULL; } if (prefixLen < 1) { Tcl_AppendResult(interp, "method forward prefix must be non-empty", NULL); return NULL; } fmPtr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod)); fmPtr->prefixObj = prefixObj; Tcl_IncrRefCount(prefixObj); return (Method *) Tcl_NewMethod(interp, (Tcl_Object) oPtr, nameObj, flags, &fwdMethodType, fmPtr); } /* * ---------------------------------------------------------------------- * * TclOONewForwardClassMethod -- * * Create a new forwarded method for a class. * * ---------------------------------------------------------------------- */ Method * TclOONewForwardClassMethod( Tcl_Interp *interp, /* Interpreter for error reporting. */ Class *clsPtr, /* The class to attach the method to. */ int flags, /* Whether the method is public or not. */ Tcl_Obj *nameObj, /* The name of the method. */ Tcl_Obj *prefixObj) /* List of arguments that form the command * prefix to forward to. */ { int prefixLen; register ForwardMethod *fmPtr; if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) { return NULL; } if (prefixLen < 1) { Tcl_AppendResult(interp, "method forward prefix must be non-empty", NULL); return NULL; } fmPtr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod)); fmPtr->prefixObj = prefixObj; Tcl_IncrRefCount(prefixObj); return (Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, &fwdMethodType, fmPtr); } /* * ---------------------------------------------------------------------- * * InvokeForwardMethod -- * * How to invoke a forwarded method. Works by doing some ensemble-like * command rearranging and then invokes some other Tcl command. * * ---------------------------------------------------------------------- */ static int InvokeForwardMethod( ClientData clientData, /* Pointer to some per-method context. */ Tcl_Interp *interp, Tcl_ObjectContext context, /* The method calling context. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Arguments as actually seen. */ { CallContext *contextPtr = (CallContext *) context; ForwardMethod *fmPtr = (ForwardMethod *) clientData; Tcl_Obj **argObjs, **prefixObjs; int numPrefixes, result, len; /* * Build the real list of arguments to use. Note that we know that the * prefixObj field of the ForwardMethod structure holds a reference to a * non-empty list, so there's a whole class of failures ("not a list") we * can ignore here. */ TclListObjGetElements(fmPtr->prefixObj, numPrefixes, prefixObjs); argObjs = InitEnsembleRewrite(interp, objc, objv, contextPtr->skip, numPrefixes, prefixObjs, &len); result = Tcl_EvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE); ckfree((char *) argObjs); return result; } /* * ---------------------------------------------------------------------- * * DeleteForwardMethod, CloneForwardMethod -- * * How to delete and clone forwarded methods. * * ---------------------------------------------------------------------- */ static void DeleteForwardMethod( ClientData clientData) { ForwardMethod *fmPtr = (ForwardMethod *) clientData; TclDecrRefCount(fmPtr->prefixObj); ckfree((char *) fmPtr); } static int CloneForwardMethod( ClientData clientData, ClientData *newClientData) { ForwardMethod *fmPtr = (ForwardMethod *) clientData; ForwardMethod *fm2Ptr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod)); fm2Ptr->prefixObj = fmPtr->prefixObj; Tcl_IncrRefCount(fm2Ptr->prefixObj); *newClientData = fm2Ptr; return TCL_OK; } /* * ---------------------------------------------------------------------- * * Tcl_ClassGetMetadata, Tcl_ClassSetMetadata, Tcl_ObjectGetMetadata, * Tcl_ObjectSetMetadata -- * * Metadata management API. The metadata system allows code in extensions * to attach arbitrary non-NULL pointers to objects and classes without * the different things that might be interested being able to interfere * with each other. Apart from non-NULL-ness, these routines attach no * interpretation to the meaning of the metadata pointers. * * The Tcl_*GetMetadata routines get the metadata pointer attached that * has been related with a particular type, or NULL if no metadata * associated with the given type has been attached. * * The Tcl_*SetMetadata routines set or delete the metadata pointer that * is related to a particular type. The value associated with the type is * deleted (if present; no-op otherwise) if the value is NULL, and * attached (replacing the previous value, which is deleted if present) * otherwise. This means it is impossible to attach a NULL value for any * metadata type. * * ---------------------------------------------------------------------- */ ClientData Tcl_ClassGetMetadata( Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr) { Class *clsPtr = (Class *) clazz; Tcl_HashEntry *hPtr; /* * If there's no metadata store attached, the type in question has * definitely not been attached either! */ if (clsPtr->metadataPtr == NULL) { return NULL; } /* * There is a metadata store, so look in it for the given type. */ hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, (char *) typePtr); /* * Return the metadata value if we found it, otherwise NULL. */ if (hPtr == NULL) { return NULL; } else { return Tcl_GetHashValue(hPtr); } } void Tcl_ClassSetMetadata( Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, ClientData metadata) { Class *clsPtr = (Class *) clazz; Tcl_HashEntry *hPtr; int isNew; /* * Attach the metadata store if not done already. */ if (clsPtr->metadataPtr == NULL) { if (metadata == NULL) { return; } clsPtr->metadataPtr = (Tcl_HashTable*) ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(clsPtr->metadataPtr, TCL_ONE_WORD_KEYS); } /* * If the metadata is NULL, we're deleting the metadata for the type. */ if (metadata == NULL) { hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, (char *) typePtr); if (hPtr != NULL) { Tcl_DeleteHashEntry(hPtr); } return; } /* * Otherwise we're attaching the metadata. Note that if there was already * some metadata attached of this type, we delete that first. */ hPtr = Tcl_CreateHashEntry(clsPtr->metadataPtr, (char *) typePtr, &isNew); if (!isNew) { typePtr->deleteProc(Tcl_GetHashValue(hPtr)); } Tcl_SetHashValue(hPtr, metadata); } ClientData Tcl_ObjectGetMetadata( Tcl_Object object, const Tcl_ObjectMetadataType *typePtr) { Object *oPtr = (Object *) object; Tcl_HashEntry *hPtr; /* * If there's no metadata store attached, the type in question has * definitely not been attached either! */ if (oPtr->metadataPtr == NULL) { return NULL; } /* * There is a metadata store, so look in it for the given type. */ hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, (char *) typePtr); /* * Return the metadata value if we found it, otherwise NULL. */ if (hPtr == NULL) { return NULL; } else { return Tcl_GetHashValue(hPtr); } } void Tcl_ObjectSetMetadata( Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, ClientData metadata) { Object *oPtr = (Object *) object; Tcl_HashEntry *hPtr; int isNew; /* * Attach the metadata store if not done already. */ if (oPtr->metadataPtr == NULL) { if (metadata == NULL) { return; } oPtr->metadataPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(oPtr->metadataPtr, TCL_ONE_WORD_KEYS); } /* * If the metadata is NULL, we're deleting the metadata for the type. */ if (metadata == NULL) { hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, (char *) typePtr); if (hPtr != NULL) { Tcl_DeleteHashEntry(hPtr); } return; } /* * Otherwise we're attaching the metadata. Note that if there was already * some metadata attached of this type, we delete that first. */ hPtr = Tcl_CreateHashEntry(oPtr->metadataPtr, (char *) typePtr, &isNew); if (!isNew) { typePtr->deleteProc(Tcl_GetHashValue(hPtr)); } Tcl_SetHashValue(hPtr, metadata); } /* * ---------------------------------------------------------------------- * * PublicObjectCmd, PrivateObjectCmd, ObjectCmd -- * * Main entry point for object invokations. The Public* and Private* * wrapper functions are just thin wrappers round the main ObjectCmd * function that does call chain creation, management and invokation. * * ---------------------------------------------------------------------- */ static int PublicObjectCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { return ObjectCmd(clientData, interp, objc, objv, PUBLIC_METHOD, &((Object *)clientData)->publicContextCache); } static int PrivateObjectCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { return ObjectCmd(clientData, interp, objc, objv, 0, &((Object *)clientData)->privateContextCache); } static int ObjectCmd( Object *oPtr, /* The object being invoked. */ Tcl_Interp *interp, /* The interpreter containing the object. */ int objc, /* How many arguments are being passed in. */ Tcl_Obj *const *objv, /* The array of arguments. */ int flags, /* Whether this is an invokation through the * public or the private command interface. */ Tcl_HashTable *cachePtr) /* What call chain cache to use. */ { Interp *iPtr = (Interp *) interp; CallContext *contextPtr; int result; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "method ?arg ...?"); return TCL_ERROR; } contextPtr = TclOOGetCallContext(iPtr->ooFoundation, oPtr, objv[1], flags | (oPtr->flags & FILTER_HANDLING), cachePtr); if (contextPtr == NULL) { Tcl_AppendResult(interp, "impossible to invoke method \"", TclGetString(objv[1]), "\": no defined method or unknown method", NULL); return TCL_ERROR; } Tcl_Preserve(oPtr); result = TclOOInvokeContext(interp, contextPtr, objc, objv); if (!(contextPtr->flags & OO_UNKNOWN_METHOD) && !(oPtr->flags & OBJECT_DELETED)) { Tcl_HashEntry *hPtr; hPtr = Tcl_FindHashEntry(cachePtr, (char *) objv[1]); if (hPtr != NULL && Tcl_GetHashValue(hPtr) == NULL) { Tcl_SetHashValue(hPtr, contextPtr); } else { TclOODeleteContext(contextPtr); } } else { TclOODeleteContext(contextPtr); } Tcl_Release(oPtr); return result; } /* * ---------------------------------------------------------------------- * * ClassCreate -- * * Implementation for oo::class->create method. * * ---------------------------------------------------------------------- */ static int ClassCreate( ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* Interpreter in which to create the object; * also used for error reporting. */ Tcl_ObjectContext context, /* The object/call context. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* The actual arguments. */ { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); Tcl_Object newObject; const char *objName; int len; /* * Sanity check; should not be possible to invoke this method on a * non-class. */ if (oPtr->classPtr == NULL) { Tcl_Obj *cmdnameObj; TclNewObj(cmdnameObj); Tcl_GetCommandFullName(interp, oPtr->command, cmdnameObj); Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj), "\" is not a class", NULL); TclDecrRefCount(cmdnameObj); return TCL_ERROR; } /* * Check we have the right number of (sensible) arguments. */ if (objc - Tcl_ObjectContextSkippedArgs(context) < 1) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "objectName ?arg ...?"); return TCL_ERROR; } objName = Tcl_GetStringFromObj( objv[Tcl_ObjectContextSkippedArgs(context)], &len); if (len == 0) { Tcl_AppendResult(interp, "object name must not be empty", NULL); return TCL_ERROR; } /* * Make the object and return its name. */ newObject = Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->classPtr, objName, objc, objv, Tcl_ObjectContextSkippedArgs(context)+1); if (newObject == NULL) { return TCL_ERROR; } Tcl_GetCommandFullName(interp, Tcl_GetObjectCommand(newObject), Tcl_GetObjResult(interp)); return TCL_OK; } /* * ---------------------------------------------------------------------- * * ClassNew -- * * Implementation for oo::class->new method. * * ---------------------------------------------------------------------- */ static int ClassNew( ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* Interpreter in which to create the object; * also used for error reporting. */ Tcl_ObjectContext context, /* The object/call context. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* The actual arguments. */ { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); Tcl_Object newObject; /* * Sanity check; should not be possible to invoke this method on a * non-class. */ if (oPtr->classPtr == NULL) { Tcl_Obj *cmdnameObj; TclNewObj(cmdnameObj); Tcl_GetCommandFullName(interp, oPtr->command, cmdnameObj); Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj), "\" is not a class", NULL); TclDecrRefCount(cmdnameObj); return TCL_ERROR; } /* * Make the object and return its name. */ newObject = Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->classPtr, NULL, objc, objv, Tcl_ObjectContextSkippedArgs(context)); if (newObject == NULL) { return TCL_ERROR; } Tcl_GetCommandFullName(interp, Tcl_GetObjectCommand(newObject), Tcl_GetObjResult(interp)); return TCL_OK; } /* * ---------------------------------------------------------------------- * * ObjectDestroy -- * * Implementation for oo::object->destroy method. * * ---------------------------------------------------------------------- */ static int ObjectDestroy( ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* Interpreter in which to create the object; * also used for error reporting. */ Tcl_ObjectContext context, /* The object/call context. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* The actual arguments. */ { if (objc != Tcl_ObjectContextSkippedArgs(context)) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; } Tcl_DeleteCommandFromToken(interp, Tcl_GetObjectCommand(Tcl_ObjectContextObject(context))); return TCL_OK; } /* * ---------------------------------------------------------------------- * * ObjectEval -- * * Implementation for oo::object->eval method. * * ---------------------------------------------------------------------- */ static int ObjectEval( ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* Interpreter in which to create the object; * also used for error reporting. */ Tcl_ObjectContext context, /* The object/call context. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* The actual arguments. */ { CallContext *contextPtr = (CallContext *) context; Tcl_Object object = Tcl_ObjectContextObject(context); CallFrame *framePtr, **framePtrPtr; Tcl_Obj *objnameObj; int result; if (objc-1 < Tcl_ObjectContextSkippedArgs(context)) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "arg ?arg ...?"); return TCL_ERROR; } /* * Make the object's namespace the current namespace and evaluate the * command(s). */ /* This is needed to satisfy GCC 3.3's strict aliasing rules */ framePtrPtr = &framePtr; result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, Tcl_GetObjectNamespace(object), 0); if (result != TCL_OK) { return TCL_ERROR; } framePtr->objc = objc; framePtr->objv = objv; /* Reference counts do not need to be * incremented here. */ if (contextPtr->flags & PUBLIC_METHOD) { TclNewObj(objnameObj); Tcl_GetCommandFullName(interp, Tcl_GetObjectCommand(object), objnameObj); } else { TclNewStringObj(objnameObj, "my", 2); } Tcl_IncrRefCount(objnameObj); if (objc == Tcl_ObjectContextSkippedArgs(context)+1) { result = Tcl_EvalObjEx(interp, objv[Tcl_ObjectContextSkippedArgs(context)], 0); } else { Tcl_Obj *objPtr; /* * More than one argument: concatenate them together with spaces * between, then evaluate the result. Tcl_EvalObjEx will delete the * object when it decrements its refcount after eval'ing it. */ objPtr = Tcl_ConcatObj(objc-Tcl_ObjectContextSkippedArgs(context), objv+Tcl_ObjectContextSkippedArgs(context)); result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); } if (result == TCL_ERROR) { TclFormatToErrorInfo(interp, "\n (in \"%s eval\" script line %d)", TclGetString(objnameObj), interp->errorLine); } /* * Restore the previous "current" namespace. */ TclPopStackFrame(interp); TclDecrRefCount(objnameObj); return result; } /* * ---------------------------------------------------------------------- * * ObjectUnknown -- * * Default unknown method handler method (defined in oo::object). This * just creates a suitable error message. * * ---------------------------------------------------------------------- */ static int ObjectUnknown( ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* Interpreter in which to create the object; * also used for error reporting. */ Tcl_ObjectContext context, /* The object/call context. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* The actual arguments. */ { CallContext *contextPtr = (CallContext *) context; Object *oPtr = contextPtr->oPtr; const char **methodNames; int numMethodNames, i; /* * Get the list of methods that we want to know about. */ numMethodNames = TclOOGetSortedMethodList(oPtr, contextPtr->flags & PUBLIC_METHOD, &methodNames); /* * Special message when there are no visible methods at all. */ if (numMethodNames == 0) { Tcl_Obj *tmpBuf; TclNewObj(tmpBuf); Tcl_GetCommandFullName(interp, oPtr->command, tmpBuf); Tcl_AppendResult(interp, "object \"", TclGetString(tmpBuf), "\" has no visible methods", NULL); TclDecrRefCount(tmpBuf); return TCL_ERROR; } Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[Tcl_ObjectContextSkippedArgs(context)-1]), "\": must be ", NULL); for (i=0 ; i<numMethodNames-1 ; i++) { if (i) { Tcl_AppendResult(interp, ", ", NULL); } Tcl_AppendResult(interp, methodNames[i], NULL); } if (i) { Tcl_AppendResult(interp, " or ", NULL); } Tcl_AppendResult(interp, methodNames[i], NULL); ckfree((char *) methodNames); return TCL_ERROR; } /* * ---------------------------------------------------------------------- * * ObjectLinkVar -- * * Implementation of oo::object->variable method. * * ---------------------------------------------------------------------- */ static int ObjectLinkVar( ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* Interpreter in which to create the object; * also used for error reporting. */ Tcl_ObjectContext context, /* The object/call context. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* The actual arguments. */ { Interp *iPtr = (Interp *) interp; Tcl_Object object = Tcl_ObjectContextObject(context); Namespace *savedNsPtr; int i; if (objc-Tcl_ObjectContextSkippedArgs(context) < 1) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "varName ?varName ...?"); return TCL_ERROR; } /* * Do nothing if we are not called from the body of a method. In this * respect, we are like the [global] command. */ if (iPtr->varFramePtr == NULL || !(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD)) { return TCL_OK; } for (i=Tcl_ObjectContextSkippedArgs(context) ; i<objc ; i++) { Var *varPtr, *aryPtr; Tcl_Obj **argObjs; const char *varName; int len; /* * Parse to see if we have a single value in the argument (just the * name of a variable to use in both the namespace and local scope) or * a two-argument list (namespace variable name and local variable * name). Other cases are an error. */ if (Tcl_ListObjGetElements(interp, objv[i], &len, &argObjs)!=TCL_OK) { return TCL_ERROR; } if (len != 1 && len != 2) { Tcl_AppendResult(interp, "argument must be list " "of one or two variable names", NULL); return TCL_ERROR; } varName = TclGetString(argObjs[len-1]); if (strstr(varName, "::") != NULL) { /* * The local var name must not contain a '::' but the ns name is * OK. Naturally, if they're the same, then the restriction is * applied equally to both. */ Tcl_AppendResult(interp, "variable name \"", varName, "\" illegal: must not contain namespace separator", NULL); return TCL_ERROR; } /* * Switch to the object's namespace for the duration of this call. * Like this, the variable is looked up in the namespace of the * object, and not in the namespace of the caller. Otherwise this * would only work if the caller was a method of the object itself, * which might not be true if the method was exported. This is a bit * of a hack, but the simplest way to do this (pushing a stack frame * would be horribly expensive by comparison). We never have to worry * about the case where we're dealing with the global namespace; we've * already checked that we are inside a method. */ savedNsPtr = iPtr->varFramePtr->nsPtr; iPtr->varFramePtr->nsPtr = (Namespace *) Tcl_GetObjectNamespace(object); varPtr = TclObjLookupVar(interp, argObjs[0], NULL, TCL_NAMESPACE_ONLY, "define", 1, 0, &aryPtr); iPtr->varFramePtr->nsPtr = savedNsPtr; if (varPtr == NULL || aryPtr != NULL) { /* * Variable cannot be an element in an array. If aryPtr is not * NULL, it is an element, so throw up an error and return. */ TclVarErrMsg(interp, TclGetString(argObjs[0]), NULL, "define", "name refers to an element in an array"); return TCL_ERROR; } /* * Arrange for the lifetime of the variable to be correctly managed. * This is copied out of Tcl_VariableObjCmd... */ if (!TclIsVarNamespaceVar(varPtr)) { TclSetVarNamespaceVar(varPtr); varPtr->refCount++; } if (TclPtrMakeUpvar(interp, varPtr, varName, 0, -1) != TCL_OK) { return TCL_ERROR; } } return TCL_OK; } /* * ---------------------------------------------------------------------- * * ObjectVarName -- * * Implementation of the oo::object->varname method. * * ---------------------------------------------------------------------- */ static int ObjectVarName( ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* Interpreter in which to create the object; * also used for error reporting. */ Tcl_ObjectContext context, /* The object/call context. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* The actual arguments. */ { Interp *iPtr = (Interp *) interp; Var *varPtr, *aryVar; Tcl_Obj *varNamePtr; if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "varName"); return TCL_ERROR; } /* * Switch to the object's namespace for the duration of this call. Like * this, the variable is looked up in the namespace of the object, and not * in the namespace of the caller. Otherwise this would only work if the * caller was a method of the object itself, which might not be true if * the method was exported. This is a bit of a hack, but the simplest way * to do this (pushing a stack frame would be horribly expensive by * comparison, and is only done when we'd otherwise interfere with the * global namespace). */ if (iPtr->varFramePtr == NULL) { Tcl_CallFrame *dummyFrame; TclPushStackFrame(interp, &dummyFrame, Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)),0); varPtr = TclObjLookupVar(interp, objv[objc-1], NULL, TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to",1,1,&aryVar); TclPopStackFrame(interp); } else { Namespace *savedNsPtr; savedNsPtr = iPtr->varFramePtr->nsPtr; iPtr->varFramePtr->nsPtr = (Namespace *) Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)); varPtr = TclObjLookupVar(interp, objv[objc-1], NULL, TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to",1,1,&aryVar); iPtr->varFramePtr->nsPtr = savedNsPtr; } if (varPtr == NULL) { return TCL_ERROR; } TclNewObj(varNamePtr); Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr); Tcl_SetObjResult(interp, varNamePtr); return TCL_OK; } /* * ---------------------------------------------------------------------- * * NextObjCmd -- * * Implementation of the [next] command. Note that this command is only * ever to be used inside the body of a procedure-like method. * * ---------------------------------------------------------------------- */ static int NextObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { Interp *iPtr = (Interp *) interp; CallFrame *framePtr = iPtr->varFramePtr, *savedFramePtr; CallContext *contextPtr; int index, result, skip; /* * Start with sanity checks on the calling context and the method context. */ if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { Tcl_AppendResult(interp, TclGetString(objv[0]), " may only be called from inside a method", NULL); return TCL_ERROR; } contextPtr = framePtr->ooContextPtr; index = contextPtr->index; skip = contextPtr->skip; if (index+1 >= contextPtr->numCallChain) { Tcl_AppendResult(interp, "no superclass ", (contextPtr->flags & CONSTRUCTOR ? "constructor" : (contextPtr->flags & DESTRUCTOR ? "destructor" : "method")), " implementation", NULL); return TCL_ERROR; } /* * Advance to the next method implementation in the chain in the method * call context while we process the body. However, need to adjust the * argument-skip control because we're guaranteed to have a single prefix * arg (i.e., 'next') and not the variable amount that can happen because * method invokations (i.e., '$obj meth' and 'my meth'), constructors * (i.e., '$cls new' and '$cls create obj') and destructors (no args at * all) come through the same code. From here on, the skip is always 1. */ contextPtr->index = index+1; contextPtr->skip = 1; /* * Invoke the (advanced) method call context in the caller context. Note * that this is like [uplevel 1] and not [eval]. */ savedFramePtr = iPtr->varFramePtr; iPtr->varFramePtr = savedFramePtr->callerVarPtr; result = TclOOInvokeContext(interp, contextPtr, objc, objv); iPtr->varFramePtr = savedFramePtr; /* * Restore the call chain context index as we've finished the inner invoke * and want to operate in the outer context again. */ contextPtr->index = index; contextPtr->skip = skip; return result; } /* * ---------------------------------------------------------------------- * * SelfObjCmd -- * * Implementation of the [self] command, which provides introspection of * the call context. * * ---------------------------------------------------------------------- */ static int SelfObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { static const char *subcmds[] = { "caller", "class", "filter", "method", "namespace", "next", "object", "target", NULL }; enum SelfCmds { SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS, SELF_NEXT, SELF_OBJECT, SELF_TARGET }; Interp *iPtr = (Interp *) interp; CallFrame *framePtr = iPtr->varFramePtr; CallContext *contextPtr; int index; /* * Start with sanity checks on the calling context and the method context. */ if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { Tcl_AppendResult(interp, TclGetString(objv[0]), " may only be called from inside a method", NULL); return TCL_ERROR; } contextPtr = framePtr->ooContextPtr; /* * Now we do "conventional" argument parsing for a while. Note that no * subcommand takes arguments. */ if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "subcommand"); return TCL_ERROR; } if (objc == 1) { index = SELF_OBJECT; } else if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "subcommand", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum SelfCmds) index) { case SELF_OBJECT: Tcl_GetCommandFullName(interp, contextPtr->oPtr->command, Tcl_GetObjResult(interp)); return TCL_OK; case SELF_NS: Tcl_SetObjResult(interp, Tcl_NewStringObj( contextPtr->oPtr->namespacePtr->fullName,-1)); return TCL_OK; case SELF_CLASS: { Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr; Object *declarerPtr; if (mPtr->declaringClassPtr != NULL) { declarerPtr = mPtr->declaringClassPtr->thisPtr; } else if (mPtr->declaringObjectPtr != NULL) { declarerPtr = mPtr->declaringObjectPtr; } else { /* * This should be unreachable code. */ Tcl_AppendResult(interp, "method without declarer!", NULL); return TCL_ERROR; } Tcl_GetCommandFullName(interp, declarerPtr->command, Tcl_GetObjResult(interp)); return TCL_OK; } case SELF_METHOD: if (contextPtr->flags & CONSTRUCTOR) { Tcl_AppendResult(interp, "<constructor>", NULL); } else if (contextPtr->flags & DESTRUCTOR) { Tcl_AppendResult(interp, "<destructor>", NULL); } else { Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr; Tcl_SetObjResult(interp, mPtr->namePtr); } return TCL_OK; case SELF_FILTER: if (!contextPtr->callChain[contextPtr->index].isFilter) { Tcl_AppendResult(interp, "not inside a filtering context", NULL); return TCL_ERROR; } else { struct MInvoke *miPtr = &contextPtr->callChain[contextPtr->index]; Tcl_Obj *result[3]; Object *oPtr; const char *type; if (miPtr->filterDeclarer != NULL) { oPtr = miPtr->filterDeclarer->thisPtr; type = "class"; } else { oPtr = contextPtr->oPtr; type = "object"; } TclNewObj(result[0]); Tcl_GetCommandFullName(interp, oPtr->command, result[0]); result[1] = Tcl_NewStringObj(type, -1); result[2] = miPtr->mPtr->namePtr; Tcl_SetObjResult(interp, Tcl_NewListObj(3, result)); return TCL_OK; } case SELF_CALLER: if ((framePtr->callerVarPtr != NULL) && (framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)) { CallContext *callerPtr = framePtr->callerVarPtr->ooContextPtr; Method *mPtr = callerPtr->callChain[callerPtr->index].mPtr; Object *declarerPtr; Tcl_Obj *tmpObj; if (mPtr->declaringClassPtr != NULL) { declarerPtr = mPtr->declaringClassPtr->thisPtr; } else if (mPtr->declaringObjectPtr != NULL) { declarerPtr = mPtr->declaringObjectPtr; } else { /* * This should be unreachable code. */ Tcl_AppendResult(interp, "method without declarer!", NULL); return TCL_ERROR; } TclNewObj(tmpObj); Tcl_GetCommandFullName(interp, declarerPtr->command, tmpObj); Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj); TclNewObj(tmpObj); Tcl_GetCommandFullName(interp, callerPtr->oPtr->command, tmpObj); Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj); if (callerPtr->flags & CONSTRUCTOR) { Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), Tcl_NewStringObj("<constructor>", -1)); } else if (callerPtr->flags & DESTRUCTOR) { Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), Tcl_NewStringObj("<destructor>", -1)); } else { Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), mPtr->namePtr); } return TCL_OK; } else { Tcl_AppendResult(interp, "caller is not an object", NULL); return TCL_ERROR; } case SELF_NEXT: if (contextPtr->index < contextPtr->numCallChain-1) { Method *mPtr = contextPtr->callChain[contextPtr->index+1].mPtr; Object *declarerPtr; Tcl_Obj *tmpObj; if (mPtr->declaringClassPtr != NULL) { declarerPtr = mPtr->declaringClassPtr->thisPtr; } else if (mPtr->declaringObjectPtr != NULL) { declarerPtr = mPtr->declaringObjectPtr; } else { /* * This should be unreachable code. */ Tcl_AppendResult(interp, "method without declarer!", NULL); return TCL_ERROR; } TclNewObj(tmpObj); Tcl_GetCommandFullName(interp, declarerPtr->command, tmpObj); Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj); if (contextPtr->flags & CONSTRUCTOR) { Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), Tcl_NewStringObj("<constructor>", -1)); } else if (contextPtr->flags & DESTRUCTOR) { Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), Tcl_NewStringObj("<destructor>", -1)); } else { Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), mPtr->namePtr); } } return TCL_OK; case SELF_TARGET: if (!contextPtr->callChain[contextPtr->index].isFilter) { Tcl_AppendResult(interp, "not inside a filtering context", NULL); return TCL_ERROR; } else { Method *mPtr; Object *declarerPtr; Tcl_Obj *cmdName; int i; for (i=contextPtr->index ; i<contextPtr->numCallChain ; i++) { if (!contextPtr->callChain[i].isFilter) { break; } } if (i == contextPtr->numCallChain) { Tcl_Panic("filtering call chain without terminal non-filter"); } mPtr = contextPtr->callChain[i].mPtr; if (mPtr->declaringClassPtr != NULL) { declarerPtr = mPtr->declaringClassPtr->thisPtr; } else if (mPtr->declaringObjectPtr != NULL) { declarerPtr = mPtr->declaringObjectPtr; } else { /* * This should be unreachable code. */ Tcl_AppendResult(interp, "method without declarer!", NULL); return TCL_ERROR; } TclNewObj(cmdName); Tcl_GetCommandFullName(interp, declarerPtr->command, cmdName); Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), cmdName); Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), mPtr->namePtr); return TCL_OK; } } return TCL_ERROR; } /* * ---------------------------------------------------------------------- * * CopyObjectCmd -- * * Implementation of the [oo::copy] command, which clones an object (but * not its namespace). Note that no constructors are called during this * process. * * ---------------------------------------------------------------------- */ static int CopyObjectCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { Tcl_Object oPtr, o2Ptr; if (objc < 2 || objc > 3) { Tcl_WrongNumArgs(interp, 1, objv, "sourceName ?targetName?"); return TCL_ERROR; } oPtr = Tcl_GetObjectFromObj(interp, objv[1]); if (oPtr == NULL) { return TCL_ERROR; } /* * Create a cloned object of the correct class. Note that constructors are * not called. Also note that we must resolve the object name ourselves * because we do not want to create the object in the current namespace, * but rather in the context of the namespace of the caller of the overall * [oo::define] command. */ if (objc == 2) { o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, NULL); } else { char *name; Tcl_DString buffer; name = TclGetString(objv[2]); Tcl_DStringInit(&buffer); if (name[0]!=':' || name[1]!=':') { Interp *iPtr = (Interp *) interp; if (iPtr->varFramePtr != NULL) { Tcl_DStringAppend(&buffer, iPtr->varFramePtr->nsPtr->fullName, -1); } Tcl_DStringAppend(&buffer, "::", 2); Tcl_DStringAppend(&buffer, name, -1); name = Tcl_DStringValue(&buffer); } o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name); Tcl_DStringFree(&buffer); } if (o2Ptr == NULL) { return TCL_ERROR; } /* * Return the name of the cloned object. */ Tcl_GetCommandFullName(interp, Tcl_GetObjectCommand(o2Ptr), Tcl_GetObjResult(interp)); return TCL_OK; } /* * ---------------------------------------------------------------------- * * Tcl_GetObjectFromObj -- * * Utility function to get an object from a Tcl_Obj containing its name. * * ---------------------------------------------------------------------- */ Tcl_Object Tcl_GetObjectFromObj( Tcl_Interp *interp, Tcl_Obj *objPtr) { Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr); if (cmdPtr == NULL || cmdPtr->objProc != PublicObjectCmd) { Tcl_AppendResult(interp, TclGetString(objPtr), " does not refer to an object", NULL); return NULL; } return cmdPtr->objClientData; } /* * ---------------------------------------------------------------------- * * TclOOIsReachable -- * * Utility function that tests whether a class is a subclass (whether * directly or indirectly) of another class. * * ---------------------------------------------------------------------- */ int TclOOIsReachable( Class *targetPtr, Class *startPtr) { int i; Class *superPtr; tailRecurse: if (startPtr == targetPtr) { return 1; } if (startPtr->superclasses.num == 1) { startPtr = startPtr->superclasses.list[0]; goto tailRecurse; } FOREACH(superPtr, startPtr->superclasses) { if (TclOOIsReachable(targetPtr, superPtr)) { return 1; } } return 0; } /* * ---------------------------------------------------------------------- * * TclOOGetProcFromMethod, TclOOGetFwdFromMethod -- * * Utility functions used for procedure-like and forwarding method * introspection. * * ---------------------------------------------------------------------- */ Proc * TclOOGetProcFromMethod( Method *mPtr) { if (mPtr->typePtr == &procMethodType) { ProcedureMethod *pmPtr = mPtr->clientData; return pmPtr->procPtr; } return NULL; } Tcl_Obj * TclOOGetFwdFromMethod( Method *mPtr) { if (mPtr->typePtr == &fwdMethodType) { ForwardMethod *fwPtr = mPtr->clientData; return fwPtr->prefixObj; } return NULL; } /* * ---------------------------------------------------------------------- * * InitEnsembleRewrite -- * * Utility function that wraps up a lot of the complexity involved in * doing ensemble-like command forwarding. Here is a picture of memory * management plan: * * <-----------------objc----------------------> * objv: |=============|===============================| * <-toRewrite-> | * \ * <-rewriteLength-> \ * rewriteObjs: |=================| \ * | | * V V * argObjs: |=================|===============================| * <------------------*lengthPtr-------------------> * * ---------------------------------------------------------------------- */ static Tcl_Obj ** InitEnsembleRewrite( Tcl_Interp *interp, /* Place to log the rewrite info. */ int objc, /* Number of real arguments. */ Tcl_Obj *const *objv, /* The real arguments. */ int toRewrite, /* Number of real arguments to replace. */ int rewriteLength, /* Number of arguments to insert instead. */ Tcl_Obj *const *rewriteObjs,/* Arguments to insert instead. */ int *lengthPtr) /* Where to write the resulting length of the * array of rewritten arguments. */ { Interp *iPtr = (Interp *) interp; int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); Tcl_Obj **argObjs; unsigned len = rewriteLength + objc - toRewrite; argObjs = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * len); memcpy(argObjs, rewriteObjs, rewriteLength * sizeof(Tcl_Obj *)); memcpy(argObjs + rewriteLength, objv + toRewrite, sizeof(Tcl_Obj *) * (objc - toRewrite)); /* * Now plumb this into the core ensemble rewrite logging system so that * Tcl_WrongNumArgs() can rewrite its result appropriately. The rules for * how to store the rewrite rules get complex solely because of the case * where an ensemble rewrites itself out of the picture; when that * happens, the quality of the error message rewrite falls drastically * (and unavoidably). */ if (isRootEnsemble) { iPtr->ensembleRewrite.sourceObjs = objv; iPtr->ensembleRewrite.numRemovedObjs = toRewrite; iPtr->ensembleRewrite.numInsertedObjs = rewriteLength; } else { int numIns = iPtr->ensembleRewrite.numInsertedObjs; if (numIns < toRewrite) { iPtr->ensembleRewrite.numRemovedObjs += toRewrite - numIns; iPtr->ensembleRewrite.numInsertedObjs += rewriteLength - 1; } else { iPtr->ensembleRewrite.numInsertedObjs += rewriteLength - toRewrite; } } *lengthPtr = len; return argObjs; } /* * ---------------------------------------------------------------------- * * Tcl_ObjectContextMethod, ... -- * * Simple introspector functions. People would read the structures * directly for this sort of information, except that we discourage that * sort of thing as it makes it harder to evolve the internal data * structures. None of these change anything. * * ---------------------------------------------------------------------- */ Tcl_Method Tcl_ObjectContextMethod( Tcl_ObjectContext context) { CallContext *contextPtr = (CallContext *) context; return (Tcl_Method) contextPtr->callChain[contextPtr->index].mPtr; } int Tcl_ObjectContextIsFiltering( Tcl_ObjectContext context) { CallContext *contextPtr = (CallContext *) context; return contextPtr->callChain[contextPtr->index].isFilter; } Tcl_Object Tcl_ObjectContextObject( Tcl_ObjectContext context) { return (Tcl_Object) ((CallContext *)context)->oPtr; } int Tcl_ObjectContextSkippedArgs( Tcl_ObjectContext context) { return ((CallContext *)context)->skip; } Tcl_Object Tcl_MethodDeclarerObject( Tcl_Method method) { return (Tcl_Object) ((Method *) method)->declaringObjectPtr; } Tcl_Class Tcl_MethodDeclarerClass( Tcl_Method method) { return (Tcl_Class) ((Method *) method)->declaringClassPtr; } Tcl_Obj * Tcl_MethodName( Tcl_Method method) { return ((Method *) method)->namePtr; } int Tcl_MethodIsType( Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *clientDataPtr) { Method *mPtr = (Method *) method; if (mPtr->typePtr == typePtr) { if (clientDataPtr != NULL) { *clientDataPtr = mPtr->clientData; } return 1; } return 0; } int Tcl_MethodIsPublic( Tcl_Method method) { return (((Method *)method)->flags & PUBLIC_METHOD) ? 1 : 0; } Tcl_Namespace * Tcl_GetObjectNamespace( Tcl_Object object) { return ((Object *)object)->namespacePtr; } Tcl_Command Tcl_GetObjectCommand( Tcl_Object object) { return ((Object *)object)->command; } Tcl_Class Tcl_GetObjectAsClass( Tcl_Object object) { return (Tcl_Class) ((Object *)object)->classPtr; } int Tcl_ObjectDeleted( Tcl_Object object) { return (((Object *)object)->flags & OBJECT_DELETED) ? 1 : 0; } Tcl_Object Tcl_GetClassAsObject( Tcl_Class clazz) { return (Tcl_Object) ((Class *)clazz)->thisPtr; } /* * ---------------------------------------------------------------------- * * Tcl_OOGetObjectClass, Tcl_OOGetClassClass -- * * Get the basic ::oo::object and ::oo::class classes. * * ---------------------------------------------------------------------- */ Tcl_Class Tcl_GetClassOfObjects( Tcl_Interp *interp) { Foundation *fPtr = ((Interp *) interp)->ooFoundation; return (Tcl_Class) fPtr->objectCls; } Tcl_Class Tcl_GetClassOfClasses( Tcl_Interp *interp) { Foundation *fPtr = ((Interp *) interp)->ooFoundation; return (Tcl_Class) fPtr->classCls; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Added generic/tclOO.h.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 | /* * tclOO.h -- * * This file contains the structure definitions and some of the function * declarations for the object-system (NB: not Tcl_Obj, but ::oo). * * Copyright (c) 2006 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclOO.h,v 1.1.2.41 2006/10/31 09:20:33 dkf Exp $ */ // vvvvvvvvvvvvvvvvvvvvvv MOVE TO TCL.DECLS vvvvvvvvvvvvvvvvvvvvvv Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, Tcl_Object sourceObject, const char *targetName); Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz); Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object); Tcl_Command Tcl_GetObjectCommand(Tcl_Object object); Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object); Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method); Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method); int Tcl_MethodIsPublic(Tcl_Method method); int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *clientDataPtr); Tcl_Obj * Tcl_MethodName(Tcl_Method method); Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); Tcl_Method Tcl_NewClassMethod(Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *name, int objc, Tcl_Obj *const *objv, int skip); int Tcl_ObjectDeleted(Tcl_Object object); int Tcl_ObjectContextIsFiltering( Tcl_ObjectContext context); Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context); Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); int Tcl_ObjectContextSkippedArgs( Tcl_ObjectContext context); ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); void Tcl_ClassSetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); ClientData Tcl_ObjectGetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); void Tcl_ObjectSetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); Tcl_Class Tcl_GetClassOfClasses(Tcl_Interp *interp); Tcl_Class Tcl_GetClassOfObjects(Tcl_Interp *interp); // ^^^^^^^^^^^^^^^^^^^^^^ MOVE TO TCL.DECLS ^^^^^^^^^^^^^^^^^^^^^^ /* * Forward declarations. */ struct Class; struct Object; /* * The data that needs to be stored per method. This record is used to collect * information about all sorts of methods, including forwards, constructors * and destructors. */ typedef struct Method { const Tcl_MethodType *typePtr; /* The type of method. If NULL, this is a * special flag record which is just used for * the setting of the flags field. */ ClientData clientData; /* Type-specific data. */ Tcl_Obj *namePtr; /* Name of the method. */ struct Object *declaringObjectPtr; /* The object that declares this method, or * NULL if it was declared by a class. */ struct Class *declaringClassPtr; /* The class that declares this method, or * NULL if it was declared directly on an * object. */ int flags; /* Assorted flags. Includes whether this * method is public/exported or not. */ } Method; /* * Procedure-like methods have the following extra information. It is a * single-field structure because this allows for future expansion without * changing vast amounts of code. */ typedef struct ProcedureMethod { Proc *procPtr; } ProcedureMethod; /* * Forwarded methods have the following extra information. It is a * single-field structure because this allows for future expansion without * changing vast amounts of code. */ typedef struct ForwardMethod { Tcl_Obj *prefixObj; } ForwardMethod; /* * Helper definitions that declare a "list" array. The two varieties are * either optimized for simplicity (in the case that the whole array is * typically assigned at once) or efficiency (in the case that the array is * expected to be expanded over time). These lists are designed to be iterated * over with the help of the FOREACH macro (see later in this file). * * The "num" field always counts the number of listType_t elements used in the * "list" field. When a "size" field exists, it describes how many elements * are present in the list; when absent, exactly "num" elements are present. */ #define LIST_STATIC(listType_t) \ struct { int num; listType_t *list; } #define LIST_DYNAMIC(listType_t) \ struct { int num, size; listType_t *list; } /* * Now, the definition of what an object actually is. */ typedef struct Object { Tcl_Namespace *namespacePtr;/* This object's tame namespace. */ Tcl_Command command; /* Reference to this object's public * command. */ Tcl_Command myCommand; /* Reference to this object's internal * command. */ struct Class *selfCls; /* This object's class. */ Tcl_HashTable methods; /* Object-local Tcl_Obj (method name) to * Method* mapping. */ LIST_STATIC(struct Class *) mixins; /* Classes mixed into this object. */ LIST_STATIC(Tcl_Obj *) filters; /* List of filter names. */ struct Class *classPtr; /* All classes have this non-NULL; it points * to the class structure. Everything else has * this NULL. */ int flags; int epoch; /* Per-object epoch, incremented when the way * an object should resolve call chains is * changed. */ Tcl_HashTable *metadataPtr; /* Mapping from pointers to metadata type to * the ClientData values that are the values * of each piece of attached metadata. This * field starts out as NULL and is only * allocated if metadata is attached. */ Tcl_HashTable publicContextCache; /* Place to keep unused contexts. */ Tcl_HashTable privateContextCache; /* Place to keep unused contexts. */ } Object; #define OBJECT_DELETED 1 /* Flag to say that an object has been * destroyed. */ #define ROOT_OBJECT 0x1000 /* Flag to say that this object is the root of * the class hierarchy and should be treated * specially during teardown. */ #define FILTER_HANDLING 0x2000 /* Flag set when the object is processing a * filter; when set, filters are *not* * processed on the object, preventing nasty * recursive filtering problems. */ /* * And the definition of a class. Note that every class also has an associated * object, through which it is manipulated. */ typedef struct Class { Object *thisPtr; /* Reference to the object associated with * this class. */ int flags; /* Assorted flags. */ LIST_STATIC(struct Class *) superclasses; /* List of superclasses, used for generation * of method call chains. */ LIST_DYNAMIC(struct Class *) subclasses; /* List of subclasses, used to ensure deletion * of dependent entities happens properly when * the class itself is deleted. */ LIST_DYNAMIC(Object *) instances; /* List of instances, used to ensure deletion * of dependent entities happens properly when * the class itself is deleted. */ LIST_STATIC(Tcl_Obj *) filters; /* List of filter names, used for generation * of method call chains. */ LIST_STATIC(struct Class *) mixins; /* List of mixin classes, used for generation * of method call chains. */ LIST_DYNAMIC(struct Class *) mixinSubs; /* List of classes that this class is mixed * into, used to ensure deletion of dependent * entities happens properly when the class * itself is deleted. */ LIST_STATIC(struct Class *) classHierarchy; /* List of classes that comprise the basic * class hierarchy for this class's * superclasses. If NULL (and this isn't the * root object class) then this needs * recomputing. */ int classHierarchyEpoch; /* Differs from the global epoch when it is * time to recompute the class hierarchy. */ Tcl_HashTable classMethods; /* Hash table of all methods. Hash maps from * the (Tcl_Obj*) method name to the (Method*) * method record. */ Method *constructorPtr; /* Method record of the class constructor (if * any). */ Method *destructorPtr; /* Method record of the class destructor (if * any). */ Tcl_HashTable *metadataPtr; /* Mapping from pointers to metadata type to * the ClientData values that are the values * of each piece of attached metadata. This * field starts out as NULL and is only * allocated if metadata is attached. */ } Class; /* * The foundation of the object system within an interpreter contains * references to the key classes and namespaces, together with a few other * useful bits and pieces. Probably ought to eventually go in the Interp * structure itself. */ typedef struct Foundation { Class *objectCls; /* The root of the object system. */ Class *classCls; /* The class of all classes. */ Tcl_Namespace *ooNs; /* Master ::oo namespace. */ Tcl_Namespace *defineNs; /* Namespace containing special commands for * manipulating objects and classes. The * "oo::define" command acts as a special kind * of ensemble for this namespace. */ Tcl_Namespace *helpersNs; /* Namespace containing the commands that are * only valid when executing inside a * procedural method. */ int epoch; /* Used to invalidate method chains when the * class structure changes. */ int nsCount; /* Counter so we can allocate a unique * namespace to each object. */ Tcl_Obj *unknownMethodNameObj; /* Shared object containing the name of the * unknown method handler method. */ } Foundation; /* * A call context structure is built when a method is called. They contain the * chain of method implementations that are to be invoked by a particular * call, and the process of calling walks the chain, with the [next] command * proceeding to the next entry in the chain. */ #define CALL_CHAIN_STATIC_SIZE 4 struct MInvoke { Method *mPtr; /* Reference to the method implementation * record. */ int isFilter; /* Whether this is a filter invokation. */ Class *filterDeclarer; /* What class decided to add the filter; if * NULL, it was added by the object. */ }; typedef struct CallContext { Object *oPtr; /* The object associated with this call. */ int globalEpoch; /* Global (class) epoch counter snapshot. */ int localEpoch; /* Local (single object) epoch counter * snapshot. */ int flags; /* Assorted flags, see below. */ int index; /* Index into the call chain of the currently * executing method implementation. */ int skip; int numCallChain; /* Size of the call chain. */ struct MInvoke *callChain; /* Array of call chain entries. May point to * staticCallChain if the number of entries is * small. */ struct MInvoke staticCallChain[CALL_CHAIN_STATIC_SIZE]; } CallContext; /* * Bits for the 'flags' field of the call context. */ #define PUBLIC_METHOD 0x01 /* This is a public (exported) method. */ #define PRIVATE_METHOD 0x02 /* This is a private (class's direct instances * only) method. */ #define OO_UNKNOWN_METHOD 0x04 /* This is an unknown method. */ #define CONSTRUCTOR 0x08 /* This is a constructor. */ #define DESTRUCTOR 0x10 /* This is a destructor. */ /* * Private definitions, some of which perhaps ought to be exposed properly or * maybe just put in the internal stubs table. */ MODULE_SCOPE Method * TclOONewProcMethod(Tcl_Interp *interp, Object *oPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj); MODULE_SCOPE Method * TclOONewForwardMethod(Tcl_Interp *interp, Object *oPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); MODULE_SCOPE Method * TclOONewProcClassMethod(Tcl_Interp *interp, Class *clsPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj); MODULE_SCOPE Method * TclOONewForwardClassMethod(Tcl_Interp *interp, Class *clsPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); MODULE_SCOPE void TclOODeleteMethod(Method *method); MODULE_SCOPE void TclOOInitInfo(Tcl_Interp *interp); MODULE_SCOPE int TclObjInterpProcCore(register Tcl_Interp *interp, CallFrame *framePtr, Tcl_Obj *procNameObj, int skip); MODULE_SCOPE void TclOOAddToInstances(Object *oPtr, Class *clsPtr); MODULE_SCOPE void TclOOAddToSubclasses(Class *subPtr, Class *superPtr); MODULE_SCOPE void TclOOAddToMixinSubs(Class *subPtr, Class *mixinPtr); MODULE_SCOPE Proc * TclOOGetProcFromMethod(Method *mPtr); MODULE_SCOPE Tcl_Obj * TclOOGetFwdFromMethod(Method *mPtr); MODULE_SCOPE int TclOOIsReachable(Class *targetPtr, Class *startPtr); MODULE_SCOPE void TclOORemoveFromInstances(Object *oPtr, Class *clsPtr); MODULE_SCOPE void TclOORemoveFromSubclasses(Class *subPtr, Class *superPtr); MODULE_SCOPE void TclOORemoveFromMixinSubs(Class *subPtr, Class *mixinPtr); MODULE_SCOPE void TclOODeleteContext(CallContext *contextPtr); MODULE_SCOPE CallContext *TclOOGetCallContext(Foundation *fPtr, Object *oPtr, Tcl_Obj *methodNameObj, int flags, Tcl_HashTable *cachePtr); MODULE_SCOPE int TclOOInvokeContext(Tcl_Interp *interp, CallContext *contextPtr, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOOGetSortedMethodList(Object *oPtr, int flags, const char ***stringsPtr); /* * A convenience macro for iterating through the lists used in the internal * memory management of objects. This is a bit gnarly because we want to do * the assignment of the picked-out value only when the body test succeeds, * but we cannot rely on the assigned value being useful, forcing us to do * some nasty stuff with the comma operator. The compiler's optimizer should * be able to sort it all out! * * REQUIRES DECLARATION: int i; */ #define FOREACH(var,ary) \ for(i=0 ; (i<(ary).num?((var=(ary).list[i]),1):0) ; i++) /* * Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS * sets up the declarations needed for the main macro, FOREACH_HASH, which * does the actual iteration. FOREACH_HASH_VALUE is a restricted version that * only iterates over values. */ #define FOREACH_HASH_DECLS \ Tcl_HashEntry *hPtr;Tcl_HashSearch search #define FOREACH_HASH(key,val,tablePtr) \ for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \ ((key)=(void *)Tcl_GetHashKey((tablePtr),hPtr),\ (val)=Tcl_GetHashValue(hPtr),1):0; hPtr=Tcl_NextHashEntry(&search)) #define FOREACH_HASH_VALUE(val,tablePtr) \ for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \ ((val)=Tcl_GetHashValue(hPtr),1):0;hPtr=Tcl_NextHashEntry(&search)) /* * Convenience macro for duplicating a list. Needs no external declaration, * but all arguments are used multiple times and so must have no side effects. */ #define DUPLICATE(target,source,type) \ do { \ register unsigned len = sizeof(type) * ((target).num=(source).num);\ if (len != 0) { \ memcpy(((target).list=(type*)ckalloc(len)), (source).list, len); \ } else { \ (target).list = NULL; \ } \ } while(0) /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Added generic/tclOOCall.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 | /* * tclOO.c -- * * This file contains the method call chain management code for the * object-system core. * * Copyright (c) 2005-2006 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclOOCall.c,v 1.1.2.5 2006/10/22 23:01:37 dkf Exp $ */ #include "tclInt.h" #include "tclOO.h" /* * Structure containing a CallContext and any other values needed only during * the construction of the CallContext. */ struct ChainBuilder { CallContext *contextPtr; /* The call context being built. */ int filterLength; /* Number of entries in the call chain that * are due to processing filters and not the * main call chain. */ }; /* * Extra flags used for call chain management. */ #define DEFINITE_PROTECTED 0x100000 #define DEFINITE_PUBLIC 0x200000 #define KNOWN_STATE (DEFINITE_PROTECTED | DEFINITE_PUBLIC) #define SPECIAL (CONSTRUCTOR | DESTRUCTOR) /* * Function declarations for things defined in this file. */ static void AddClassFiltersToCallContext(Object *oPtr, Class *clsPtr, struct ChainBuilder *cbPtr, Tcl_HashTable *doneFilters); static void AddClassMethodNames(Class *clsPtr, int flags, Tcl_HashTable *namesPtr); static void AddMethodToCallChain(Method *mPtr, struct ChainBuilder *cbPtr, Tcl_HashTable *doneFilters, Class *filterDecl); static void AddSimpleChainToCallContext(Object *oPtr, Tcl_Obj *methodNameObj, struct ChainBuilder *cbPtr, Tcl_HashTable *doneFilters, int isPublic, Class *filterDecl); static void AddSimpleClassChainToCallContext(Class *classPtr, Tcl_Obj *methodNameObj, struct ChainBuilder *cbPtr, Tcl_HashTable *doneFilters, int isPublic, Class *filterDecl); static int CmpStr(const void *ptr1, const void *ptr2); static void InitClassHierarchy(Foundation *fPtr, Class *classPtr); /* * ---------------------------------------------------------------------- * * TclOODeleteContext -- * * Destroys a method call-chain context, which should not be in use. * * ---------------------------------------------------------------------- */ void TclOODeleteContext( CallContext *contextPtr) { if (contextPtr->callChain != contextPtr->staticCallChain) { ckfree((char *) contextPtr->callChain); } ckfree((char *) contextPtr); } /* * ---------------------------------------------------------------------- * * TclOOInvokeContext -- * * Invokes a single step along a method call-chain context. Note that the * invokation of a step along the chain can cause further steps along the * chain to be invoked. Note that this function is written to be as light * in stack usage as possible. * * ---------------------------------------------------------------------- */ int TclOOInvokeContext( Tcl_Interp *interp, /* Interpreter for error reporting, and many * other sorts of context handling (e.g., * commands, variables) depending on method * implementation. */ CallContext *contextPtr, /* The method call context. */ int objc, /* The number of arguments. */ Tcl_Obj *const *objv) /* The arguments as actually seen. */ { Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr; int result, isFirst = (contextPtr->index == 0); int isFilter = contextPtr->callChain[contextPtr->index].isFilter; int wasFilter; /* * If this is the first step along the chain, we preserve the method * entries in the chain so that they do not get deleted out from under our * feet. */ if (isFirst) { int i; for (i=0 ; i<contextPtr->numCallChain ; i++) { Tcl_Preserve(contextPtr->callChain[i].mPtr); } } /* * Save whether we were in a filter and set up whether we are now. */ wasFilter = contextPtr->oPtr->flags & FILTER_HANDLING; if (isFilter || contextPtr->flags & FILTER_HANDLING) { contextPtr->oPtr->flags |= FILTER_HANDLING; } else { contextPtr->oPtr->flags &= ~FILTER_HANDLING; } /* * Run the method implementation. */ result = mPtr->typePtr->callProc(mPtr->clientData, interp, (Tcl_ObjectContext) contextPtr, objc, objv); /* * Restore the old filter-ness, release any locks on method * implementations, and return the result code. */ if (wasFilter) { contextPtr->oPtr->flags |= FILTER_HANDLING; } else { contextPtr->oPtr->flags &= ~FILTER_HANDLING; } if (isFirst) { int i; for (i=0 ; i<contextPtr->numCallChain ; i++) { Tcl_Release(contextPtr->callChain[i].mPtr); } } return result; } /* * ---------------------------------------------------------------------- * * InitClassHierarchy -- * * Builds the basic class hierarchy cache. This does not include mixins. * * ---------------------------------------------------------------------- */ static void InitClassHierarchy( Foundation *fPtr, Class *classPtr) { if (classPtr == fPtr->objectCls) { return; } if (classPtr->classHierarchyEpoch != fPtr->epoch) { int i; Class *superPtr; if (classPtr->classHierarchy.num != 0) { ckfree((char *) classPtr->classHierarchy.list); } FOREACH(superPtr, classPtr->superclasses) { InitClassHierarchy(fPtr, superPtr); } if (i == 1) { Class **hierlist = (Class **) ckalloc(sizeof(Class*) * (1+superPtr->classHierarchy.num)); hierlist[0] = superPtr; memcpy(hierlist+1, superPtr->classHierarchy.list, sizeof(Class*) * superPtr->classHierarchy.num); classPtr->classHierarchy.num = 1 + superPtr->classHierarchy.num; classPtr->classHierarchy.list = hierlist; classPtr->classHierarchyEpoch = fPtr->epoch; return; } else { int num = classPtr->superclasses.num, j = 0, k, realNum; Class **hierlist; /* Temporary work space. */ FOREACH(superPtr, classPtr->superclasses) { num += superPtr->classHierarchy.num; } hierlist = (Class **) ckalloc(sizeof(Class *) * num); FOREACH(superPtr, classPtr->superclasses) { hierlist[j++] = superPtr; if (superPtr == fPtr->objectCls) { continue; } memcpy(hierlist+j, superPtr->classHierarchy.list, sizeof(Class *) * superPtr->classHierarchy.num); j += superPtr->classHierarchy.num; } realNum = num; for (j=0 ; j<num-1 ; j++) { for (k=num-1 ; k>j ; k--) { if (hierlist[j] == hierlist[k]) { hierlist[j] = NULL; realNum--; break; } } } classPtr->classHierarchy.num = realNum; classPtr->classHierarchy.list = (Class **) ckalloc(sizeof(Class *) * realNum); for (j=k=0 ; j<num ; j++) { if (hierlist[j] != NULL) { classPtr->classHierarchy.list[k++] = hierlist[j]; } } ckfree((char *) hierlist); } } } /* * ---------------------------------------------------------------------- * * TclOOGetSortedMethodList -- * * Discovers the list of method names supported by an object. * * ---------------------------------------------------------------------- */ int TclOOGetSortedMethodList( Object *oPtr, /* The object to get the method names for. */ int flags, /* Whether we just want the public method * names. */ const char ***stringsPtr) /* Where to write a pointer to the array of * strings to. */ { Tcl_HashTable names; /* Tcl_Obj* method name to "wanted in list" * mapping. */ FOREACH_HASH_DECLS; int i; Class *mixinPtr; Tcl_Obj *namePtr; Method *mPtr; void *isWanted; Tcl_InitObjHashTable(&names); /* * Process method names due to the object. */ FOREACH_HASH(namePtr, mPtr, &oPtr->methods) { int isNew; if ((mPtr->flags & PRIVATE_METHOD) && !(flags & PRIVATE_METHOD)) { continue; } hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew); if (isNew) { isWanted = (void *) (!(flags & PUBLIC_METHOD) || mPtr->flags & PUBLIC_METHOD); Tcl_SetHashValue(hPtr, isWanted); } } /* * Process method names due to private methods on the object's class. */ if (flags & PRIVATE_METHOD) { FOREACH_HASH(namePtr, mPtr, &oPtr->selfCls->classMethods) { if (mPtr->flags & PRIVATE_METHOD) { int isNew; hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew); if (isNew) { isWanted = (void *) 1; Tcl_SetHashValue(hPtr, isWanted); } } } } /* * Process (normal) method names from the class hierarchy and the mixin * hierarchy. */ AddClassMethodNames(oPtr->selfCls, flags, &names); FOREACH(mixinPtr, oPtr->mixins) { AddClassMethodNames(mixinPtr, flags, &names); } /* * See how many (visible) method names there are. If none, we do not (and * should not) try to sort the list of them. */ i = 0; if (names.numEntries != 0) { const char **strings; /* * We need to build the list of methods to sort. We will be using * qsort() for this, because it is very unlikely that the list will be * heavily sorted when it is long enough to matter. */ strings = (const char **) ckalloc(sizeof(char *) * names.numEntries); FOREACH_HASH(namePtr, isWanted, &names) { if (!(flags & PUBLIC_METHOD) || isWanted) { strings[i++] = TclGetString(namePtr); } } /* * Note that 'i' may well be less than names.numEntries when we are * dealing with public method names. */ qsort(strings, (unsigned) i, sizeof(char *), CmpStr); *stringsPtr = strings; } Tcl_DeleteHashTable(&names); return i; } /* Comparator for GetSortedMethodList */ static int CmpStr( const void *ptr1, const void *ptr2) { const char **strPtr1 = (const char **) ptr1; const char **strPtr2 = (const char **) ptr2; return TclpUtfNcmp2(*strPtr1, *strPtr2, strlen(*strPtr1)+1); } /* * ---------------------------------------------------------------------- * * AddClassMethodNames -- * * Adds the method names defined by a class (or its superclasses) to the * collection being built. The collection is built in a hash table to * ensure that duplicates are excluded. Helper for GetSortedMethodList(). * * ---------------------------------------------------------------------- */ static void AddClassMethodNames( Class *clsPtr, /* Class to get method names from. */ const int flags, /* Whether we are interested in just the * public method names. */ Tcl_HashTable *const namesPtr) /* Reference to the hash table to put the * information in. The hash table maps the * Tcl_Obj * method name to an integral value * describing whether the method is wanted. * This ensures that public/private override * semantics are handled correctly.*/ { /* * Scope all declarations so that the compiler can stand a good chance of * making the recursive step highly efficient. We also hand-implement the * tail-recursive case using a while loop; C compilers typically cannot do * tail-recursion optimization usefully. */ if (clsPtr->mixins.num != 0) { Class *mixinPtr; int i; /* TODO: Beware of infinite loops! */ FOREACH(mixinPtr, clsPtr->mixins) { AddClassMethodNames(mixinPtr, flags, namesPtr); } } while (1) { FOREACH_HASH_DECLS; Tcl_Obj *namePtr; Method *mPtr; FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) { int isNew; hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew); if (isNew) { int isWanted = (!(flags & PUBLIC_METHOD) || (mPtr->flags & PUBLIC_METHOD)); Tcl_SetHashValue(hPtr, (void *) isWanted); } } if (clsPtr->superclasses.num != 1) { break; } clsPtr = clsPtr->superclasses.list[0]; } if (clsPtr->superclasses.num != 0) { Class *superPtr; int i; FOREACH(superPtr, clsPtr->superclasses) { AddClassMethodNames(superPtr, flags, namesPtr); } } } /* * ---------------------------------------------------------------------- * * TclOOGetCallContext -- * * Responsible for constructing the call context, an ordered list of all * method implementations to be called as part of a method invokation. * This method is central to the whole operation of the OO system. * * ---------------------------------------------------------------------- */ CallContext * TclOOGetCallContext( Foundation *fPtr, /* The foundation of the object system. */ Object *oPtr, /* The object to get the context for. */ Tcl_Obj *methodNameObj, /* The name of the method to get the context * for. NULL when getting a constructor or * destructor chain. */ int flags, /* What sort of context are we looking for. * Only the bits PUBLIC_METHOD, CONSTRUCTOR, * PRIVATE_METHOD, DESTRUCTOR and * FILTER_HANDLING are useful. */ Tcl_HashTable *cachePtr) /* Where to cache the chain. Ignored for both * constructors and destructors. */ { struct ChainBuilder cb; int i, count, doFilters; Tcl_HashEntry *hPtr; Tcl_HashTable doneFilters; if (flags&(SPECIAL|FILTER_HANDLING) || (oPtr->flags&FILTER_HANDLING)) { hPtr = NULL; doFilters = 0; } else { doFilters = 1; hPtr = Tcl_FindHashEntry(cachePtr, (char *) methodNameObj); if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) { cb.contextPtr = Tcl_GetHashValue(hPtr); Tcl_SetHashValue(hPtr, NULL); if ((cb.contextPtr->globalEpoch == fPtr->epoch) && (cb.contextPtr->localEpoch == oPtr->epoch)) { return cb.contextPtr; } TclOODeleteContext(cb.contextPtr); } } cb.contextPtr = (CallContext *) ckalloc(sizeof(CallContext)); cb.contextPtr->numCallChain = 0; cb.contextPtr->callChain = cb.contextPtr->staticCallChain; cb.filterLength = 0; cb.contextPtr->globalEpoch = fPtr->epoch; cb.contextPtr->localEpoch = oPtr->epoch; cb.contextPtr->flags = 0; cb.contextPtr->skip = 2; if (flags & (PUBLIC_METHOD|PRIVATE_METHOD|SPECIAL|FILTER_HANDLING)) { cb.contextPtr->flags |= flags&(PUBLIC_METHOD|PRIVATE_METHOD|SPECIAL|FILTER_HANDLING); } cb.contextPtr->oPtr = oPtr; cb.contextPtr->index = 0; /* * Ensure that the class hierarchy is trivially iterable. */ InitClassHierarchy(fPtr, oPtr->selfCls); /* * Add all defined filters (if any, and if we're going to be processing * them; they're not processed for constructors, destructors or when we're * in the middle of processing a filter). */ if (doFilters) { Tcl_Obj *filterObj; Class *mixinPtr; doFilters = 1; Tcl_InitObjHashTable(&doneFilters); FOREACH(mixinPtr, oPtr->mixins) { AddClassFiltersToCallContext(oPtr, mixinPtr, &cb, &doneFilters); } FOREACH(filterObj, oPtr->filters) { AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters, 0, NULL); } AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters); Tcl_DeleteHashTable(&doneFilters); } count = cb.filterLength = cb.contextPtr->numCallChain; /* * Add the actual method implementations. */ AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, flags, NULL); /* * Check to see if the method has no implementation. If so, we probably * need to add in a call to the unknown method. Otherwise, set up the * cacheing of the method implementation (if relevant). */ if (count == cb.contextPtr->numCallChain) { /* * Method does not actually exist. If we're dealing with constructors * or destructors, this isn't a problem. */ if (flags & SPECIAL) { TclOODeleteContext(cb.contextPtr); return NULL; } AddSimpleChainToCallContext(oPtr, fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); cb.contextPtr->flags |= OO_UNKNOWN_METHOD; cb.contextPtr->globalEpoch = -1; if (count == cb.contextPtr->numCallChain) { TclOODeleteContext(cb.contextPtr); return NULL; } } else if (doFilters) { if (hPtr == NULL) { hPtr = Tcl_CreateHashEntry(cachePtr, (char *) methodNameObj, &i); } Tcl_SetHashValue(hPtr, NULL); } return cb.contextPtr; } /* * ---------------------------------------------------------------------- * * AddClassFiltersToCallContext -- * * Logic to make extracting all the filters from the class context much * easier. * * ---------------------------------------------------------------------- */ static void AddClassFiltersToCallContext( Object *const oPtr, /* Object that the filters operate on. */ Class *clsPtr, /* Class to get the filters from. */ struct ChainBuilder *const cbPtr, /* Context to fill with call chain entries. */ Tcl_HashTable *const doneFilters) /* Where to record what filters have been * processed. Keys are objects, values are * ignored. */ { int i; Class *superPtr; Tcl_Obj *filterObj; tailRecurse: if (clsPtr == NULL) { return; } /* * Add all the class filters from the current class. Note that the filters * are added starting at the object root, as this allows the object to * override how filters work to extend their behaviour. */ FOREACH(filterObj, clsPtr->filters) { int isNew; (void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj, &isNew); if (isNew) { AddSimpleChainToCallContext(oPtr, filterObj, cbPtr, doneFilters, 0, clsPtr); } } /* * Now process the recursive case. Notice the tail-call optimization. */ switch (clsPtr->superclasses.num) { case 1: clsPtr = clsPtr->superclasses.list[0]; goto tailRecurse; default: FOREACH(superPtr, clsPtr->superclasses) { AddClassFiltersToCallContext(oPtr, superPtr, cbPtr, doneFilters); } case 0: return; } } /* * ---------------------------------------------------------------------- * * AddSimpleChainToCallContext -- * * The core of the call-chain construction engine, this handles calling a * particular method on a particular object. Note that filters and * unknown handling are already handled by the logic that uses this * function. * * ---------------------------------------------------------------------- */ static void AddSimpleChainToCallContext( Object *oPtr, /* Object to add call chain entries for. */ Tcl_Obj *methodNameObj, /* Name of method to add the call chain * entries for. */ struct ChainBuilder *cbPtr, /* Where to add the call chain entries. */ Tcl_HashTable *doneFilters, /* Where to record what call chain entries * have been processed. */ int flags, /* What sort of call chain are we building. */ Class *filterDecl) /* The class that declared the filter. If * NULL, either the filter was declared by the * object or this isn't a filter. */ { int i; if (!(flags & (KNOWN_STATE | SPECIAL))) { Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&oPtr->methods, (char *) methodNameObj); if (hPtr != NULL) { Method *mPtr = Tcl_GetHashValue(hPtr); if (flags & PUBLIC_METHOD) { if (!(mPtr->flags & PUBLIC_METHOD)) { return; } else { flags |= DEFINITE_PUBLIC; } } else { flags |= DEFINITE_PROTECTED; } } } if (!(flags & SPECIAL)) { Tcl_HashEntry *hPtr; Class *mixinPtr, *superPtr; FOREACH(mixinPtr, oPtr->mixins) { AddSimpleClassChainToCallContext(mixinPtr, methodNameObj, cbPtr, doneFilters, flags, filterDecl); } FOREACH(mixinPtr, oPtr->selfCls->mixins) { AddSimpleClassChainToCallContext(mixinPtr, methodNameObj, cbPtr, doneFilters, flags, filterDecl); } FOREACH(superPtr, oPtr->selfCls->classHierarchy) { int j=i; /* HACK: save index so can nest FOREACHes. */ FOREACH(mixinPtr, superPtr->mixins) { AddSimpleClassChainToCallContext(mixinPtr, methodNameObj, cbPtr, doneFilters, flags, filterDecl); } i=j; } hPtr = Tcl_FindHashEntry(&oPtr->methods, (char *) methodNameObj); if (hPtr != NULL) { AddMethodToCallChain(Tcl_GetHashValue(hPtr), cbPtr, doneFilters, filterDecl); } } AddSimpleClassChainToCallContext(oPtr->selfCls, methodNameObj, cbPtr, doneFilters, flags, filterDecl); } /* * ---------------------------------------------------------------------- * * AddSimpleClassChainToCallContext -- * * Construct a call-chain from a class hierarchy. * * ---------------------------------------------------------------------- */ static void AddSimpleClassChainToCallContext( Class *classPtr, /* Class to add the call chain entries for. */ Tcl_Obj *const methodNameObj, /* Name of method to add the call chain * entries for. */ struct ChainBuilder *const cbPtr, /* Where to add the call chain entries. */ Tcl_HashTable *const doneFilters, /* Where to record what call chain entries * have been processed. */ int flags, /* What sort of call chain are we building. */ Class *filterDecl) /* The class that declared the filter. If * NULL, either the filter was declared by the * object or this isn't a filter. */ { /* * We hard-code the tail-recursive form. It's by far the most common case * *and* it is much more gentle on the stack. */ tailRecurse: if (flags & CONSTRUCTOR) { AddMethodToCallChain(classPtr->constructorPtr, cbPtr, doneFilters, filterDecl); } else if (flags & DESTRUCTOR) { AddMethodToCallChain(classPtr->destructorPtr, cbPtr, doneFilters, filterDecl); } else { Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods, (char *) methodNameObj); if (hPtr != NULL) { register Method *mPtr = Tcl_GetHashValue(hPtr); if (!(flags & KNOWN_STATE)) { if (flags & PUBLIC_METHOD) { if (mPtr->flags & PUBLIC_METHOD) { flags |= DEFINITE_PUBLIC; } else { return; } } else { flags |= DEFINITE_PROTECTED; } } AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl); } } switch (classPtr->superclasses.num) { case 1: classPtr = classPtr->superclasses.list[0]; goto tailRecurse; default: { int i; Class *superPtr; FOREACH(superPtr, classPtr->superclasses) { AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr, doneFilters, flags, filterDecl); } } case 0: return; } } /* * ---------------------------------------------------------------------- * * AddMethodToCallChain -- * * Utility method that manages the adding of a particular method * implementation to a call-chain. * * ---------------------------------------------------------------------- */ static void AddMethodToCallChain( Method *mPtr, /* Actual method implementation to add to call * chain (or NULL, a no-op). */ struct ChainBuilder *cbPtr, /* The call chain to add the method * implementation to. */ Tcl_HashTable *doneFilters, /* Where to record what filters have been * processed. If NULL, not processing filters. * Note that this function does not update * this hashtable. */ Class *filterDecl) /* The class that declared the filter. If * NULL, either the filter was declared by the * object or this isn't a filter. */ { register CallContext *contextPtr = cbPtr->contextPtr; int i; /* * Return if this is just an entry used to record whether this is a public * method. If so, there's nothing real to call and so nothing to add to * the call chain. */ if (mPtr == NULL || mPtr->typePtr == NULL) { return; } /* * Enforce real private method handling here. We will skip adding this * method IF * 1) we are not allowing private methods, AND * 2) this is a private method, AND * 3) this is a class method, AND * 4) this method was not declared by the class of the current object. * * This does mean that only classes really handle private methods. This * should be sufficient for [incr Tcl] support though. */ if (!(contextPtr->flags & PRIVATE_METHOD) && (mPtr->flags & PRIVATE_METHOD) && (mPtr->declaringClassPtr != NULL) && (mPtr->declaringClassPtr != contextPtr->oPtr->selfCls)) { return; } /* * First test whether the method is already in the call chain. Skip over * any leading filters. */ for (i=cbPtr->filterLength ; i<contextPtr->numCallChain ; i++) { if (contextPtr->callChain[i].mPtr == mPtr && contextPtr->callChain[i].isFilter == (doneFilters!=NULL)) { /* * Call chain semantics states that methods come as *late* in the * call chain as possible. This is done by copying down the * following methods. Note that this does not change the number of * method invokations in the call chain; it just rearranges them. */ Class *declCls = contextPtr->callChain[i].filterDeclarer; for (; i+1<contextPtr->numCallChain ; i++) { contextPtr->callChain[i] = contextPtr->callChain[i+1]; } contextPtr->callChain[i].mPtr = mPtr; contextPtr->callChain[i].isFilter = (doneFilters != NULL); contextPtr->callChain[i].filterDeclarer = declCls; return; } } /* * Need to really add the method. This is made a bit more complex by the * fact that we are using some "static" space initially, and only start * realloc-ing if the chain gets long. */ if (contextPtr->numCallChain == CALL_CHAIN_STATIC_SIZE) { contextPtr->callChain = (struct MInvoke *) ckalloc(sizeof(struct MInvoke)*(contextPtr->numCallChain+1)); memcpy(contextPtr->callChain, contextPtr->staticCallChain, sizeof(struct MInvoke) * (contextPtr->numCallChain + 1)); } else if (contextPtr->numCallChain > CALL_CHAIN_STATIC_SIZE) { contextPtr->callChain = (struct MInvoke *) ckrealloc((char *) contextPtr->callChain, sizeof(struct MInvoke) * (contextPtr->numCallChain + 1)); } contextPtr->callChain[i].mPtr = mPtr; contextPtr->callChain[i].isFilter = (doneFilters != NULL); contextPtr->callChain[i].filterDeclarer = filterDecl; contextPtr->numCallChain++; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Added generic/tclOODefineCmds.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 | /* * tclOODefineCmds.c -- * * This file contains the implementation of the ::oo::define command, * part of the object-system core (NB: not Tcl_Obj, but ::oo). * * Copyright (c) 2006 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclOODefineCmds.c,v 1.1.2.29 2006/10/23 13:20:59 dkf Exp $ */ #include "tclInt.h" #include "tclOO.h" int TclOODefineObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { CallFrame *framePtr, **framePtrPtr; Foundation *fPtr = ((Interp *) interp)->ooFoundation; int result; Object *oPtr; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "objectName arg ?arg ...?"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); if (oPtr == NULL) { return TCL_ERROR; } /* * Make the oo::define namespace the current namespace and evaluate the * command(s). */ /* This is needed to satisfy GCC 3.3's strict aliasing rules */ framePtrPtr = &framePtr; result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, (Tcl_Namespace *) fPtr->defineNs, FRAME_IS_OO_DEFINE); if (result != TCL_OK) { return TCL_ERROR; } framePtr->ooContextPtr = oPtr; framePtr->objc = objc; framePtr->objv = objv; /* Reference counts do not need to be * incremented here. */ if (objc == 3) { result = Tcl_EvalObjEx(interp, objv[2], 0); if (result == TCL_ERROR) { int length; const char *objName = Tcl_GetStringFromObj(objv[1], &length); int limit = 200; int overflow = (length > limit); TclFormatToErrorInfo(interp, "\n (in definition script for object \"%.*s%s\" line %d)", (overflow ? limit : length), objName, (overflow ? "..." : ""), interp->errorLine); } } else { Tcl_Obj *objPtr, *obj2Ptr, **objs; Interp *iPtr = (Interp *) interp; Tcl_Command cmd; int dummy; /* * More than one argument: fire them through the ensemble processing * engine so that everything appears to be good and proper in error * messages. Note that we cannot just concatenate and send through * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we * cannot go through Tcl_EvalObjv without the extra work to pre-find * the command, as that finds command names in the wrong namespace at * the moment. Ugly! */ if (iPtr->ensembleRewrite.sourceObjs == NULL) { iPtr->ensembleRewrite.sourceObjs = objv; iPtr->ensembleRewrite.numRemovedObjs = 3; iPtr->ensembleRewrite.numInsertedObjs = 1; } else { int ni = iPtr->ensembleRewrite.numInsertedObjs; if (ni < 3) { iPtr->ensembleRewrite.numRemovedObjs += 3 - ni; } else { iPtr->ensembleRewrite.numInsertedObjs -= 2; } } /* * Build the list of arguments using a Tcl_Obj as a workspace. See * comments above for why these contortions are necessary. */ TclNewObj(objPtr); TclNewObj(obj2Ptr); cmd = Tcl_FindCommand(interp, TclGetString(objv[2]), fPtr->defineNs, TCL_NAMESPACE_ONLY); if (cmd == NULL) { /* punt this case! */ Tcl_AppendObjToObj(obj2Ptr, objv[2]); } else { Tcl_GetCommandFullName(interp, cmd, obj2Ptr); } Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr); Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-3, objv+3); TclListObjGetElements(objPtr, dummy, objs); result = Tcl_EvalObjv(interp, objc-2, objs, TCL_EVAL_INVOKE); TclDecrRefCount(objPtr); } /* * Restore the previous "current" namespace. */ TclPopStackFrame(interp); return result; } Tcl_Object TclOOGetDefineCmdContext( Tcl_Interp *interp) { Interp *iPtr = (Interp *) interp; if ((iPtr->framePtr == NULL) || (iPtr->framePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) { Tcl_AppendResult(interp, "this command may only be called from within" " the context of the ::oo::define command", NULL); return NULL; } return (Tcl_Object) iPtr->framePtr->ooContextPtr; } int TclOODefineConstructorObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { Object *oPtr; Class *clsPtr; int bodyLength; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "arguments body"); return TCL_ERROR; } /* * Extract and validate the context, which is the class that we wish to * modify. */ oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { return TCL_ERROR; } if (oPtr->classPtr == NULL) { Tcl_AppendResult(interp, "only classes may have constructors defined", NULL); return TCL_ERROR; } clsPtr = oPtr->classPtr; (void) Tcl_GetStringFromObj(objv[2], &bodyLength); if (bodyLength > 0) { /* * Create the method structure. */ Method *mPtr; mPtr = TclOONewProcClassMethod(interp, clsPtr, PUBLIC_METHOD, NULL, objv[1], objv[2]); if (mPtr == NULL) { return TCL_ERROR; } /* * Place the method structure in the class record. Note that we might * not immediately delete the constructor as this might be being done * during execution of the constructor itself. */ TclOODeleteMethod(clsPtr->constructorPtr); clsPtr->constructorPtr = mPtr; } else { /* * Delete the constructor method record and set the field in the class * record to NULL. */ TclOODeleteMethod(clsPtr->constructorPtr); clsPtr->constructorPtr = NULL; } return TCL_OK; } int TclOODefineDestructorObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { Object *oPtr; Class *clsPtr; int bodyLength; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "body"); return TCL_ERROR; } oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { return TCL_ERROR; } if (oPtr->classPtr == NULL) { Tcl_AppendResult(interp, "only classes may have destructors defined", NULL); return TCL_ERROR; } clsPtr = oPtr->classPtr; (void) Tcl_GetStringFromObj(objv[1], &bodyLength); if (bodyLength > 0) { /* * Create the method structure. */ Method *mPtr; mPtr = TclOONewProcClassMethod(interp, clsPtr, PUBLIC_METHOD, NULL, NULL, objv[1]); if (mPtr == NULL) { return TCL_ERROR; } /* * Place the method structure in the class record. Note that we might * not immediately delete the destructor as this might be being done * during execution of the destructor itself. */ TclOODeleteMethod(clsPtr->destructorPtr); clsPtr->destructorPtr = mPtr; } else { /* * Delete the destructor method record and set the field in the class * record to NULL. */ TclOODeleteMethod(clsPtr->destructorPtr); clsPtr->destructorPtr = NULL; } return TCL_OK; } int TclOODefineExportObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { int isSelfExport = (clientData != NULL); Object *oPtr; Method *mPtr; Tcl_HashEntry *hPtr; Class *clsPtr; int i, isNew; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); return TCL_ERROR; } oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { return TCL_ERROR; } clsPtr = oPtr->classPtr; isSelfExport |= (clsPtr == NULL); for (i=1 ; i<objc ; i++) { if (isSelfExport) { hPtr = Tcl_CreateHashEntry(&oPtr->methods, (char *) objv[i], &isNew); } else { hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i], &isNew); } if (isNew) { mPtr = (Method *) ckalloc(sizeof(Method)); memset(mPtr, 0, sizeof(Method)); Tcl_SetHashValue(hPtr, mPtr); } else { mPtr = Tcl_GetHashValue(hPtr); } mPtr->flags |= PUBLIC_METHOD; } if (isSelfExport) { oPtr->epoch++; } else { ((Interp *)interp)->ooFoundation->epoch++; } return TCL_OK; } int TclOODefineFilterObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { int isSelfFilter = (clientData != NULL); Object *oPtr; int i; oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { return TCL_ERROR; } isSelfFilter |= (oPtr->classPtr == NULL); if (!isSelfFilter) { if (oPtr->classPtr->filters.num) { Tcl_Obj *filterObj; FOREACH(filterObj, oPtr->classPtr->filters) { TclDecrRefCount(filterObj); } } if (objc == 1) { /* * No list of filters was supplied, so we're deleting filters. */ ckfree((char *) oPtr->classPtr->filters.list); oPtr->classPtr->filters.list = NULL; oPtr->classPtr->filters.num = 0; } else { /* * We've got a list of filters, so we're creating filters. */ Tcl_Obj **filters; if (oPtr->classPtr->filters.num == 0) { filters = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * (objc-1)); } else { filters = (Tcl_Obj **) ckrealloc( (char *) oPtr->classPtr->filters.list, sizeof(Tcl_Obj *) * (objc-1)); } for (i=1 ; i<objc ; i++) { filters[i-1] = objv[i]; Tcl_IncrRefCount(objv[i]); } oPtr->classPtr->filters.list = filters; oPtr->classPtr->filters.num = objc-1; } /* * There may be many objects affected, so bump the global epoch. */ ((Interp *)interp)->ooFoundation->epoch++; } else { if (oPtr->filters.num) { Tcl_Obj *filterObj; FOREACH(filterObj, oPtr->filters) { TclDecrRefCount(filterObj); } } if (objc == 1) { /* * No list of filters was supplied, so we're deleting filters. */ ckfree((char *) oPtr->filters.list); oPtr->filters.list = NULL; oPtr->filters.num = 0; } else { /* * We've got a list of filters, so we're creating filters. */ Tcl_Obj **filters; if (oPtr->filters.num == 0) { filters = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * (objc-1)); } else { filters = (Tcl_Obj **) ckrealloc((char *) oPtr->filters.list, sizeof(Tcl_Obj *) * (objc-1)); } for (i=1 ; i<objc ; i++) { filters[i-1] = objv[i]; Tcl_IncrRefCount(objv[i]); } oPtr->filters.list = filters; oPtr->filters.num = objc-1; } oPtr->epoch++; /* Only this object can be affected. */ } return TCL_OK; } int TclOODefineForwardObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { int isSelfForward = (clientData != NULL); Object *oPtr; Method *mPtr; int isPublic; Tcl_Obj *prefixObj; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "name cmdName ?arg ...?"); return TCL_ERROR; } oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { return TCL_ERROR; } isSelfForward |= (oPtr->classPtr == NULL); isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*") ? PUBLIC_METHOD : 0; /* * Create the method structure. */ prefixObj = Tcl_NewListObj(objc-2, objv+2); if (isSelfForward) { mPtr = TclOONewForwardMethod(interp, oPtr, isPublic, objv[1], prefixObj); } else { mPtr = TclOONewForwardClassMethod(interp, oPtr->classPtr, isPublic, objv[1], prefixObj); } if (mPtr == NULL) { TclDecrRefCount(prefixObj); return TCL_ERROR; } return TCL_OK; } int TclOODefineMethodObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { int isSelfMethod = (clientData != NULL); Object *oPtr; int bodyLength; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "name args body"); return TCL_ERROR; } oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { return TCL_ERROR; } isSelfMethod |= (oPtr->classPtr == NULL); (void) Tcl_GetStringFromObj(objv[3], &bodyLength); if (bodyLength > 0) { /* * Create the method structure. */ Method *mPtr; int isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*") ? PUBLIC_METHOD : 0; if (isSelfMethod) { mPtr = TclOONewProcMethod(interp, oPtr, isPublic, objv[1], objv[2], objv[3]); } else { mPtr = TclOONewProcClassMethod(interp, oPtr->classPtr, isPublic, objv[1], objv[2], objv[3]); } if (mPtr == NULL) { return TCL_ERROR; } } else { /* * Delete the method structure from the appropriate hash table. */ Tcl_HashEntry *hPtr; if (isSelfMethod) { hPtr = Tcl_FindHashEntry(&oPtr->methods, (char *)objv[1]); } else { hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, (char *)objv[1]); } if (hPtr != NULL) { Method *mPtr = (Method *) Tcl_GetHashValue(hPtr); Tcl_DeleteHashEntry(hPtr); TclOODeleteMethod(mPtr); } } return TCL_OK; } int TclOODefineMixinObjCmd( ClientData clientData, Tcl_Interp *interp, const int objc, Tcl_Obj *const *objv) { int isSelfMixin = (clientData != NULL); Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); Class *mixinPtr; int i; if (oPtr == NULL) { return TCL_ERROR; } isSelfMixin |= (oPtr->classPtr == NULL); if (isSelfMixin) { if (objc == 1) { if (oPtr->mixins.num != 0) { FOREACH(mixinPtr, oPtr->mixins) { TclOORemoveFromInstances(oPtr, mixinPtr); } ckfree((char *) oPtr->mixins.list); oPtr->mixins.num = 0; } } else { Class **mixins = (Class **) ckalloc(sizeof(Class *) * (objc-1)); for (i=1 ; i<objc ; i++) { Object *o2Ptr; o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[i]); if (o2Ptr == NULL) { goto freeAndErrorSelf; } if (o2Ptr->classPtr == NULL) { Tcl_AppendResult(interp, "may only mix in classes; \"", TclGetString(objv[i]), "\" is not a class", NULL); freeAndErrorSelf: ckfree((char *) mixins); return TCL_ERROR; } mixins[i-1] = o2Ptr->classPtr; } if (oPtr->mixins.num != 0) { FOREACH(mixinPtr, oPtr->mixins) { if (mixinPtr != oPtr->selfCls) { TclOORemoveFromInstances(oPtr, mixinPtr); } } ckfree((char *) oPtr->mixins.list); } oPtr->mixins.num = objc-1; oPtr->mixins.list = mixins; FOREACH(mixinPtr, oPtr->mixins) { if (mixinPtr != oPtr->selfCls) { TclOOAddToInstances(oPtr, mixinPtr); } } } oPtr->epoch++; } else { register Class *clsPtr = oPtr->classPtr; if (objc == 1) { if (clsPtr->mixins.num != 0) { FOREACH(mixinPtr, clsPtr->mixins) { TclOORemoveFromMixinSubs(clsPtr, mixinPtr); } ckfree((char *) clsPtr->mixins.list); clsPtr->mixins.num = 0; } } else { Class **mixins = (Class **) ckalloc(sizeof(Class *) * (objc-1)); for (i=1 ; i<objc ; i++) { Object *o2Ptr; o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[i]); if (o2Ptr == NULL) { goto freeAndErrorClass; } if (o2Ptr->classPtr == NULL) { Tcl_AppendResult(interp, "may only mix in classes; \"", TclGetString(objv[i]), "\" is not a class", NULL); freeAndErrorClass: ckfree((char *) mixins); return TCL_ERROR; } mixins[i-1] = o2Ptr->classPtr; } if (clsPtr->mixins.num != 0) { FOREACH(mixinPtr, clsPtr->mixins) { TclOORemoveFromMixinSubs(clsPtr, mixinPtr); } ckfree((char *) clsPtr->mixins.list); } clsPtr->mixins.num = objc-1; clsPtr->mixins.list = mixins; FOREACH(mixinPtr, clsPtr->mixins) { TclOOAddToMixinSubs(clsPtr, mixinPtr); } } ((Interp *)interp)->ooFoundation->epoch++; } return TCL_OK; } int TclOODefineSelfClassObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { Object *oPtr, *o2Ptr; Foundation *fPtr = ((Interp *)interp)->ooFoundation; /* * Parse the context to get the object to operate on. */ oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { return TCL_ERROR; } if (oPtr == fPtr->objectCls->thisPtr) { Tcl_AppendResult(interp, "may not modify the class of the root object", NULL); return TCL_ERROR; } if (oPtr == fPtr->classCls->thisPtr) { Tcl_AppendResult(interp, "may not modify the class of the class of classes", NULL); return TCL_ERROR; } /* * Parse the argument to get the class to set the object's class to. */ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "className"); return TCL_ERROR; } o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); if (o2Ptr == NULL) { return TCL_ERROR; } if (o2Ptr->classPtr == NULL) { Tcl_AppendResult(interp, "the class of an object must be a class", NULL); return TCL_ERROR; } /* * Apply semantic checks. In particular, classes and non-classes are not * interchangable (too complicated to do the conversion!) so we must * produce an error if any attempt is made to swap from one to the other. */ if ((oPtr->classPtr == NULL) == TclOOIsReachable(fPtr->classCls, o2Ptr->classPtr)) { Tcl_AppendResult(interp, "may not change a ", (oPtr->classPtr==NULL ? "non-" : ""), "class object into a ", (oPtr->classPtr==NULL ? "" : "non-"), "class object", NULL); return TCL_ERROR; } /* * Set the object's class. */ if (oPtr->selfCls != o2Ptr->classPtr) { TclOORemoveFromInstances(oPtr, oPtr->selfCls); oPtr->selfCls = o2Ptr->classPtr; TclOOAddToInstances(oPtr, oPtr->selfCls); if (oPtr->classPtr != NULL) { fPtr->epoch++; } else { oPtr->epoch++; } } return TCL_OK; } int TclOODefineSuperclassObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { Object *oPtr, *o2Ptr; Foundation *fPtr = ((Interp *)interp)->ooFoundation; Class **superclasses, *superPtr; int i, j; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "className ?className ...?"); return TCL_ERROR; } /* * Get the class to operate on. */ oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { return TCL_ERROR; } if (oPtr->classPtr == NULL) { Tcl_AppendResult(interp, "only classes may have superclasses defined", NULL); return TCL_ERROR; } if (oPtr == fPtr->objectCls->thisPtr) { Tcl_AppendResult(interp, "may not modify the superclass of the root object", NULL); return TCL_ERROR; } /* * Allocate some working space. */ superclasses = (Class **) ckalloc(sizeof(Class *) * (objc-1)); /* * Parse the arguments to get the class to use as superclasses. */ for (i=0 ; i<objc-1 ; i++) { o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[i+1]); if (o2Ptr == NULL) { goto failedAfterAlloc; } if (o2Ptr->classPtr == NULL) { Tcl_AppendResult(interp, "only a class can be a superclass",NULL); goto failedAfterAlloc; } for (j=0 ; j<i ; j++) { if (superclasses[j] == o2Ptr->classPtr) { Tcl_AppendResult(interp, "class should only be a direct superclass once",NULL); goto failedAfterAlloc; } } if (TclOOIsReachable(oPtr->classPtr, o2Ptr->classPtr)) { Tcl_AppendResult(interp, "attempt to form circular dependency graph", NULL); failedAfterAlloc: ckfree((char *) superclasses); return TCL_ERROR; } superclasses[i] = o2Ptr->classPtr; } /* * Install the list of superclasses into the class. Note that this also * involves splicing the class out of the superclasses' subclass list that * it used to be a member of and splicing it into the new superclasses' * subclass list. */ if (oPtr->classPtr->superclasses.num != 0) { FOREACH(superPtr, oPtr->classPtr->superclasses) { TclOORemoveFromSubclasses(oPtr->classPtr, superPtr); } ckfree((char *) oPtr->classPtr->superclasses.list); } oPtr->classPtr->superclasses.list = superclasses; oPtr->classPtr->superclasses.num = objc-1; FOREACH(superPtr, oPtr->classPtr->superclasses) { TclOOAddToSubclasses(oPtr->classPtr, superPtr); } fPtr->epoch++; return TCL_OK; } int TclOODefineUnexportObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { int isSelfUnexport = (clientData != NULL); Object *oPtr; Method *mPtr; Tcl_HashEntry *hPtr; Class *clsPtr; int i, isNew; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); return TCL_ERROR; } oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { return TCL_ERROR; } clsPtr = oPtr->classPtr; isSelfUnexport |= (oPtr->classPtr == NULL); for (i=1 ; i<objc ; i++) { if (isSelfUnexport) { hPtr = Tcl_CreateHashEntry(&oPtr->methods, (char *) objv[i], &isNew); } else { hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i], &isNew); } if (isNew) { mPtr = (Method *) ckalloc(sizeof(Method)); memset(mPtr, 0, sizeof(Method)); Tcl_SetHashValue(hPtr, mPtr); } else { mPtr = Tcl_GetHashValue(hPtr); } mPtr->flags &= ~PUBLIC_METHOD; } if (isSelfUnexport) { oPtr->epoch++; } else { ((Interp *)interp)->ooFoundation->epoch++; } return TCL_OK; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Added generic/tclOOInfo.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 | /* * tclOODefineCmds.c -- * * This file contains the implementation of the ::oo-related [info] * subcommands. * * Copyright (c) 2006 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclOOInfo.c,v 1.1.2.20 2006/10/22 23:01:37 dkf Exp $ */ #include "tclInt.h" #include "tclOO.h" static Tcl_ObjCmdProc InfoObjectClassCmd; static Tcl_ObjCmdProc InfoObjectDefnCmd; static Tcl_ObjCmdProc InfoObjectFiltersCmd; static Tcl_ObjCmdProc InfoObjectForwardCmd; static Tcl_ObjCmdProc InfoObjectIsACmd; static Tcl_ObjCmdProc InfoObjectMethodsCmd; static Tcl_ObjCmdProc InfoObjectMixinsCmd; static Tcl_ObjCmdProc InfoObjectVarsCmd; static Tcl_ObjCmdProc InfoClassConstrCmd; static Tcl_ObjCmdProc InfoClassDefnCmd; static Tcl_ObjCmdProc InfoClassDestrCmd; static Tcl_ObjCmdProc InfoClassFiltersCmd; static Tcl_ObjCmdProc InfoClassForwardCmd; static Tcl_ObjCmdProc InfoClassInstancesCmd; static Tcl_ObjCmdProc InfoClassMethodsCmd; static Tcl_ObjCmdProc InfoClassMixinsCmd; static Tcl_ObjCmdProc InfoClassSubsCmd; static Tcl_ObjCmdProc InfoClassSupersCmd; 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::class", InfoObjectClassCmd}, {"::oo::InfoObject::definition", InfoObjectDefnCmd}, {"::oo::InfoObject::filters", InfoObjectFiltersCmd}, {"::oo::InfoObject::forward", InfoObjectForwardCmd}, {"::oo::InfoObject::isa", InfoObjectIsACmd}, {"::oo::InfoObject::methods", InfoObjectMethodsCmd}, {"::oo::InfoObject::mixins", InfoObjectMixinsCmd}, {"::oo::InfoObject::vars", InfoObjectVarsCmd}, {NULL, NULL} }; /* * List of commands that are used to implement the [info class] subcommands. */ static const struct NameProcMap infoClassCmds[] = { {"::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::mixins", InfoClassMixinsCmd}, {"::oo::InfoClass::subclasses", InfoClassSubsCmd}, {"::oo::InfoClass::superclasses", InfoClassSupersCmd}, {NULL, NULL} }; void TclOOInitInfo( Tcl_Interp *interp) { Tcl_Namespace *nsPtr; 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]. */ 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); } } int TclInfoObjectCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { Interp *iPtr = (Interp *) interp; int result; Tcl_Obj **newobjv = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * objc-1); int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); if (isRootEnsemble) { iPtr->ensembleRewrite.sourceObjs = objv; iPtr->ensembleRewrite.numRemovedObjs = 2; iPtr->ensembleRewrite.numInsertedObjs = 1; } else { int ni = iPtr->ensembleRewrite.numInsertedObjs; if (ni < 2) { iPtr->ensembleRewrite.numRemovedObjs += 2 - ni; } else { iPtr->ensembleRewrite.numInsertedObjs--; } } TclNewStringObj(newobjv[0], "::oo::InfoObject", strlen("::oo::InfoObject")); Tcl_IncrRefCount(newobjv[0]); if (objc > 2) { memcpy(newobjv+1, objv+2, sizeof(Tcl_Obj *) * (objc-2)); } result = Tcl_EvalObjv(interp, objc-1, newobjv, TCL_EVAL_INVOKE); TclDecrRefCount(newobjv[0]); ckfree((char *) newobjv); if (isRootEnsemble) { iPtr->ensembleRewrite.sourceObjs = NULL; iPtr->ensembleRewrite.numRemovedObjs = 0; iPtr->ensembleRewrite.numInsertedObjs = 0; } return result; } int TclInfoClassCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { Interp *iPtr = (Interp *) interp; int result; Tcl_Obj **newobjv = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * objc-1); int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); if (isRootEnsemble) { iPtr->ensembleRewrite.sourceObjs = objv; iPtr->ensembleRewrite.numRemovedObjs = 2; iPtr->ensembleRewrite.numInsertedObjs = 1; } else { int ni = iPtr->ensembleRewrite.numInsertedObjs; if (ni < 2) { iPtr->ensembleRewrite.numRemovedObjs += 2 - ni; } else { iPtr->ensembleRewrite.numInsertedObjs--; } } TclNewStringObj(newobjv[0], "::oo::InfoClass", strlen("::oo::InfoClass")); Tcl_IncrRefCount(newobjv[0]); if (objc > 2) { memcpy(newobjv+1, objv+2, sizeof(Tcl_Obj *) * (objc-2)); } result = Tcl_EvalObjv(interp, objc-1, newobjv, TCL_EVAL_INVOKE); TclDecrRefCount(newobjv[0]); ckfree((char *) newobjv); if (isRootEnsemble) { iPtr->ensembleRewrite.sourceObjs = NULL; iPtr->ensembleRewrite.numRemovedObjs = 0; iPtr->ensembleRewrite.numInsertedObjs = 0; } return result; } static int InfoObjectClassCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Object *oPtr; if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "objName ?className?"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); if (oPtr == NULL) { return TCL_ERROR; } if (objc == 2) { Tcl_GetCommandFullName(interp, oPtr->selfCls->thisPtr->command, Tcl_GetObjResult(interp)); return TCL_OK; } else { Object *o2Ptr; Class *mixinPtr; int i; o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); if (o2Ptr == NULL) { return TCL_ERROR; } if (o2Ptr->classPtr == NULL) { Tcl_AppendResult(interp, "object \"", TclGetString(objv[2]), "\" is not a class", NULL); return TCL_ERROR; } FOREACH(mixinPtr, oPtr->mixins) { if (TclOOIsReachable(o2Ptr->classPtr, mixinPtr)) { Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); return TCL_OK; } } Tcl_SetObjResult(interp, Tcl_NewIntObj( TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls))); return TCL_OK; } } static int InfoObjectDefnCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Object *oPtr; Tcl_HashEntry *hPtr; Proc *procPtr; CompiledLocal *localPtr; Tcl_Obj *argsObj; if (objc != 3) { Tcl_WrongNumArgs(interp, 3, objv, "objName methodName"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); if (oPtr == NULL) { return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&oPtr->methods, (char *) objv[2]); if (hPtr == NULL) { Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), "\"", NULL); return TCL_ERROR; } procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); if (procPtr == NULL) { Tcl_AppendResult(interp, "definition not available for this kind of method", NULL); return TCL_ERROR; } TclNewObj(argsObj); for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL; localPtr=localPtr->nextPtr) { if (TclIsVarArgument(localPtr)) { Tcl_Obj *argObj; TclNewObj(argObj); Tcl_ListObjAppendElement(NULL, argObj, Tcl_NewStringObj(localPtr->name, -1)); if (localPtr->defValuePtr != NULL) { Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr); } Tcl_ListObjAppendElement(NULL, argsObj, argObj); } } Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj); /* * This is copied from the [info body] implementation. See the comments * there for why this copy has to be done here. */ if (procPtr->bodyPtr->bytes == NULL) { (void) Tcl_GetString(procPtr->bodyPtr); } Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), Tcl_NewStringObj(procPtr->bodyPtr->bytes, procPtr->bodyPtr->length)); return TCL_OK; } static int InfoObjectFiltersCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { int i; Tcl_Obj *filterObj; Object *oPtr; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "objName"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); if (oPtr == NULL) { return TCL_ERROR; } FOREACH(filterObj, oPtr->filters) { Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), filterObj); } return TCL_OK; } static int InfoObjectForwardCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Object *oPtr; Tcl_HashEntry *hPtr; Tcl_Obj *prefixObj; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "objName methodName"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); if (oPtr == NULL) { return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&oPtr->methods, (char *) objv[2]); if (hPtr == NULL) { Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), "\"", NULL); return TCL_ERROR; } prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr)); if (prefixObj == NULL) { Tcl_AppendResult(interp, "prefix argument list not available for this kind of method", NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, prefixObj); return TCL_OK; } static int InfoObjectIsACmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { static const char *categories[] = { "class", "metaclass", "mixin", "object", "typeof", NULL }; enum IsACats { IsClass, IsMetaclass, IsMixin, IsObject, IsType }; Object *oPtr, *o2Ptr; int idx, i; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "category objName ?arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], categories, "category", 0, &idx) != TCL_OK) { return TCL_ERROR; } if (idx == IsObject) { int ok = (Tcl_GetObjectFromObj(interp, objv[2]) != NULL); if (!ok) { Tcl_ResetResult(interp); } Tcl_SetObjResult(interp, Tcl_NewIntObj(ok ? 1 : 0)); return TCL_OK; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); if (oPtr == NULL) { return TCL_ERROR; } switch ((enum IsACats) idx) { case IsClass: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "objName"); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(oPtr->classPtr ? 1 : 0)); return TCL_OK; case IsMetaclass: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "objName"); return TCL_ERROR; } if (oPtr->classPtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); } else { Foundation *fPtr = ((Interp *)interp)->ooFoundation; Tcl_SetObjResult(interp, Tcl_NewIntObj( TclOOIsReachable(fPtr->classCls, oPtr->classPtr) ? 1 : 0)); } return TCL_OK; case IsMixin: if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "objName className"); return TCL_ERROR; } o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]); if (o2Ptr == NULL) { return TCL_ERROR; } if (o2Ptr->classPtr == NULL) { Tcl_AppendResult(interp, "non-classes cannot be mixins", NULL); return TCL_ERROR; } else { Class *mixinPtr; FOREACH(mixinPtr, oPtr->mixins) { if (mixinPtr == o2Ptr->classPtr) { Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); return TCL_OK; } } } Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); return TCL_OK; case IsType: if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "objName className"); return TCL_ERROR; } o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]); if (o2Ptr == NULL) { return TCL_ERROR; } if (o2Ptr->classPtr == NULL) { Tcl_AppendResult(interp, "non-classes cannot be types", NULL); return TCL_ERROR; } if (TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)) { Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); } else { Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); } return TCL_OK; case IsObject: Tcl_Panic("unexpected fallthrough"); } return TCL_ERROR; } static int InfoObjectMethodsCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Object *oPtr; int flag = PUBLIC_METHOD; FOREACH_HASH_DECLS; Tcl_Obj *namePtr; Method *mPtr; if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "objName ?-private?"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); if (oPtr == NULL) { return TCL_ERROR; } if (objc == 3) { int len; const char *str = Tcl_GetStringFromObj(objv[2], &len); if (len == 13 && !strcmp("-localprivate", str)) { flag = PRIVATE_METHOD; } else if (len < 2 || strncmp("-private", str, (unsigned)len)) { Tcl_AppendResult(interp, "unknown switch \"", str, "\": must be -private", NULL); return TCL_ERROR; } else { flag = 0; } } FOREACH_HASH(namePtr, mPtr, &oPtr->methods) { if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) { Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), namePtr); } } return TCL_OK; } static int InfoObjectMixinsCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Class *mixinPtr; Object *oPtr; int i; if (objc != 2) { Tcl_WrongNumArgs(interp, 3, objv, "objName"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); if (oPtr == NULL) { return TCL_ERROR; } FOREACH(mixinPtr, oPtr->mixins) { Tcl_Obj *tmpObj; TclNewObj(tmpObj); Tcl_GetCommandFullName(interp, mixinPtr->thisPtr->command, tmpObj); Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj); } return TCL_OK; } static int InfoObjectVarsCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Object *oPtr; const char *pattern = NULL, *name; FOREACH_HASH_DECLS; Var *varPtr; if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "objName ?pattern?"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); if (oPtr == NULL) { return TCL_ERROR; } if (objc == 3) { pattern = TclGetString(objv[2]); } FOREACH_HASH(name, varPtr, &((Namespace *) oPtr->namespacePtr)->varTable) { if (varPtr->flags & VAR_UNDEFINED) { continue; } if (pattern != NULL && !Tcl_StringMatch(name, pattern)) { continue; } Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), Tcl_NewStringObj(name, -1)); } return TCL_OK; } static int InfoClassConstrCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Proc *procPtr; CompiledLocal *localPtr; Tcl_Obj *argsObj; Object *oPtr; Class *clsPtr; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "className"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); if (oPtr == NULL) { return TCL_ERROR; } if (oPtr->classPtr == NULL) { Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), "\" is not a class", NULL); return TCL_ERROR; } clsPtr = oPtr->classPtr; if (clsPtr->constructorPtr == NULL) { return TCL_OK; } procPtr = TclOOGetProcFromMethod(clsPtr->constructorPtr); if (procPtr == NULL) { Tcl_AppendResult(interp, "definition not available for this kind of method", NULL); return TCL_ERROR; } TclNewObj(argsObj); for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL; localPtr=localPtr->nextPtr) { if (TclIsVarArgument(localPtr)) { Tcl_Obj *argObj; TclNewObj(argObj); Tcl_ListObjAppendElement(NULL, argObj, Tcl_NewStringObj(localPtr->name, -1)); if (localPtr->defValuePtr != NULL) { Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr); } Tcl_ListObjAppendElement(NULL, argsObj, argObj); } } Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj); if (procPtr->bodyPtr->bytes == NULL) { (void) Tcl_GetString(procPtr->bodyPtr); } Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), Tcl_NewStringObj(procPtr->bodyPtr->bytes, procPtr->bodyPtr->length)); return TCL_OK; } static int InfoClassDefnCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Tcl_HashEntry *hPtr; Proc *procPtr; CompiledLocal *localPtr; Tcl_Obj *argsObj; Object *oPtr; Class *clsPtr; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "className methodName"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); if (oPtr == NULL) { return TCL_ERROR; } if (oPtr->classPtr == NULL) { Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), "\" is not a class", NULL); return TCL_ERROR; } clsPtr = oPtr->classPtr; hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]); if (hPtr == NULL) { Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), "\"", NULL); return TCL_ERROR; } procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); if (procPtr == NULL) { Tcl_AppendResult(interp, "definition not available for this kind of method", NULL); return TCL_ERROR; } TclNewObj(argsObj); for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL; localPtr=localPtr->nextPtr) { if (TclIsVarArgument(localPtr)) { Tcl_Obj *argObj; TclNewObj(argObj); Tcl_ListObjAppendElement(NULL, argObj, Tcl_NewStringObj(localPtr->name, -1)); if (localPtr->defValuePtr != NULL) { Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr); } Tcl_ListObjAppendElement(NULL, argsObj, argObj); } } Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj); if (procPtr->bodyPtr->bytes == NULL) { (void) Tcl_GetString(procPtr->bodyPtr); } Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), Tcl_NewStringObj(procPtr->bodyPtr->bytes, procPtr->bodyPtr->length)); return TCL_OK; } static int InfoClassDestrCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Proc *procPtr; Object *oPtr; Class *clsPtr; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "className"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); if (oPtr == NULL) { return TCL_ERROR; } if (oPtr->classPtr == NULL) { Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), "\" is not a class", NULL); return TCL_ERROR; } clsPtr = oPtr->classPtr; if (clsPtr->destructorPtr == NULL) { return TCL_OK; } procPtr = TclOOGetProcFromMethod(clsPtr->destructorPtr); if (procPtr == NULL) { Tcl_AppendResult(interp, "definition not available for this kind of method", NULL); return TCL_ERROR; } if (procPtr->bodyPtr->bytes == NULL) { (void) Tcl_GetString(procPtr->bodyPtr); } Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), Tcl_NewStringObj(procPtr->bodyPtr->bytes, procPtr->bodyPtr->length)); return TCL_OK; } static int InfoClassFiltersCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { int i; Tcl_Obj *filterObj; Object *oPtr; Class *clsPtr; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "className"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); if (oPtr == NULL) { return TCL_ERROR; } if (oPtr->classPtr == NULL) { Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), "\" is not a class", NULL); return TCL_ERROR; } clsPtr = oPtr->classPtr; FOREACH(filterObj, clsPtr->filters) { Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), filterObj); } return TCL_OK; } static int InfoClassForwardCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Tcl_HashEntry *hPtr; Tcl_Obj *prefixObj; Object *oPtr; Class *clsPtr; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "className methodName"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); if (oPtr == NULL) { return TCL_ERROR; } if (oPtr->classPtr == NULL) { Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), "\" is not a class", NULL); return TCL_ERROR; } clsPtr = oPtr->classPtr; hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]); if (hPtr == NULL) { Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), "\"", NULL); return TCL_ERROR; } prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr)); if (prefixObj == NULL) { Tcl_AppendResult(interp, "prefix argument list not available for this kind of method", NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, prefixObj); return TCL_OK; } static int InfoClassInstancesCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Object *oPtr; Class *clsPtr; int i; const char *pattern = NULL; if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); if (oPtr == NULL) { return TCL_ERROR; } if (oPtr->classPtr == NULL) { Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), "\" is not a class", NULL); return TCL_ERROR; } clsPtr = oPtr->classPtr; if (objc == 3) { pattern = TclGetString(objv[2]); } FOREACH(oPtr, clsPtr->instances) { Tcl_Obj *tmpObj; TclNewObj(tmpObj); Tcl_GetCommandFullName(interp, oPtr->command, tmpObj); if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) { TclDecrRefCount(tmpObj); continue; } Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj); } return TCL_OK; } static int InfoClassMethodsCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { int flag = PUBLIC_METHOD; FOREACH_HASH_DECLS; Tcl_Obj *namePtr; Method *mPtr; Object *oPtr; Class *clsPtr; if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "className ?-private?"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); if (oPtr == NULL) { return TCL_ERROR; } if (oPtr->classPtr == NULL) { Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), "\" is not a class", NULL); return TCL_ERROR; } clsPtr = oPtr->classPtr; if (objc == 3) { int len; const char *str = Tcl_GetStringFromObj(objv[2], &len); if (len == 13 && !strcmp("-localprivate", str)) { flag = PRIVATE_METHOD; } else if (len < 2 || strncmp("-private", str, (unsigned)len)) { Tcl_AppendResult(interp, "unknown switch \"", str, "\": must be -private", NULL); return TCL_ERROR; } else { flag = 0; } } FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) { if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) { Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), namePtr); } } return TCL_OK; } static int InfoClassMixinsCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Object *oPtr; Class *clsPtr, *mixinPtr; int i; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "className"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); if (oPtr == NULL) { return TCL_ERROR; } if (oPtr->classPtr == NULL) { Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), "\" is not a class", NULL); return TCL_ERROR; } clsPtr = oPtr->classPtr; FOREACH(mixinPtr, clsPtr->mixins) { Tcl_Obj *tmpObj; TclNewObj(tmpObj); Tcl_GetCommandFullName(interp, mixinPtr->thisPtr->command, tmpObj); Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj); } return TCL_OK; } static int InfoClassSubsCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Object *oPtr; Class *clsPtr, *subclassPtr; int i; const char *pattern = NULL; if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); if (oPtr == NULL) { return TCL_ERROR; } if (oPtr->classPtr == NULL) { Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), "\" is not a class", NULL); return TCL_ERROR; } clsPtr = oPtr->classPtr; if (objc == 3) { pattern = TclGetString(objv[2]); } FOREACH(subclassPtr, clsPtr->subclasses) { Tcl_Obj *tmpObj; TclNewObj(tmpObj); Tcl_GetCommandFullName(interp, subclassPtr->thisPtr->command, tmpObj); if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) { TclDecrRefCount(tmpObj); continue; } Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj); } return TCL_OK; } static int InfoClassSupersCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Object *oPtr; Class *clsPtr, *superPtr; int i; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "className"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); if (oPtr == NULL) { return TCL_ERROR; } if (oPtr->classPtr == NULL) { Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), "\" is not a class", NULL); return TCL_ERROR; } clsPtr = oPtr->classPtr; FOREACH(superPtr, clsPtr->superclasses) { Tcl_Obj *tmpObj; TclNewObj(tmpObj); Tcl_GetCommandFullName(interp, superPtr->thisPtr->command, tmpObj); Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj); } return TCL_OK; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclProc.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclProc.c -- * * This file contains routines that implement Tcl procedures, including * the "proc" and "uplevel" commands. * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 2004-2006 Miguel Sofer * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | > | > | | > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | /* * tclProc.c -- * * This file contains routines that implement Tcl procedures, including * the "proc" and "uplevel" commands. * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 2004-2006 Miguel Sofer * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclProc.c,v 1.86.2.7 2006/10/08 15:39:59 dkf Exp $ */ #include "tclInt.h" #include "tclCompile.h" #include "tclOO.h" /* * Prototypes for static functions in this file */ static int ObjInterpProcEx(ClientData clientData, register Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int skip); static void ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); static void ProcBodyFree(Tcl_Obj *objPtr); static int ProcessProcResultCode(Tcl_Interp *interp, Tcl_Obj *procNameObj, int returnCode, int isMethod); static int TclCompileNoOp(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); static void InitCompiledLocals(Tcl_Interp *interp, ByteCode *codePtr, CompiledLocal *localPtr, Var *varPtr, Namespace *nsPtr); static void DupLambdaInternalRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void FreeLambdaInternalRep(Tcl_Obj *objPtr); static int SetLambdaFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); /* * The ProcBodyObjType type */ Tcl_ObjType tclProcBodyType = { "procbody", /* name for this type */ |
︙ | ︙ | |||
57 58 59 60 61 62 63 64 65 66 67 68 69 70 | * rep; it's just a cache type. */ static Tcl_ObjType levelReferenceType = { "levelReference", NULL, NULL, NULL, NULL }; /* *---------------------------------------------------------------------- * * Tcl_ProcObjCmd -- * * This object-based function is invoked to process the "proc" Tcl | > > > > > > > > > > > > > > > > | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 | * rep; it's just a cache type. */ static Tcl_ObjType levelReferenceType = { "levelReference", NULL, NULL, NULL, NULL }; /* * The type of "lambda expression" terms (i.e., the first arguments to the * [apply] command). A lambdaType Tcl_Obj has the form: * * ptr1 is a *Proc: pointer to a proc structure * ptr2 is a *Tcl_Obj: the lambda's namespace */ Tcl_ObjType lambdaType = { "lambdaExpr", /* name */ FreeLambdaInternalRep, /* freeIntRepProc */ DupLambdaInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ SetLambdaFromAny /* setFromAnyProc */ }; /* *---------------------------------------------------------------------- * * Tcl_ProcObjCmd -- * * This object-based function is invoked to process the "proc" Tcl |
︙ | ︙ | |||
81 82 83 84 85 86 87 | /* ARGSUSED */ int Tcl_ProcObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ | | | | 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 | /* ARGSUSED */ int Tcl_ProcObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register Interp *iPtr = (Interp *) interp; Proc *procPtr; char *fullName; const char *procName, *procArgs, *procBody; Namespace *nsPtr, *altNsPtr, *cxtNsPtr; Tcl_Command cmd; Tcl_DString ds; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "name args body"); return TCL_ERROR; |
︙ | ︙ | |||
250 251 252 253 254 255 256 | *---------------------------------------------------------------------- */ int TclCreateProc( Tcl_Interp *interp, /* interpreter containing proc */ Namespace *nsPtr, /* namespace containing this proc */ | | | | | 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 | *---------------------------------------------------------------------- */ int TclCreateProc( Tcl_Interp *interp, /* interpreter containing proc */ Namespace *nsPtr, /* namespace containing this proc */ const char *procName, /* unqualified name of this proc */ Tcl_Obj *argsPtr, /* description of arguments */ Tcl_Obj *bodyPtr, /* command body */ Proc **procPtrPtr) /* returns: pointer to proc data */ { Interp *iPtr = (Interp*)interp; const char **argArray = NULL; register Proc *procPtr; int i, length, result, numArgs; const char *args, *bytes, *p; register CompiledLocal *localPtr = NULL; Tcl_Obj *defPtr; int precompiled = 0; if (bodyPtr->typePtr == &tclProcBodyType) { /* * Because the body is a TclProProcBody, the actual body is already |
︙ | ︙ | |||
354 355 356 357 358 359 360 | } else { procPtr->numArgs = numArgs; procPtr->numCompiledLocals = numArgs; } for (i = 0; i < numArgs; i++) { int fieldCount, nameLength, valueLength; | | | 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 | } else { procPtr->numArgs = numArgs; procPtr->numCompiledLocals = numArgs; } for (i = 0; i < numArgs; i++) { int fieldCount, nameLength, valueLength; const char **fieldValues; /* * Now divide the specifier up into name and default. */ result = Tcl_SplitList(interp, argArray[i], &fieldCount, &fieldValues); |
︙ | ︙ | |||
392 393 394 395 396 397 398 | /* * Check that the formal parameter name is a scalar. */ p = fieldValues[0]; while (*p != '\0') { if (*p == '(') { | | | 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 | /* * Check that the formal parameter name is a scalar. */ p = fieldValues[0]; while (*p != '\0') { if (*p == '(') { const char *q = p; do { q++; } while (*q != '\0'); q--; if (*q == ')') { /* we have an array element */ Tcl_AppendResult(interp, "formal parameter \"", fieldValues[0], |
︙ | ︙ | |||
563 564 565 566 567 568 569 | * *---------------------------------------------------------------------- */ int TclGetFrame( Tcl_Interp *interp, /* Interpreter in which to find frame. */ | | | 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 | * *---------------------------------------------------------------------- */ int TclGetFrame( Tcl_Interp *interp, /* Interpreter in which to find frame. */ const char *name, /* String describing frame. */ CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if * global frame indicated). */ { register Interp *iPtr = (Interp *) interp; int curLevel, level, result; CallFrame *framePtr; |
︙ | ︙ | |||
652 653 654 655 656 657 658 | Tcl_Obj *objPtr, /* Object describing frame. */ CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if * global frame indicated). */ { register Interp *iPtr = (Interp *) interp; int curLevel, level, result; CallFrame *framePtr; | | | 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 | Tcl_Obj *objPtr, /* Object describing frame. */ CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if * global frame indicated). */ { register Interp *iPtr = (Interp *) interp; int curLevel, level, result; CallFrame *framePtr; const char *name = TclGetString(objPtr); /* * Parse object to figure out which level number to go to. */ result = 1; curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level; |
︙ | ︙ | |||
770 771 772 773 774 775 776 | /* ARGSUSED */ int Tcl_UplevelObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ | | | 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 | /* ARGSUSED */ int Tcl_UplevelObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register Interp *iPtr = (Interp *) interp; int result; CallFrame *savedVarFramePtr, *framePtr; if (objc < 2) { uplevelSyntax: |
︙ | ︙ | |||
860 861 862 863 864 865 866 | * *---------------------------------------------------------------------- */ Proc * TclFindProc( Interp *iPtr, /* Interpreter in which to look. */ | | | 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 | * *---------------------------------------------------------------------- */ Proc * TclFindProc( Interp *iPtr, /* Interpreter in which to look. */ const char *procName) /* Name of desired procedure. */ { Tcl_Command cmd; Tcl_Command origCmd; Command *cmdPtr; cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName, NULL, /*flags*/ 0); if (cmd == (Tcl_Command) NULL) { |
︙ | ︙ | |||
1090 1091 1092 1093 1094 1095 1096 | InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr); } /* *---------------------------------------------------------------------- * | | | 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 | InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr); } /* *---------------------------------------------------------------------- * * TclObjInterpProc, ObjInterpProcEx -- * * When a Tcl procedure gets invoked during bytecode evaluation, this * object-based routine gets invoked to interpret the procedure. * * Results: * A standard Tcl object result value. * |
︙ | ︙ | |||
1112 1113 1114 1115 1116 1117 1118 | TclObjInterpProc( ClientData clientData, /* Record describing procedure to be * interpreted. */ register Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ int objc, /* Count of number of arguments to this * procedure. */ | | < | | | | < < < < < < | < < < < < | < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 | TclObjInterpProc( ClientData clientData, /* Record describing procedure to be * interpreted. */ register Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ int objc, /* Count of number of arguments to this * procedure. */ Tcl_Obj *const objv[]) /* Argument value objects. */ { return ObjInterpProcEx(clientData, interp, objc, objv, /*skip*/ 1); } static int ObjInterpProcEx( ClientData clientData, /* Record describing procedure to be * interpreted. */ register Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ int objc, /* Count of number of arguments to this * procedure. */ Tcl_Obj *const objv[], /* Argument value objects. */ int skip) /* Number of initial arguments to be skipped, * i.e., words in the "command name" */ { register Proc *procPtr = (Proc *) clientData; Namespace *nsPtr = procPtr->cmdPtr->nsPtr; CallFrame *framePtr, **framePtrPtr; int result; /* * If necessary, compile the procedure's body. The compiler will allocate * frame slots for the procedure's non-argument local variables. Note that * compiling the body might increase procPtr->numCompiledLocals if new * local variables are found while compiling. */ result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr, "body of proc", TclGetString(objv[0])); if (result != TCL_OK) { return result; } /* * Set up and push a new call frame for the new procedure invocation. * This call frame will execute in the proc's namespace, which might be * different than the current namespace. The proc's namespace is that of * its command, which can change if the command is renamed from one * namespace to another. */ framePtrPtr = &framePtr; result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, (Tcl_Namespace *) nsPtr, FRAME_IS_PROC); if (result != TCL_OK) { return result; } framePtr->objc = objc; framePtr->objv = objv; /* ref counts for args are incremented below */ framePtr->procPtr = procPtr; return TclObjInterpProcCore(interp, framePtr, objv[0], skip); } /* *---------------------------------------------------------------------- * * TclObjInterpProcCore -- * * When a Tcl procedure, procedure-like method or lambda term gets * invoked during bytecode evaluation, this object-based routine gets * invoked to interpret the body. * * Results: * A standard Tcl object result value. * * Side effects: * Depends on the commands in the procedure body. * *---------------------------------------------------------------------- */ int TclObjInterpProcCore( register Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ CallFrame *framePtr, /* The context to execute. The procPtr field * must be non-NULL. */ Tcl_Obj *procNameObj, /* Procedure name for error reporting. */ int skip) /* Number of initial arguments to be skipped, * i.e., words in the "command name". */ { register Proc *procPtr = framePtr->procPtr; register Var *varPtr; register CompiledLocal *localPtr; int localCt, numArgs, argCt, i, imax, result; Var *compiledLocals; Tcl_Obj *const *argObjs; int isMethod = (framePtr->isProcCallFrame & (FRAME_IS_METHOD | FRAME_IS_CONSTRUCTOR | FRAME_IS_DESTRUCTOR)); /* * Create the "compiledLocals" array. Make sure it is large enough to hold * all the procedure's compiled local variables, including its formal * parameters. */ localCt = procPtr->numCompiledLocals; compiledLocals = (Var *) TclStackAlloc(interp, (int)(localCt*sizeof(Var))); framePtr->numCompiledLocals = localCt; framePtr->compiledLocals = compiledLocals; /* * Match and assign the call's actual parameters to the procedure's formal * arguments. The formal arguments are described by the first numArgs * entries in both the Proc structure's local variable list and the call * frame's local variable array. */ numArgs = procPtr->numArgs; argCt = framePtr->objc-skip; /* set it to the number of args to the proc */ argObjs = &framePtr->objv[skip]; varPtr = framePtr->compiledLocals; localPtr = procPtr->firstLocalPtr; if (numArgs == 0) { if (argCt) { goto incorrectArgs; } else { goto runProc; |
︙ | ︙ | |||
1286 1287 1288 1289 1290 1291 1292 | /* * Do initialise all compiled locals, to avoid problems at * DeleteLocalVars. */ incorrectArgs: codePtr = (ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr; | | | | | 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 | /* * Do initialise all compiled locals, to avoid problems at * DeleteLocalVars. */ incorrectArgs: codePtr = (ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr; InitCompiledLocals(interp, codePtr, localPtr, varPtr, framePtr->nsPtr); /* * Build up desired argument list for Tcl_WrongNumArgs */ desiredObjs = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * (unsigned)(numArgs+1)); #ifdef AVOID_HACKS_FOR_ITCL desiredObjs[0] = framePtr->objv[0]; #else desiredObjs[0] = Tcl_NewListObj(skip, framePtr->objv); #endif /* AVOID_HACKS_FOR_ITCL */ localPtr = procPtr->firstLocalPtr; for (i=1 ; i<=numArgs ; i++) { TclNewObj(argObj); if (localPtr->defValuePtr != NULL) { Tcl_AppendStringsToObj(argObj, "?", localPtr->name, "?", NULL); |
︙ | ︙ | |||
1352 1353 1354 1355 1356 1357 1358 | */ runProc: if (localPtr) { ByteCode *codePtr = (ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr; | | | | | | 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 | */ runProc: if (localPtr) { ByteCode *codePtr = (ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr; InitCompiledLocals(interp, codePtr, localPtr, varPtr, framePtr->nsPtr); } /* * Invoke the commands in the procedure's body. */ #ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= 1) { fprintf(stdout, "Calling proc "); for (i = 0; i < framePtr->objc; i++) { TclPrintObject(stdout, framePtr->objv[i], 15); fprintf(stdout, " "); } fprintf(stdout, "\n"); fflush(stdout); } #endif /*TCL_COMPILE_DEBUG*/ procPtr->refCount++; result = TclCompEvalObj(interp, procPtr->bodyPtr); procPtr->refCount--; if (procPtr->refCount <= 0) { TclProcCleanupProc(procPtr); } if (result != TCL_OK) { result = ProcessProcResultCode(interp, procNameObj, result, isMethod); } /* * Pop and free the call frame for this procedure invocation, then free * the compiledLocals array if malloc'ed storage was used. */ |
︙ | ︙ | |||
1431 1432 1433 1434 1435 1436 1437 | TclProcCompileProc( Tcl_Interp *interp, /* Interpreter containing procedure. */ Proc *procPtr, /* Data associated with procedure. */ Tcl_Obj *bodyPtr, /* Body of proc. (Usually procPtr->bodyPtr, * but could be any code fragment compiled in * the context of this procedure.) */ Namespace *nsPtr, /* Namespace containing procedure. */ | | | | 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 | TclProcCompileProc( Tcl_Interp *interp, /* Interpreter containing procedure. */ Proc *procPtr, /* Data associated with procedure. */ Tcl_Obj *bodyPtr, /* Body of proc. (Usually procPtr->bodyPtr, * but could be any code fragment compiled in * the context of this procedure.) */ Namespace *nsPtr, /* Namespace containing procedure. */ const char *description, /* string describing this body of code. */ const char *procName) /* Name of this procedure. */ { Interp *iPtr = (Interp*)interp; int result; Tcl_CallFrame *framePtr; Proc *saveProcPtr; ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr; |
︙ | ︙ | |||
1562 1563 1564 1565 1566 1567 1568 | *---------------------------------------------------------------------- */ static int ProcessProcResultCode( Tcl_Interp *interp, /* The interpreter in which the procedure was * called and returned returnCode. */ | | < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > | | | > | 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 | *---------------------------------------------------------------------- */ static int ProcessProcResultCode( Tcl_Interp *interp, /* The interpreter in which the procedure was * called and returned returnCode. */ Tcl_Obj *procNameObj, /* Name of the procedure. Used for error * messages and trace information. */ int returnCode, /* The unexpected result code. */ int isMethod) /* Whether this is a procedure, method, * constructor or destructor. */ { Interp *iPtr = (Interp *) interp; int overflow, limit = 60; if (returnCode == TCL_OK) { return TCL_OK; } if ((returnCode > TCL_CONTINUE) || (returnCode < TCL_OK)) { return returnCode; } if (returnCode == TCL_RETURN) { return TclUpdateReturnInfo(iPtr); } if (returnCode != TCL_ERROR) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "invoked \"", ((returnCode == TCL_BREAK) ? "break" : "continue"), "\" outside of a loop", NULL); } if (isMethod & FRAME_IS_CONSTRUCTOR) { if (interp->errorLine != 0xDEADBEEF) { /* hack! */ CallContext *contextPtr = ((Interp *) interp)->varFramePtr->ooContextPtr; Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr; Tcl_Command declarer; Tcl_Obj *objectNameObj; const char *objectName, *kindName; int objectNameLen; if (mPtr->declaringObjectPtr != NULL) { declarer = mPtr->declaringObjectPtr->command; kindName = "object"; } else { if (mPtr->declaringClassPtr == NULL) { Tcl_Panic("method not declared in class or object"); } declarer = mPtr->declaringClassPtr->thisPtr->command; kindName = "class"; } TclNewObj(objectNameObj); Tcl_GetCommandFullName(interp, declarer, objectNameObj); objectName = Tcl_GetStringFromObj(objectNameObj, &objectNameLen); overflow = (objectNameLen > limit); TclFormatToErrorInfo(interp, "\n (%s \"%.*s%s\" constructor line %d)", kindName, (overflow ? limit : objectNameLen), objectName, (overflow ? "..." : ""), interp->errorLine); TclDecrRefCount(objectNameObj); } } else if (isMethod & FRAME_IS_DESTRUCTOR) { CallContext *contextPtr = ((Interp *) interp)->varFramePtr->ooContextPtr; Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr; Tcl_Command declarer; Tcl_Obj *objectNameObj; const char *objectName, *kindName; int objectNameLen; if (mPtr->declaringObjectPtr != NULL) { declarer = mPtr->declaringObjectPtr->command; kindName = "object"; } else { if (mPtr->declaringClassPtr == NULL) { Tcl_Panic("method not declared in class or object"); } declarer = mPtr->declaringClassPtr->thisPtr->command; kindName = "class"; } TclNewObj(objectNameObj); Tcl_GetCommandFullName(interp, declarer, objectNameObj); objectName = Tcl_GetStringFromObj(objectNameObj, &objectNameLen); overflow = (objectNameLen > limit); TclFormatToErrorInfo(interp, "\n (%s \"%.*s%s\" destructor line %d)", kindName, (overflow ? limit : objectNameLen), objectName, (overflow ? "..." : ""), interp->errorLine); TclDecrRefCount(objectNameObj); } else if (isMethod & FRAME_IS_METHOD) { int nameLen, objectNameLen, objNameOverflow; CallContext *contextPtr = ((Interp *) interp)->varFramePtr->ooContextPtr; Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr; Tcl_Obj *objectNameObj; const char *objectName, *kindName, *methodName = Tcl_GetStringFromObj(mPtr->namePtr, &nameLen); Tcl_Command declarer; if (mPtr->declaringObjectPtr != NULL) { declarer = mPtr->declaringObjectPtr->command; kindName = "object"; } else { if (mPtr->declaringClassPtr == NULL) { Tcl_Panic("method not declared in class or object"); } declarer = mPtr->declaringClassPtr->thisPtr->command; kindName = "class"; } TclNewObj(objectNameObj); Tcl_GetCommandFullName(interp, declarer, objectNameObj); objectName = Tcl_GetStringFromObj(objectNameObj, &objectNameLen); overflow = (nameLen > limit); objNameOverflow = (objectNameLen > limit); TclFormatToErrorInfo(interp, "\n (%s \"%.*s%s\" method \"%.*s%s\" line %d)", kindName, (objNameOverflow ? limit : objectNameLen), objectName, (objNameOverflow ? "..." : ""), (overflow ? limit : nameLen), methodName, (overflow ? "..." : ""), interp->errorLine); TclDecrRefCount(objectNameObj); } else { int nameLen; const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen); overflow = (nameLen > limit); TclFormatToErrorInfo(interp, "\n (procedure \"%.*s%s\" line %d)", (overflow ? limit : nameLen), procName, (overflow ? "..." : ""), interp->errorLine); } return TCL_ERROR; } /* *---------------------------------------------------------------------- * * TclProcDeleteProc -- |
︙ | ︙ | |||
1886 1887 1888 1889 1890 1891 1892 | envPtr->currStackDepth = savedStackDepth; TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); return TCL_OK; } /* * LAMBDA and APPLY implementation | < < < < < < < < < < < < < < < < < < < < < < < | | | | | | | | | | | | < | | | | 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 | envPtr->currStackDepth = savedStackDepth; TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); return TCL_OK; } /* * LAMBDA and APPLY implementation */ static void DupLambdaInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1; Tcl_Obj *nsObjPtr = srcPtr->internalRep.twoPtrValue.ptr2; copyPtr->internalRep.twoPtrValue.ptr1 = procPtr; copyPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; procPtr->refCount++; Tcl_IncrRefCount(nsObjPtr); copyPtr->typePtr = &lambdaType; } static void FreeLambdaInternalRep( register Tcl_Obj *objPtr) /* CmdName object with internal representation * to free. */ { Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1; Tcl_Obj *nsObjPtr = objPtr->internalRep.twoPtrValue.ptr2; procPtr->refCount--; if (procPtr->refCount == 0) { TclProcCleanupProc(procPtr); } TclDecrRefCount(nsObjPtr); } static int SetLambdaFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr) /* The object to convert. */ { char *name; Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv, *errPtr; int objc; Proc *procPtr; int result; |
︙ | ︙ | |||
1978 1979 1980 1981 1982 1983 1984 | /* * Create and initialize the Proc struct. The cmdPtr field is * set to NULL to signal that this is an anonymous function. */ name = TclGetString(objPtr); | | | | | | 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 | /* * Create and initialize the Proc struct. The cmdPtr field is * set to NULL to signal that this is an anonymous function. */ name = TclGetString(objPtr); if (TclCreateProc(interp, /*ignored nsPtr*/ NULL, name, argsPtr, bodyPtr, &procPtr) != TCL_OK) { TclFormatToErrorInfo(interp, "\n (parsing lambda expression \"%s\")", TclGetString(objPtr), NULL); return TCL_ERROR; } procPtr->refCount++; procPtr->cmdPtr = (Command *) NULL; /* * Set the namespace for this lambda: given by objv[2] understood * as a global reference, or else global per default. */ if (objc == 2) { nsObjPtr = Tcl_NewStringObj("::", 2); } else { char *nsName = Tcl_GetString(objv[2]); if ((*nsName != ':') || (*(nsName+1) != ':')) { nsObjPtr = Tcl_NewStringObj("::", 2); Tcl_AppendObjToObj(nsObjPtr, objv[2]); |
︙ | ︙ | |||
2016 2017 2018 2019 2020 2021 2022 | * Free the list internalrep of objPtr - this will free argsPtr, but * bodyPtr retains a reference from the Proc structure. Then finish * the conversion to lambdaType. */ objPtr->typePtr->freeIntRepProc(objPtr); | | | | > > > > > > > > > > > > > > > > > | | | | | < | | | | | | | | < | | | | < > | | | < | | | | | 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 | * Free the list internalrep of objPtr - this will free argsPtr, but * bodyPtr retains a reference from the Proc structure. Then finish * the conversion to lambdaType. */ objPtr->typePtr->freeIntRepProc(objPtr); objPtr->internalRep.twoPtrValue.ptr1 = procPtr; objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; objPtr->typePtr = &lambdaType; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ApplyObjCmd -- * * This object-based function is invoked to process the "apply" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result value. * * Side effects: * Depends on the content of the lambda term (i.e., objv[1]). * *---------------------------------------------------------------------- */ int Tcl_ApplyObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; Proc *procPtr = NULL; Tcl_Obj *lambdaPtr, *nsObjPtr, *errPtr; int result; Command cmd; Tcl_Namespace *nsPtr; #define JOE_EXTENSION 0 #if JOE_EXTENSION int numElem; #endif if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "lambdaExpr ?arg1 arg2 ...?"); return TCL_ERROR; } /* * Set lambdaPtr, convert it to lambdaType in the current interp if * necessary. */ lambdaPtr = objv[1]; if (lambdaPtr->typePtr == &lambdaType) { procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; } #if JOE_EXTENSION /* * Joe English's suggestion to allow cmdNames to function as lambdas. * Requires also making tclCmdNameType non-static in tclObj.c */ else if ((lambdaPtr->typePtr == &tclCmdNameType) || (Tcl_ListObjLength(interp, lambdaPtr, &numElem) == TCL_OK && (numElem == 1))) { return Tcl_EvalObjv(interp, objc-1, objv+1, 0); } #endif if ((procPtr == NULL) || (procPtr->iPtr != iPtr)) { result = SetLambdaFromAny(interp, lambdaPtr); if (result != TCL_OK) { return result; } procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; } procPtr->cmdPtr = &cmd; /* * Find the namespace where this lambda should run, and push a call frame * for that namespace. Note that TclObjInterpProc() will pop it. */ nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2; result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); if (result != TCL_OK) { return result; } if (nsPtr == (Tcl_Namespace *) NULL) { errPtr = Tcl_NewStringObj("cannot find namespace \"",-1); Tcl_AppendObjToObj(errPtr, nsObjPtr); Tcl_AppendToObj(errPtr, "\"", -1); Tcl_SetObjResult(interp, errPtr); return TCL_ERROR; } cmd.nsPtr = (Namespace *) nsPtr; return ObjInterpProcEx((ClientData) procPtr, interp, objc, objv, 2); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclVar.c.
︙ | ︙ | |||
11 12 13 14 15 16 17 | * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclVar.c,v 1.118.2.2 2006/08/24 02:54:36 dgp Exp $ */ #include "tclInt.h" /* * The strings below are used to indicate what went wrong when a variable * access is denied. |
︙ | ︙ | |||
34 35 36 37 38 39 40 41 42 43 44 45 46 47 | static CONST char *danglingVar = "upvar refers to variable in deleted namespace"; static CONST char *badNamespace = "parent namespace doesn't exist"; static CONST char *missingName = "missing variable name"; static CONST char *isArrayElement = "name refers to an element in an array"; /* * Forward references to functions defined later in this file: */ static void DeleteSearches(Var *arrayVarPtr); static void DeleteArray(Interp *iPtr, CONST char *arrayName, Var *varPtr, int flags); | > > > > > > > > | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | static CONST char *danglingVar = "upvar refers to variable in deleted namespace"; static CONST char *badNamespace = "parent namespace doesn't exist"; static CONST char *missingName = "missing variable name"; static CONST char *isArrayElement = "name refers to an element in an array"; /* * A test to see if we are in a call frame that has local variables. This is * true if we are inside a procedure body or an object method body. */ #define IsLocal(framePtr) \ ((framePtr)->isProcCallFrame & (FRAME_IS_PROC | FRAME_IS_METHOD)) /* * Forward references to functions defined later in this file: */ static void DeleteSearches(Var *arrayVarPtr); static void DeleteArray(Interp *iPtr, CONST char *arrayName, Var *varPtr, int flags); |
︙ | ︙ | |||
395 396 397 398 399 400 401 | goto doParse; } if (typePtr == &localVarNameType) { int localIndex = (int) part1Ptr->internalRep.longValue; if ((varFramePtr != NULL) | | | 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 | goto doParse; } if (typePtr == &localVarNameType) { int localIndex = (int) part1Ptr->internalRep.longValue; if ((varFramePtr != NULL) && IsLocal(varFramePtr) && !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) && (localIndex < varFramePtr->numCompiledLocals)) { /* * use the cached index if the names coincide. */ varPtr = &(varFramePtr->compiledLocals[localIndex]); |
︙ | ︙ | |||
419 420 421 422 423 424 425 | part1Ptr->internalRep.twoPtrValue.ptr1; varPtr = (Var *) part1Ptr->internalRep.twoPtrValue.ptr2; useGlobal = (cachedNsPtr == iPtr->globalNsPtr) && ( (flags & TCL_GLOBAL_ONLY) || (*part1==':' && *(part1+1)==':') || (varFramePtr == NULL) || | < | | | 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 | part1Ptr->internalRep.twoPtrValue.ptr1; varPtr = (Var *) part1Ptr->internalRep.twoPtrValue.ptr2; useGlobal = (cachedNsPtr == iPtr->globalNsPtr) && ( (flags & TCL_GLOBAL_ONLY) || (*part1==':' && *(part1+1)==':') || (varFramePtr == NULL) || (!IsLocal(varFramePtr) && (nsPtr == iPtr->globalNsPtr))); useReference = useGlobal || ((cachedNsPtr == nsPtr) && ( (flags & TCL_NAMESPACE_ONLY) || (varFramePtr && !IsLocal(varFramePtr) && !(flags & TCL_GLOBAL_ONLY) && /* * Careful: an undefined ns variable could be hiding a valid * global reference. */ !TclIsVarUndefined(varPtr)))); |
︙ | ︙ | |||
741 742 743 744 745 746 747 | * * If create and the variable isn't found, create the variable and, if * necessary, create varFramePtr's local var hashtable. */ if (((flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) != 0) || (varFramePtr == NULL) | | | 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 | * * If create and the variable isn't found, create the variable and, if * necessary, create varFramePtr's local var hashtable. */ if (((flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) != 0) || (varFramePtr == NULL) || !IsLocal(varFramePtr) || (strstr(varName, "::") != NULL)) { CONST char *tail; int lookGlobal; lookGlobal = (flags & TCL_GLOBAL_ONLY) || (cxtNsPtr == iPtr->globalNsPtr) || ((*varName == ':') && (*(varName+1) == ':')); |
︙ | ︙ | |||
3234 3235 3236 3237 3238 3239 3240 | * the namespace var's reference invalid. */ if (index < 0) { if (((otherP2 ? arrayPtr->nsPtr : otherPtr->nsPtr) == NULL) && ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) || (varFramePtr == NULL) | | | 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 | * the namespace var's reference invalid. */ if (index < 0) { if (((otherP2 ? arrayPtr->nsPtr : otherPtr->nsPtr) == NULL) && ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) || (varFramePtr == NULL) || !IsLocal(varFramePtr) || (strstr(myName, "::") != NULL))) { Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"", myName, "\": upvar won't create namespace variable that ", "refers to procedure variable", NULL); return TCL_ERROR; } } |
︙ | ︙ | |||
3266 3267 3268 3269 3270 3271 3272 | * Side effects: * The variable given by myName is linked to the variable in framePtr * given by otherP1 and otherP2, so that references to myName are * redirected to the other variable like a symbolic link. * *---------------------------------------------------------------------- */ | | | | | | 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 | * Side effects: * The variable given by myName is linked to the variable in framePtr * given by otherP1 and otherP2, so that references to myName are * redirected to the other variable like a symbolic link. * *---------------------------------------------------------------------- */ int TclPtrMakeUpvar(interp, otherPtr, myName, myFlags, index) Tcl_Interp *interp; /* Interpreter containing variables. Used for * error messages, too. */ Var *otherPtr; /* Pointer to the variable being linked-to */ CONST char *myName; /* Name of variable which will refer to * otherP1/otherP2. Must be a scalar. */ int myFlags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: * indicates scope of myName. */ int index; /* If the variable to be linked is an indexed * scalar, this is its index. Otherwise, -1 */ { Interp *iPtr = (Interp *) interp; CallFrame *varFramePtr = iPtr->varFramePtr; Var *varPtr; CONST char *errMsg; CONST char *p; if (index >= 0) { if (!IsLocal(varFramePtr)) { Tcl_Panic("ObjMakeUpvar called with an index outside from a proc.\n"); } varPtr = &(varFramePtr->compiledLocals[index]); } else { /* * Do not permit the new variable to look like an array reference, as * it will not be reachable in that case [Bug 600812, TIP 184]. The |
︙ | ︙ | |||
3549 3550 3551 3552 3553 3554 3555 | return TCL_ERROR; } /* * If we are not executing inside a Tcl procedure, just return. */ | | < | 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 | return TCL_ERROR; } /* * If we are not executing inside a Tcl procedure, just return. */ if ((iPtr->varFramePtr == NULL) || !IsLocal(iPtr->varFramePtr)) { return TCL_OK; } for (i=1 ; i<objc ; i++) { /* * Make a local variable linked to its counterpart in the global :: * namespace. |
︙ | ︙ | |||
3701 3702 3703 3704 3705 3706 3707 | } /* * If we are executing inside a Tcl procedure, create a local variable * linked to the new namespace variable "varName". */ | | < | 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 | } /* * If we are executing inside a Tcl procedure, create a local variable * linked to the new namespace variable "varName". */ if ((iPtr->varFramePtr != NULL) && IsLocal(iPtr->varFramePtr)) { /* * varName might have a scope qualifier, but the name for the * local "link" variable must be the simple name at the tail. * * Locate tail in one pass: drop any prefix after two *or more* * consecutive ":" characters). */ |
︙ | ︙ |
Changes to tests/info.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: info # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # Commands covered: info # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: info.test,v 1.34.2.1 2006/08/30 15:35:16 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } # Set up namespaces needed to test operation of "info args", "info body", |
︙ | ︙ | |||
643 644 645 646 647 648 649 | } {1 {wrong # args: should be "info functions ?pattern?"}} test info-21.1 {miscellaneous error conditions} { list [catch {info} msg] $msg } {1 {wrong # args: should be "info option ?arg arg ...?"}} test info-21.2 {miscellaneous error conditions} { list [catch {info gorp} msg] $msg | | | | | > > > > | 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 | } {1 {wrong # args: should be "info functions ?pattern?"}} test info-21.1 {miscellaneous error conditions} { list [catch {info} msg] $msg } {1 {wrong # args: should be "info option ?arg arg ...?"}} test info-21.2 {miscellaneous error conditions} { list [catch {info gorp} msg] $msg } {1 {bad option "gorp": must be args, body, class, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} test info-21.3 {miscellaneous error conditions} { list [catch {info c} msg] $msg } {1 {ambiguous option "c": must be args, body, class, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} test info-21.4 {miscellaneous error conditions} { list [catch {info l} msg] $msg } {1 {ambiguous option "l": must be args, body, class, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} test info-21.5 {miscellaneous error conditions} { list [catch {info s} msg] $msg } {1 {ambiguous option "s": must be args, body, class, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} # cleanup catch {namespace delete test_ns_info1 test_ns_info2} ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: |
Added tests/oo.test.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 | # This file contains a collection of tests for Tcl's built-in object system. # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # # Copyright (c) 2006 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: oo.test,v 1.1.2.40 2006/10/22 00:26:31 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } testConstraint memory [llength [info commands memory]] test oo-0.1 {basic test of OO's ability to clean up its initial state} { interp create t interp delete t } {} test oo-0.2 {basic test of OO's ability to clean up its initial state} { interp eval [interp create] { namespace delete :: } } {} test oo-0.3 {basic test of OO's ability to clean up its initial state} -setup { proc getbytes {} { set lines [split [memory info] "\n"] lindex $lines 3 3 } } -constraints memory -body { set end [getbytes] for {set i 0} {$i < 5} {incr i} { [oo::object new] destroy set tmp $end set end [getbytes] } set leakedBytes [expr {$end - $tmp}] } -cleanup { rename getbytes {} } -result 0 test oo-0.4 {basic test of OO's ability to clean up its initial state} -setup { proc getbytes {} { set lines [split [memory info] "\n"] lindex $lines 3 3 } } -constraints memory -body { set end [getbytes] for {set i 0} {$i < 5} {incr i} { oo::class create foo foo new foo destroy set tmp $end set end [getbytes] } set leakedBytes [expr {$end - $tmp}] } -cleanup { rename getbytes {} } -result 0 test oo-1.1 {basic test of OO functionality: no classes} { set result {} lappend result [oo::object create foo] lappend result [oo::define foo { method bar args { global result lappend result {expand}$args return [llength $args] } }] lappend result [foo bar a b c] lappend result [foo destroy] [info commands foo] } {::foo {} a b c 3 {} {}} test oo-1.2 {basic test of OO functionality: no classes} -body { oo::define oo::object method missingArgs } -returnCodes 1 -result "wrong # args: should be \"oo::define oo::object method name args body\"" test oo-1.3 {basic test of OO functionality: no classes} { catch {oo::define oo::object method missingArgs} set errorInfo } "wrong # args: should be \"oo::define oo::object method name args body\" while executing \"oo::define oo::object method missingArgs\"" test oo-1.4 {basic test of OO functionality} -body { oo::object create {} } -returnCodes 1 -result {object name must not be empty} test oo-1.5 {basic test of OO functionality} -body { oo::object doesnotexist } -returnCodes 1 -result {unknown method "doesnotexist": must be create, destroy or new} test oo-1.6 {basic test of OO functionality} -setup { oo::object create aninstance } -body { oo::define aninstance unexport destroy aninstance doesnotexist } -cleanup { rename aninstance {} } -returnCodes 1 -result {object "::aninstance" has no visible methods} test oo-2.1 {basic test of OO functionality: constructor} -setup { # This is a bit complex because it needs to run in a sub-interp as # we're modifying the root object class's constructor interp create subinterp } -body { subinterp eval { oo::define oo::object constructor {} { lappend ::result [info level 0] } lappend result 1 lappend result 2 [oo::object create foo] } } -cleanup { interp delete subinterp } -result {1 {oo::object create foo} 2 ::foo} test oo-2.2 {basic test of OO functionality: constructor} { oo::class create testClass { constructor {} { global result lappend result "[self]->construct" } method bar {} { global result lappend result "[self]->bar" } } set result {} [testClass create foo] bar testClass destroy return $result } {::foo->construct ::foo->bar} test oo-3.1 {basic test of OO functionality: destructor} -setup { # This is a bit complex because it needs to run in a sub-interp as # we're modifying the root object class's constructor interp create subinterp } -body { subinterp eval { oo::define oo::object destructor { lappend ::result died } lappend result 1 [oo::object create foo] lappend result 2 [rename foo {}] oo::define oo::object destructor {} return $result } } -cleanup { interp delete subinterp } -result {1 ::foo died 2 {}} test oo-3.2 {basic test of OO functionality: destructor} -setup { # This is a bit complex because it needs to run in a sub-interp as # we're modifying the root object class's constructor interp create subinterp } -body { subinterp eval { oo::define oo::object destructor { lappend ::result died } lappend result 1 [oo::object create foo] lappend result 2 [rename foo {}] } } -cleanup { interp delete subinterp } -result {1 ::foo died 2 {}} test oo-4.1 {basic test of OO functionality: export} { set o [oo::object new] set result {} oo::define $o method Foo {} {lappend ::result Foo; return} lappend result [catch {$o Foo} msg] $msg oo::define $o export Foo lappend result [$o Foo] [$o destroy] } {1 {unknown method "Foo": must be destroy} Foo {} {}} test oo-4.2 {basic test of OO functionality: unexport} { set o [oo::object new] set result {} oo::define $o method foo {} {lappend ::result foo; return} lappend result [$o foo] oo::define $o unexport foo lappend result [catch {$o foo} msg] $msg [$o destroy] } {foo {} 1 {unknown method "foo": must be destroy} {}} test oo-5.1 {OO: manipulation of classes as objects} -setup { set obj [oo::object new] } -body { oo::define oo::object self.method foo {} { return "in object" } catch {$obj foo} result list [catch {$obj foo} result] $result [oo::object foo] } -cleanup { oo::define oo::object self.method foo {} {} $obj destroy } -result {1 {unknown method "foo": must be destroy} {in object}} test oo-6.1 {OO: forward} { oo::object create foo oo::define foo { forward a lappend forward b lappend result } set result {} foo a result 1 foo b 2 foo destroy return $result } {1 2} test oo-7.1 {OO: inheritance 101} -setup { oo::class create superClass oo::class create subClass subClass create instance } -body { oo::define superClass method doit x {lappend ::result $x} oo::define subClass superclass superClass set result [list [catch {subClass doit bad} msg] $msg] instance doit ok return $result } -cleanup { subClass destroy superClass destroy } -result {1 {unknown method "doit": must be create, destroy or new} ok} test oo-7.2 {OO: inheritance 101} -setup { oo::class create superClass oo::class create subClass subClass create instance } -body { oo::define superClass method doit x {lappend ::result |$x|} oo::define subClass superclass superClass oo::define instance method doit x {lappend ::result =$x=; next [incr x]} set result {} instance doit 1 return $result } -cleanup { subClass destroy superClass destroy } -result {=1= |2|} test oo-7.3 {OO: inheritance 101} -setup { oo::class create superClass oo::class create subClass subClass create instance } -body { oo::define superClass method doit x {lappend ::result |$x|} oo::define subClass { superclass superClass method doit x {lappend ::result -$x-; next [incr x]} } oo::define instance method doit x {lappend ::result =$x=; next [incr x]} set result {} instance doit 1 return $result } -cleanup { subClass destroy superClass destroy } -result {=1= -2- |3|} test oo-7.4 {OO: inheritance from oo::class} -body { oo::class create meta oo::define meta { superclass oo::class self.unexport create new self.method make {x {definitions {}}} { if {![string match ::* $x]} { set ns [uplevel 1 {::namespace current}] set x ${ns}::$x } set o [my create $x] lappend ::result "made $o" oo::define $o $definitions return $o } } set result [list [catch {meta create foo} msg] $msg] lappend result [meta make classinstance { lappend ::result "in definition script in [namespace current]" }] lappend result [classinstance create instance] } -cleanup { catch {classinstance destroy} catch {meta destroy} } -result {1 {unknown method "create": must be destroy or make} {made ::classinstance} {in definition script in ::oo::define} ::classinstance ::instance} test oo-7.5 {OO: inheritance from oo::class in the secondary chain} -body { oo::class create other oo::class create meta oo::define meta { superclass other oo::class self.unexport create new self.method make {x {definitions {}}} { if {![string match ::* $x]} { set ns [uplevel 1 {::namespace current}] set x ${ns}::$x } set o [my create $x] lappend ::result "made $o" oo::define $o $definitions return $o } } set result [list [catch {meta create foo} msg] $msg] lappend result [meta make classinstance { lappend ::result "in definition script in [namespace current]" }] lappend result [classinstance create instance] } -cleanup { catch {classinstance destroy} catch {meta destroy} catch {other destroy} } -result {1 {unknown method "create": must be destroy or make} {made ::classinstance} {in definition script in ::oo::define} ::classinstance ::instance} test oo-7.6 {OO: inheritance 101 - overridden methods should be oblivious} -setup { oo::class create Aclass oo::class create Bclass Bclass create Binstance } -body { oo::define Aclass { method incr {var step} { upvar 1 $var v ::incr v $step } } oo::define Bclass { superclass Aclass method incr {var {step 1}} { global result lappend result $var $step set r [next $var $step] lappend result returning:$r return $r } } set result {} set x 10 lappend result x=$x lappend result [Binstance incr x] lappend result x=$x } -result {x=10 x 1 returning:11 11 x=11} -cleanup { Aclass destroy } test oo-7.7 {OO: inheritance and errorInfo} -setup { oo::class create A oo::class create B B create c } -body { oo::define A method foo {} {error foo!} oo::define B { superclass A method foo {} { next } } oo::define c method foo {} { next } catch {c ?} msg set result [list $msg] catch {c foo} msg lappend result $msg $errorInfo } -cleanup { A destroy } -result {{unknown method "?": must be destroy or foo} foo! {foo! while executing "error foo!" (class "::A" method "foo" line 1) invoked from within "next " (class "::B" method "foo" line 1) invoked from within "next " (object "::c" method "foo" line 1) invoked from within "c foo"}} test oo-8.1 {OO: global must work in methods} { oo::object create foo oo::define foo method bar x {global result; lappend result $x} set result {} foo bar this foo bar is lappend result a foo bar test foo destroy return $result } {this is a test} test oo-9.1 {OO: multiple inheritance} -setup { oo::class create A oo::class create B oo::class create C oo::class create D D create foo } -body { oo::define A method test {} {lappend ::result A; return ok} oo::define B { superclass A method test {} {lappend ::result B; next} } oo::define C { superclass A method test {} {lappend ::result C; next} } oo::define D { superclass B C method test {} {lappend ::result D; next} } set result {} lappend result [foo test] } -cleanup { D destroy C destroy B destroy A destroy } -result {D B C A ok} test oo-9.2 {OO: multiple inheritance} -setup { oo::class create A oo::class create B oo::class create C oo::class create D D create foo } -body { oo::define A method test {} {lappend ::result A; return ok} oo::define B { superclass A method test {} {lappend ::result B; next} } oo::define C { superclass A method test {} {lappend ::result C; next} } oo::define D { superclass B C method test {} {lappend ::result D; next} } set result {} lappend result [foo test] } -cleanup { A destroy } -result {D B C A ok} test oo-10.1 {OO: recursive invoke and modify} -setup { [oo::class create C] create O } -cleanup { C destroy } -body { oo::define C method foo x { lappend ::result $x if {$x} { [self object] foo [incr x -1] } } oo::define O method foo x { lappend ::result -$x- if {$x == 1} { # delete the method oo::define O method foo {} {} } next $x } set result {} O foo 2 return $result } -result {-2- 2 -1- 1 0} test oo-11.1 {OO: cleanup} { oo::object create foo set result [list [catch {oo::object create foo} msg] $msg] lappend result [foo destroy] [oo::object create foo] [foo destroy] } {1 {can't create object "foo": command already exists with that name} {} ::foo {}} test oo-11.2 {OO: cleanup} { oo::class create bar bar create foo set result [list [catch {bar create foo} msg] $msg] lappend result [bar destroy] [oo::object create foo] [foo destroy] } {1 {can't create object "foo": command already exists with that name} {} ::foo {}} test oo-11.3 {OO: cleanup} { oo::class create bar0 oo::class create bar oo::define bar superclass bar0 bar create foo set result [list [catch {bar create foo} msg] $msg] lappend result [bar0 destroy] [oo::object create foo] [foo destroy] } {1 {can't create object "foo": command already exists with that name} {} ::foo {}} test oo-11.4 {OO: cleanup} { oo::class create bar0 oo::class create bar1 oo::define bar1 superclass bar0 oo::class create bar2 oo::define bar2 { superclass bar0 destructor {lappend ::result destroyed} } oo::class create bar oo::define bar superclass bar1 bar2 bar create foo set result [list [catch {bar create foo} msg] $msg] lappend result [bar0 destroy] [oo::object create foo] [foo destroy] \ [oo::object create bar2] [bar2 destroy] } {1 {can't create object "foo": command already exists with that name} destroyed {} ::foo {} ::bar2 {}} test oo-12.1 {OO: filters} { oo::class create Aclass Aclass create Aobject oo::define Aclass { method concatenate args { global result lappend result {expand}$args join $args {} } method logFilter args { global result lappend result "calling [self object]->[self method] $args" set r [next {expand}$args] lappend result "result=$r" return $r } } oo::define Aobject filter logFilter set result {} lappend result [Aobject concatenate 1 2 3 4 5] Aclass destroy return $result } {{calling ::Aobject->logFilter 1 2 3 4 5} 1 2 3 4 5 result=12345 12345} test oo-12.2 {OO: filters} -setup { oo::class create Aclass Aclass create Aobject } -body { oo::define Aclass { method concatenate args { global result lappend result {expand}$args join $args {} } method logFilter args { global result lappend result "calling [self object]->[self method] $args" set r [next {expand}$args] lappend result "result=$r" return $r } } oo::define Aobject filter logFilter set result {} lappend result [Aobject concatenate 1 2 3 4 5] [Aobject destroy] } -cleanup { Aclass destroy } -result {{calling ::Aobject->logFilter 1 2 3 4 5} 1 2 3 4 5 result=12345 {calling ::Aobject->logFilter } result= 12345 {}} test oo-12.3 {OO: filters} -setup { oo::class create Aclass Aclass create Aobject } -body { oo::define Aclass { method concatenate args { global result lappend result {expand}$args join $args {} } method logFilter args { global result lappend result "calling [self object]->[self method] $args" set r [next {expand}$args] lappend result "result=$r" return $r } filter logFilter } set result {} lappend result [Aobject concatenate 1 2 3 4 5] [Aobject destroy] } -cleanup { Aclass destroy } -result {{calling ::Aobject->logFilter 1 2 3 4 5} 1 2 3 4 5 result=12345 {calling ::Aobject->logFilter } result= 12345 {}} test oo-12.4 {OO: filters} -setup { oo::class create Aclass Aclass create Aobject } -body { oo::define Aclass { method foo {} { return foo } method Bar {} { return 1 } method boo {} { if {[my Bar]} { next } { error forbidden } } filter boo } Aobject foo } -cleanup { Aclass destroy } -result foo test oo-12.5 {OO: filters} -setup { oo::class create Aclass Aclass create Aobject } -body { oo::define Aclass { method foo {} { return foo } method Bar {} { return [my Bar2] } method Bar2 {} { return 1 } method boo {} { if {[my Bar]} { next } { error forbidden } } filter boo } Aobject foo } -cleanup { Aclass destroy } -result foo test oo-12.6 {OO: filters} -setup { oo::class create Aclass Aclass create Aobject } -body { oo::define Aclass { method foo {} { return foo } method Bar {} { return [my Bar2] } method Bar2 {} { return [my Bar3] } method Bar3 {} { return 1 } method boo {} { if {[my Bar]} { next } { error forbidden } } filter boo } Aobject foo } -cleanup { Aclass destroy } -result foo test oo-12.7 {OO: filters} -setup { oo::class create Aclass Aclass create Aobject } -body { oo::define Aclass { method outerfoo {} { return [my InnerFoo] } method InnerFoo {} { return foo } method Bar {} { return [my Bar2] } method Bar2 {} { return [my Bar3] } method Bar3 {} { return 1 } method boo {} { lappend ::log [self target] if {[my Bar]} { next } else { error forbidden } } filter boo } set log {} list [Aobject outerfoo] $log } -cleanup { Aclass destroy } -result {foo {{::Aclass outerfoo} {::Aclass InnerFoo}}} test oo-13.1 {OO: changing an object's class} { oo::class create Aclass oo::define Aclass {method bar {} {lappend ::result "in A [self object]"}} oo::class create Bclass oo::define Bclass {method bar {} {lappend ::result "in B [self object]"}} set result [Aclass create foo] foo bar oo::define foo self.class Bclass foo bar Aclass destroy lappend result [info command foo] Bclass destroy return $result } {::foo {in A ::foo} {in B ::foo} foo} test oo-13.2 {OO: changing an object's class} -body { oo::object create foo oo::define foo self.class oo::class } -cleanup { foo destroy } -returnCodes 1 -result {may not change a non-class object into a class object} test oo-13.3 {OO: changing an object's class} -body { oo::class create foo oo::define foo self.class oo::object } -cleanup { foo destroy } -returnCodes 1 -result {may not change a class object into a non-class object} # todo: changing a class subtype (metaclass) to another class subtype test oo-14.1 {OO: mixins} { oo::class create Aclass oo::define Aclass method bar {} {lappend ::result "[self object] in bar"} oo::class create Bclass oo::define Bclass method boo {} {lappend ::result "[self object] in boo"} oo::define [Aclass create fooTest] mixin Bclass oo::define [Aclass create fooTest2] mixin Bclass set result [list [catch {fooTest ?} msg] $msg] fooTest bar fooTest boo fooTest2 bar fooTest2 boo oo::define fooTest2 mixin lappend result [Bclass destroy] [info command fooTest*] [Aclass destroy] } {1 {unknown method "?": must be bar, boo or destroy} {::fooTest in bar} {::fooTest in boo} {::fooTest2 in bar} {::fooTest2 in boo} {} fooTest2 {}} test oo-14.2 {OO: mixins} { oo::class create Aclass { method bar {} {return "[self object] in bar"} } oo::class create Bclass { method boo {} {return "[self object] in boo"} } oo::define Aclass mixin Bclass Aclass create fooTest set result [list [catch {fooTest ?} msg] $msg] lappend result [catch {fooTest bar} msg] $msg lappend result [catch {fooTest boo} msg] $msg lappend result [Bclass destroy] [info commands Aclass] } {1 {unknown method "?": must be bar, boo or destroy} 0 {::fooTest in bar} 0 {::fooTest in boo} {} {}} test oo-15.1 {OO: object cloning} { oo::class create Aclass oo::define Aclass method test {} {lappend ::result [self object]->test} Aclass create Ainstance set result {} Ainstance test oo::copy Ainstance Binstance Binstance test Ainstance test Ainstance destroy namespace eval foo { oo::copy Binstance Cinstance Cinstance test } Aclass destroy namespace delete foo lappend result [info commands Binstance] } {::Ainstance->test ::Binstance->test ::Ainstance->test ::foo::Cinstance->test {}} test oo-15.2 {OO: object cloning} { oo::object create foo oo::define foo { method m x {lappend ::result [self object] >$x<} forward f ::lappend ::result fwd } set result {} foo m 1 foo f 2 lappend result [oo::copy foo bar] foo m 3 foo f 4 bar m 5 bar f 6 lappend result [foo destroy] bar m 7 bar f 8 lappend result [bar destroy] } {::foo >1< fwd 2 ::bar ::foo >3< fwd 4 ::bar >5< fwd 6 {} ::bar >7< fwd 8 {}} catch {foo destroy} catch {bar destroy} test oo-15.3 {OO: class cloning} { oo::class create foo { method testme {} {lappend ::result [self class]->[self object]} } set result {} foo create baseline baseline testme oo::copy foo bar baseline testme bar create tester tester testme foo destroy tester testme bar destroy return $result } {::foo->::baseline ::foo->::baseline ::bar->::tester ::bar->::tester} test oo-16.1 {OO: object introspection} -body { info object } -returnCodes 1 -result "wrong \# args: should be \"info object subcommand ?argument ...?\"" test oo-16.2 {OO: object introspection} -body { info object class NOTANOBJECT } -returnCodes 1 -result {NOTANOBJECT does not refer to an object} test oo-16.3 {OO: object introspection} -body { info object gorp oo::object } -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be class, definition, filters, forward, isa, methods, mixins, or vars} test oo-16.4 {OO: object introspection} -setup { oo::class create meta { superclass oo::class } } -body { list [info object class oo::object] \ [info object class oo::class] \ [info object isa class oo::object] \ [info object isa metaclass oo::object] \ [info object isa metaclass meta] \ [info object isa object oo::object] \ [info object isa object oo::define] \ [info object isa object NOTANOBJECT] } -cleanup { meta destroy } -result {::oo::class ::oo::class 1 0 1 1 0 0} test oo-16.5 {OO: object introspection} {info object methods oo::object} {} test oo-16.6 {OO: object introspection} { oo::object create foo set result [list [info object methods foo]] oo::define foo method bar {} {...} lappend result [info object methods foo] [foo destroy] } {{} bar {}} test oo-16.7 {OO: object introspection} -setup { oo::object create foo } -body { oo::define foo method bar {a {b c} args} {the body} set result [info object methods foo] lappend result [info object definition foo bar] } -cleanup { foo destroy } -result {bar {{a {b c} args} {the body}}} test oo-16.8 {OO: object introspection} { oo::object create foo oo::class create bar oo::define foo mixin bar set result [list [info object mixins foo] \ [info object isa mixin foo bar] \ [info object isa mixin foo oo::class]] foo destroy bar destroy return $result } {::bar 1 0} test oo-16.9 {OO: object introspection} { oo::class create Ac oo::class create Bc; oo::define Bc superclass Ac oo::class create Cc; oo::define Cc superclass Bc Cc create D list [info object isa typeof D oo::class] \ [info object isa typeof D Ac] \ [Ac destroy] } {0 1 {}} test oo-16.10 {OO: object introspection} -setup { oo::object create foo } -body { oo::define foo export eval foo eval {variable c 3 a 1 b 2 ddd 4 e} lsort [info object vars foo ?] } -cleanup { foo destroy } -result {a b c} test oo-17.1 {OO: class introspection} -body { info class } -returnCodes 1 -result "wrong \# args: should be \"info class subcommand ?argument ...?\"" test oo-17.2 {OO: class introspection} -body { info class superclass NOTANOBJECT } -returnCodes 1 -result {NOTANOBJECT does not refer to an object} test oo-17.3 {OO: class introspection} -setup { oo::object create foo } -body { info class superclass foo } -returnCodes 1 -cleanup { foo destroy } -result {"foo" is not a class} test oo-17.4 {OO: class introspection} -body { info class gorp oo::object } -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be constructor, definition, destructor, filters, forward, instances, methods, mixins, subclasses, or superclasses} test oo-17.5 {OO: class introspection} -setup { oo::class create testClass } -body { testClass create foo testClass create bar testClass create spong lsort [info class instances testClass] } -cleanup { testClass destroy } -result {::bar ::foo ::spong} test oo-17.6 {OO: object introspection} -setup { oo::class create foo } -body { oo::define foo method bar {a {b c} args} {the body} set result [info class methods foo] lappend result [info class definition foo bar] } -cleanup { foo destroy } -result {bar {{a {b c} args} {the body}}} test oo-17.7 {OO: object introspection} { info class superclasses oo::class } ::oo::object test oo-17.8 {OO: object introspection} -setup { oo::class create testClass oo::class create superClass1 oo::class create superClass2 } -body { oo::define testClass superclass superClass1 superClass2 list [info class superclasses testClass] \ [lsort [info class subclass oo::object ::superClass?]] } -cleanup { testClass destroy superClass1 destroy superClass2 destroy } -result {{::superClass1 ::superClass2} {::superClass1 ::superClass2}} test oo-18.1 {OO: define command support} { list [catch {oo::define oo::object {error foo}} msg] $msg $errorInfo } {1 foo {foo while executing "error foo" (in definition script for object "oo::object" line 1) invoked from within "oo::define oo::object {error foo}"}} test oo-18.2 {OO: define command support} { list [catch {oo::define oo::object error foo} msg] $msg $errorInfo } {1 foo {foo while executing "oo::define oo::object error foo"}} test oo-18.3 {OO: define command support} { list [catch {oo::class create foo {error bar}} msg] $msg $errorInfo } {1 bar {bar while executing "error bar" (in definition script for object "::foo" line 1) invoked from within "oo::class create foo {error bar}"}} test oo-18.4 {OO: more error traces from the guts} -setup { oo::object create obj } -body { oo::define obj method bar {} {my eval {error foo}} list [catch {obj bar} msg] $msg $errorInfo } -cleanup { obj destroy } -result {1 foo {foo while executing "error foo" (in "my eval" script line 1) invoked from within "my eval {error foo}" (object "::obj" method "bar" line 1) invoked from within "obj bar"}} test oo-18.5 {OO: more error traces from the guts} -setup { [oo::class create cls] create obj set errorInfo {} } -body { oo::define cls { method eval script {next $script} export eval } oo::define obj method bar {} {my eval {error foo}} set result {} lappend result [catch {obj bar} msg] $msg $errorInfo lappend result [catch {obj eval {error bar}} msg] $msg $errorInfo } -cleanup { cls destroy } -result {1 foo {foo while executing "error foo" (in "my eval" script line 1) invoked from within "next $script" (class "::cls" method "eval" line 1) invoked from within "my eval {error foo}" (object "::obj" method "bar" line 1) invoked from within "obj bar"} 1 bar {bar while executing "error bar" (in "::obj eval" script line 1) invoked from within "next $script" (class "::cls" method "eval" line 1) invoked from within "obj eval {error bar}"}} test oo-19.1 {OO: varname method} -setup { oo::object create inst oo::define inst export eval set result {} } -body { inst eval {trace add variable x write foo} set ns [inst eval namespace current] proc foo args { global ns result set context [uplevel 1 namespace current] lappend result $args [expr { $ns eq $context ? "ok" : [list $ns ne $context] }] [expr { "${ns}::x" eq [uplevel 1 my varname x] ? "ok" : [list ${ns}::x ne [uplevel 1 my varname x]] }] } lappend result [inst eval set x 0] } -cleanup { inst destroy rename foo {} } -result {{x {} write} ok ok 0} test oo-20.1 {OO: variable method} -body { oo::class create testClass { constructor {} { my variable ok set ok {} } } lsort [info object vars [testClass new]] } -cleanup { catch {testClass destroy} } -result ok test oo-20.2 {OO: variable method} -body { oo::class create testClass { constructor {} { my variable a b c set a [set b [set c {}]] } } lsort [info object vars [testClass new]] } -cleanup { catch {testClass destroy} } -result {a b c} test oo-20.3 {OO: variable method} -body { oo::class create testClass { export varname method bar {} { my variable a(b) } } testClass create foo array set [foo varname a] {b c} foo bar } -returnCodes 1 -cleanup { catch {testClass destroy} } -result {can't define "a(b)": name refers to an element in an array} test oo-20.4 {OO: variable method} -body { oo::class create testClass { export varname method bar {} { my variable a(b) } } testClass create foo set [foo varname a] b foo bar } -returnCodes 1 -cleanup { catch {testClass destroy} } -result {can't define "a(b)": name refers to an element in an array} test oo-20.5 {OO: variable method} -body { oo::class create testClass { method bar {} { my variable a::b } } testClass create foo foo bar } -returnCodes 1 -cleanup { catch {testClass destroy} } -result {variable name "a::b" illegal: must not contain namespace separator} test oo-20.6 {OO: variable method} -setup { oo::class create testClass { self.export eval export varname } } -body { testClass eval variable a 0 oo::define [testClass create foo] method bar {other} { $other variable a set a 3 } oo::define [testClass create boo] export variable set [foo varname a] 1 set [boo varname a] 2 foo bar boo list [testClass eval set a] [set [foo varname a]] [set [boo varname a]] } -cleanup { testClass destroy } -result {0 1 3} test oo-20.7 {OO: variable method} -setup { oo::class create cls } -body { oo::define cls { method a {} { my variable {b c} d lappend c $d } method e {} { my variable b d return [list $b $d] } method f {x y} { my variable b d set b $x set d $y } } cls create obj obj f p q obj a obj a obj e } -cleanup { cls destroy } -result {{p q q} q} test oo-20.8 {OO: variable method} -setup { oo::class create cls } -body { oo::define cls { constructor {} { namespace eval foo { variable bar 1 } } method ns {} {self namespace} method a {} { my variable {foo::bar c} d lappend c $d } method e {} { my variable {foo::bar b} d return [list $b $d] } method f {x} { my variable d set d $x } } cls create obj obj f p obj a obj a list [obj e] [set [obj ns]::foo::bar] } -cleanup { cls destroy } -result {{{1 p p} p} {1 p p}} test oo-20.9 {OO: variable method} -setup { oo::object create obj } -body { oo::define obj { method a {} { my variable {a ::b} } } obj a } -cleanup { obj destroy } -returnCodes 1 -result {variable name "::b" illegal: must not contain namespace separator} test oo-21.1 {OO: inheritance ordering} -setup { oo::class create A } -body { oo::define A method m {} {lappend ::result A} oo::class create B { superclass A method m {} {lappend ::result B;next} } oo::class create C { superclass A method m {} {lappend ::result C;next} } oo::class create D { superclass B C method m {} {lappend ::result D;next} } D create o oo::define o method m {} {lappend ::result o;next} set result {} o m return $result } -cleanup { A destroy } -result {o D B C A} test oo-21.2 {OO: inheritance ordering} -setup { oo::class create A } -body { oo::define A method m {} {lappend ::result A} oo::class create B { superclass A method m {} {lappend ::result B;next} } oo::class create C { superclass A method m {} {lappend ::result C;next} } oo::class create D { superclass B C method m {} {lappend ::result D;next} } oo::class create Emix { superclass C method m {} {lappend ::result Emix;next} } oo::class create Fmix { superclass Emix method m {} {lappend ::result Fmix;next} } D create o oo::define o method m {} {lappend ::result o;next} oo::define o mixin Fmix set result {} o m return $result } -cleanup { A destroy } -result {Fmix Emix o D B C A} test oo-21.3 {OO: inheritance ordering} -setup { oo::class create A } -body { oo::define A method m {} {lappend ::result A} oo::class create B { superclass A method m {} {lappend ::result B;next} method f {} {lappend ::result B-filt;next} } oo::class create C { superclass A method m {} {lappend ::result C;next} } oo::class create D { superclass B C method m {} {lappend ::result D;next} } oo::class create Emix { superclass C method m {} {lappend ::result Emix;next} method f {} {lappend ::result Emix-filt;next} } oo::class create Fmix { superclass Emix method m {} {lappend ::result Fmix;next} } D create o oo::define o { method m {} {lappend ::result o;next} mixin Fmix filter f } set result {} o m return $result } -cleanup { A destroy } -result {Emix-filt B-filt Fmix Emix o D B C A} test oo-21.4 {OO: inheritance ordering} -setup { oo::class create A } -body { oo::define A method m {} {lappend ::result A} oo::class create B { superclass A method m {} {lappend ::result B;next} method f {} {lappend ::result B-filt;next} method g {} {lappend ::result B-cfilt;next} } oo::class create C { superclass A method m {} {lappend ::result C;next} } oo::class create D { superclass B C method m {} {lappend ::result D;next} method g {} {lappend ::result D-cfilt;next} filter g } oo::class create Emix { superclass C method m {} {lappend ::result Emix;next} method f {} {lappend ::result Emix-filt;next} } oo::class create Fmix { superclass Emix method m {} {lappend ::result Fmix;next} } D create o oo::define o { method m {} {lappend ::result o;next} mixin Fmix filter f } set result {} o m return $result } -cleanup { A destroy } -result {Emix-filt B-filt D-cfilt B-cfilt Fmix Emix o D B C A} cleanupTests return # Local Variables: # mode: tcl # End: |
Changes to unix/Makefile.in.
1 2 3 4 5 6 7 | # # This file is a Makefile for Tcl. If it has the name "Makefile.in" # then it is a template for a Makefile; to generate the actual Makefile, # run "./configure", which is a configuration script generated by the # "autoconf" program (constructs like "@foo@" will get replaced in the # actual Makefile. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | # # This file is a Makefile for Tcl. If it has the name "Makefile.in" # then it is a template for a Makefile; to generate the actual Makefile, # run "./configure", which is a configuration script generated by the # "autoconf" program (constructs like "@foo@" will get replaced in the # actual Makefile. # # RCS: @(#) $Id: Makefile.in,v 1.183.2.7 2006/10/11 01:59:27 dgp Exp $ VERSION = @TCL_VERSION@ MAJOR_VERSION = @TCL_MAJOR_VERSION@ MINOR_VERSION = @TCL_MINOR_VERSION@ PATCH_LEVEL = @TCL_PATCH_LEVEL@ #---------------------------------------------------------------- |
︙ | ︙ | |||
300 301 302 303 304 305 306 | GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ tclAsync.o tclBasic.o tclBinary.o tclCkalloc.o tclClock.o \ tclCmdAH.o tclCmdIL.o tclCmdMZ.o tclCompCmds.o tclCompExpr.o \ tclCompile.o tclConfig.o tclDate.o tclDictObj.o tclEncoding.o \ tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \ tclHash.o tclHistory.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \ tclIORChan.o tclIOGT.o tclIOSock.o tclIOUtil.o tclLink.o tclListObj.o \ | | > | | | 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 | GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ tclAsync.o tclBasic.o tclBinary.o tclCkalloc.o tclClock.o \ tclCmdAH.o tclCmdIL.o tclCmdMZ.o tclCompCmds.o tclCompExpr.o \ tclCompile.o tclConfig.o tclDate.o tclDictObj.o tclEncoding.o \ tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \ tclHash.o tclHistory.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \ tclIORChan.o tclIOGT.o tclIOSock.o tclIOUtil.o tclLink.o tclListObj.o \ tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o tclObj.o \ tclOO.o tclOOCall.o tclOODefineCmds.o tclOOInfo.o tclPanic.o \ tclParse.o tclParseExpr.o tclPathObj.o \ tclPipe.o tclPkg.o tclPkgConfig.o tclPosixStr.o \ tclPreserve.o tclProc.o tclRegexp.o \ tclResolve.o tclResult.o tclScan.o tclStringObj.o \ tclStrToD.o tclThread.o \ tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \ tclStubLib.o tclTimer.o tclTrace.o tclUtf.o tclUtil.o tclVar.o \ tclTomMathInterface.o |
︙ | ︙ | |||
400 401 402 403 404 405 406 407 408 409 410 411 412 413 | $(GENERIC_DIR)/tclListObj.c \ $(GENERIC_DIR)/tclLiteral.c \ $(GENERIC_DIR)/tclLoad.c \ $(GENERIC_DIR)/tclMain.c \ $(GENERIC_DIR)/tclNamesp.c \ $(GENERIC_DIR)/tclNotify.c \ $(GENERIC_DIR)/tclObj.c \ $(GENERIC_DIR)/tclParse.c \ $(GENERIC_DIR)/tclParseExpr.c \ $(GENERIC_DIR)/tclPathObj.c \ $(GENERIC_DIR)/tclPipe.c \ $(GENERIC_DIR)/tclPkg.c \ $(GENERIC_DIR)/tclPkgConfig.c \ $(GENERIC_DIR)/tclPosixStr.c \ | > > > > | 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 | $(GENERIC_DIR)/tclListObj.c \ $(GENERIC_DIR)/tclLiteral.c \ $(GENERIC_DIR)/tclLoad.c \ $(GENERIC_DIR)/tclMain.c \ $(GENERIC_DIR)/tclNamesp.c \ $(GENERIC_DIR)/tclNotify.c \ $(GENERIC_DIR)/tclObj.c \ $(GENERIC_DIR)/tclOO.c \ $(GENERIC_DIR)/tclOOCall.c \ $(GENERIC_DIR)/tclOODefineCmds.c \ $(GENERIC_DIR)/tclOOInfo.c \ $(GENERIC_DIR)/tclParse.c \ $(GENERIC_DIR)/tclParseExpr.c \ $(GENERIC_DIR)/tclPathObj.c \ $(GENERIC_DIR)/tclPipe.c \ $(GENERIC_DIR)/tclPkg.c \ $(GENERIC_DIR)/tclPkgConfig.c \ $(GENERIC_DIR)/tclPosixStr.c \ |
︙ | ︙ | |||
928 929 930 931 932 933 934 935 936 937 938 939 940 941 | REGHDRS=$(GENERIC_DIR)/regex.h $(GENERIC_DIR)/regguts.h \ $(GENERIC_DIR)/regcustom.h TCLREHDRS=$(GENERIC_DIR)/tclRegexp.h COMPILEHDR=$(GENERIC_DIR)/tclCompile.h FSHDR=$(GENERIC_DIR)/tclFileSystem.h IOHDR=$(GENERIC_DIR)/tclIO.h MATHHDRS=$(GENERIC_DIR)/tommath.h $(GENERIC_DIR)/tclTomMath.h regcomp.o: $(REGHDRS) $(GENERIC_DIR)/regcomp.c $(GENERIC_DIR)/regc_lex.c \ $(GENERIC_DIR)/regc_color.c $(GENERIC_DIR)/regc_locale.c \ $(GENERIC_DIR)/regc_nfa.c $(GENERIC_DIR)/regc_cvec.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/regcomp.c | > | 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 | REGHDRS=$(GENERIC_DIR)/regex.h $(GENERIC_DIR)/regguts.h \ $(GENERIC_DIR)/regcustom.h TCLREHDRS=$(GENERIC_DIR)/tclRegexp.h COMPILEHDR=$(GENERIC_DIR)/tclCompile.h FSHDR=$(GENERIC_DIR)/tclFileSystem.h IOHDR=$(GENERIC_DIR)/tclIO.h OOHDR=$(GENERIC_DIR)/tclOO.h MATHHDRS=$(GENERIC_DIR)/tommath.h $(GENERIC_DIR)/tclTomMath.h regcomp.o: $(REGHDRS) $(GENERIC_DIR)/regcomp.c $(GENERIC_DIR)/regc_lex.c \ $(GENERIC_DIR)/regc_color.c $(GENERIC_DIR)/regc_locale.c \ $(GENERIC_DIR)/regc_nfa.c $(GENERIC_DIR)/regc_cvec.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/regcomp.c |
︙ | ︙ | |||
1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 | tclLiteral.o: $(GENERIC_DIR)/tclLiteral.c $(COMPILEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLiteral.c tclObj.o: $(GENERIC_DIR)/tclObj.c $(COMPILEHDR) $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclObj.c tclLoad.o: $(GENERIC_DIR)/tclLoad.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLoad.c tclLoadAix.o: $(UNIX_DIR)/tclLoadAix.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadAix.c tclLoadDl.o: $(UNIX_DIR)/tclLoadDl.c | > > > > > > > > > > > > | 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 | tclLiteral.o: $(GENERIC_DIR)/tclLiteral.c $(COMPILEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLiteral.c tclObj.o: $(GENERIC_DIR)/tclObj.c $(COMPILEHDR) $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclObj.c tclOO.o: $(GENERIC_DIR)/tclOO.c $(OOHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOO.c tclOOCall.o: $(GENERIC_DIR)/tclOOCall.c $(OOHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOCall.c tclOODefineCmds.o: $(GENERIC_DIR)/tclOODefineCmds.c $(OOHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOODefineCmds.c tclOOInfo.o: $(GENERIC_DIR)/tclOOInfo.c $(OOHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOInfo.c tclLoad.o: $(GENERIC_DIR)/tclLoad.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLoad.c tclLoadAix.o: $(UNIX_DIR)/tclLoadAix.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadAix.c tclLoadDl.o: $(UNIX_DIR)/tclLoadDl.c |
︙ | ︙ |
Changes to win/Makefile.in.
1 2 3 4 5 6 7 | # # This file is a Makefile for Tcl. If it has the name "Makefile.in" # then it is a template for a Makefile; to generate the actual Makefile, # run "./configure", which is a configuration script generated by the # "autoconf" program (constructs like "@foo@" will get replaced in the # actual Makefile. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | # # This file is a Makefile for Tcl. If it has the name "Makefile.in" # then it is a template for a Makefile; to generate the actual Makefile, # run "./configure", which is a configuration script generated by the # "autoconf" program (constructs like "@foo@" will get replaced in the # actual Makefile. # # RCS: @(#) $Id: Makefile.in,v 1.96.2.7 2006/10/08 17:14:33 dkf Exp $ VERSION = @TCL_VERSION@ #---------------------------------------------------------------- # Things you can change to personalize the Makefile for your own # site (you can make these changes in either Makefile.in or # Makefile, but changes to Makefile will get lost if you re-run |
︙ | ︙ | |||
249 250 251 252 253 254 255 256 257 258 259 260 261 262 | tclLiteral.$(OBJEXT) \ tclListObj.$(OBJEXT) \ tclLoad.$(OBJEXT) \ tclMain.$(OBJEXT) \ tclNamesp.$(OBJEXT) \ tclNotify.$(OBJEXT) \ tclObj.$(OBJEXT) \ tclPanic.$(OBJEXT) \ tclParse.$(OBJEXT) \ tclParseExpr.$(OBJEXT) \ tclPathObj.$(OBJEXT) \ tclPipe.$(OBJEXT) \ tclPkg.$(OBJEXT) \ tclPkgConfig.$(OBJEXT) \ | > > > > | 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 | tclLiteral.$(OBJEXT) \ tclListObj.$(OBJEXT) \ tclLoad.$(OBJEXT) \ tclMain.$(OBJEXT) \ tclNamesp.$(OBJEXT) \ tclNotify.$(OBJEXT) \ tclObj.$(OBJEXT) \ tclOO.$(OBJEXT) \ tclOOCall.$(OBJEXT) \ tclOODefineCmds.$(OBJEXT) \ tclOOInfo.$(OBJEXT) \ tclPanic.$(OBJEXT) \ tclParse.$(OBJEXT) \ tclParseExpr.$(OBJEXT) \ tclPathObj.$(OBJEXT) \ tclPipe.$(OBJEXT) \ tclPkg.$(OBJEXT) \ tclPkgConfig.$(OBJEXT) \ |
︙ | ︙ | |||
380 381 382 383 384 385 386 387 388 389 390 391 392 393 | TCL_DOCS = "$(ROOT_DIR_NATIVE)"/doc/*.[13n] all: binaries libraries doc tcltest: $(TCLTEST) binaries: @LIBRARIES@ $(TCLSH) libraries: doc: winhelp: $(ROOT_DIR)/tools/man2help.tcl $(MAN2TCL) TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ | > > > > | 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 | TCL_DOCS = "$(ROOT_DIR_NATIVE)"/doc/*.[13n] all: binaries libraries doc tcltest: $(TCLTEST) binaries: @LIBRARIES@ $(TCLSH) # Special dependencies to make development easier tclOO.$(OBJEXT) tclOOCall.$(OBJEXT) tclOODefineCmds.$(OBJEXT) tclOOInfo.$(OBJEXT) tclProc.$(OBJEXT): \ $(GENERIC_DIR)/tclOO.h libraries: doc: winhelp: $(ROOT_DIR)/tools/man2help.tcl $(MAN2TCL) TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ |
︙ | ︙ | |||
713 714 715 716 717 718 719 | shell: binaries @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ ./$(TCLSH) $(SCRIPT) # This target can be used to run tclsh inside either gdb or insight gdb: binaries @echo "set env TCL_LIBRARY=$(LIBRARY_DIR)" > gdb.run | | | 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 | shell: binaries @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ ./$(TCLSH) $(SCRIPT) # This target can be used to run tclsh inside either gdb or insight gdb: binaries @echo "set env TCL_LIBRARY=$(LIBRARY_DIR)" > gdb.run gdb ./$(TCLSH) --command=gdb.run rm gdb.run depend: Makefile: $(SRC_DIR)/Makefile.in ./config.status |
︙ | ︙ |
Changes to win/makefile.bc.
︙ | ︙ | |||
230 231 232 233 234 235 236 237 238 239 240 241 242 243 | $(TMPDIR)\tclLiteral.obj \ $(TMPDIR)\tclListObj.obj \ $(TMPDIR)\tclLoad.obj \ $(TMPDIR)\tclMain.obj \ $(TMPDIR)\tclNamesp.obj \ $(TMPDIR)\tclNotify.obj \ $(TMPDIR)\tclObj.obj \ $(TMPDIR)\tclPanic.obj \ $(TMPDIR)\tclParse.obj \ $(TMPDIR)\tclParseExpr.obj \ $(TMPDIR)\tclPipe.obj \ $(TMPDIR)\tclPkg.obj \ $(TMPDIR)\tclPkgConfig.obj \ $(TMPDIR)\tclPosixStr.obj \ | > > > > | 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 | $(TMPDIR)\tclLiteral.obj \ $(TMPDIR)\tclListObj.obj \ $(TMPDIR)\tclLoad.obj \ $(TMPDIR)\tclMain.obj \ $(TMPDIR)\tclNamesp.obj \ $(TMPDIR)\tclNotify.obj \ $(TMPDIR)\tclObj.obj \ $(TMPDIR)\tclOO.obj \ $(TMPDIR)\tclOOCall.obj \ $(TMPDIR)\tclOODefineCmds.obj \ $(TMPDIR)\tclOOInfo.obj \ $(TMPDIR)\tclPanic.obj \ $(TMPDIR)\tclParse.obj \ $(TMPDIR)\tclParseExpr.obj \ $(TMPDIR)\tclPipe.obj \ $(TMPDIR)\tclPkg.obj \ $(TMPDIR)\tclPkgConfig.obj \ $(TMPDIR)\tclPosixStr.obj \ |
︙ | ︙ |
Changes to win/makefile.vc.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 Ajuba Solutions. # Copyright (c) 2001-2005 ActiveState Corporation. # Copyright (c) 2001-2004 David Gravereaux. # #------------------------------------------------------------------------------ | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 Ajuba Solutions. # Copyright (c) 2001-2005 ActiveState Corporation. # Copyright (c) 2001-2004 David Gravereaux. # #------------------------------------------------------------------------------ # RCS: @(#) $Id: makefile.vc,v 1.143.2.4 2006/10/08 17:14:33 dkf Exp $ #------------------------------------------------------------------------------ # Check to see we are configured to build with MSVC (MSDEVDIR or MSVCDIR) # or with the MS Platform SDK (MSSDK). Visual Studio .NET 2003 and 2005 define # VCINSTALLDIR instead. !if !defined(MSDEVDIR) && !defined(MSVCDIR) && !defined(MSSDK) && !defined(VCINSTALLDIR) MSG = ^ |
︙ | ︙ | |||
290 291 292 293 294 295 296 297 298 299 300 301 302 303 | $(TMP_DIR)\tclListObj.obj \ $(TMP_DIR)\tclLiteral.obj \ $(TMP_DIR)\tclLoad.obj \ $(TMP_DIR)\tclMain.obj \ $(TMP_DIR)\tclNamesp.obj \ $(TMP_DIR)\tclNotify.obj \ $(TMP_DIR)\tclObj.obj \ $(TMP_DIR)\tclPanic.obj \ $(TMP_DIR)\tclParse.obj \ $(TMP_DIR)\tclParseExpr.obj \ $(TMP_DIR)\tclPathObj.obj \ $(TMP_DIR)\tclPipe.obj \ $(TMP_DIR)\tclPkg.obj \ $(TMP_DIR)\tclPkgConfig.obj \ | > > > > | 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 | $(TMP_DIR)\tclListObj.obj \ $(TMP_DIR)\tclLiteral.obj \ $(TMP_DIR)\tclLoad.obj \ $(TMP_DIR)\tclMain.obj \ $(TMP_DIR)\tclNamesp.obj \ $(TMP_DIR)\tclNotify.obj \ $(TMP_DIR)\tclObj.obj \ $(TMP_DIR)\tclOO.obj \ $(TMP_DIR)\tclOOCall.obj \ $(TMP_DIR)\tclOODefineCmds.obj \ $(TMP_DIR)\tclOOInfo.obj \ $(TMP_DIR)\tclPanic.obj \ $(TMP_DIR)\tclParse.obj \ $(TMP_DIR)\tclParseExpr.obj \ $(TMP_DIR)\tclPathObj.obj \ $(TMP_DIR)\tclPipe.obj \ $(TMP_DIR)\tclPkg.obj \ $(TMP_DIR)\tclPkgConfig.obj \ |
︙ | ︙ |