/[dtapublic]/projs/ets/trunk/src/c_tcl_base_7_5_w_mods/tclstublib.c
ViewVC logotype

Diff of /projs/ets/trunk/src/c_tcl_base_7_5_w_mods/tclstublib.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 70 by dashley, Sun Oct 30 21:57:38 2016 UTC revision 71 by dashley, Sat Nov 5 11:07:06 2016 UTC
# Line 1  Line 1 
1  /* $Header$ */  /* $Header$ */
2  /*  /*
3   * tclStubLib.c --   * tclStubLib.c --
4   *   *
5   *      Stub object that will be statically linked into extensions that wish   *      Stub object that will be statically linked into extensions that wish
6   *      to access Tcl.   *      to access Tcl.
7   *   *
8   * Copyright (c) 1998-1999 by Scriptics Corporation.   * Copyright (c) 1998-1999 by Scriptics Corporation.
9   * Copyright (c) 1998 Paul Duffin.   * Copyright (c) 1998 Paul Duffin.
10   *   *
11   * See the file "license.terms" for information on usage and redistribution   * See the file "license.terms" for information on usage and redistribution
12   * of this file, and for a DISCLAIMER OF ALL WARRANTIES.   * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13   *   *
14   * RCS: @(#) $Id: tclstublib.c,v 1.1.1.1 2001/06/13 04:46:23 dtashley Exp $   * RCS: @(#) $Id: tclstublib.c,v 1.1.1.1 2001/06/13 04:46:23 dtashley Exp $
15   */   */
16    
17  /*  /*
18   * We need to ensure that we use the stub macros so that this file contains   * We need to ensure that we use the stub macros so that this file contains
19   * no references to any of the stub functions.  This will make it possible   * no references to any of the stub functions.  This will make it possible
20   * to build an extension that references Tcl_InitStubs but doesn't end up   * to build an extension that references Tcl_InitStubs but doesn't end up
21   * including the rest of the stub functions.   * including the rest of the stub functions.
22   */   */
23    
24  #ifndef USE_TCL_STUBS  #ifndef USE_TCL_STUBS
25  #define USE_TCL_STUBS  #define USE_TCL_STUBS
26  #endif  #endif
27  #undef USE_TCL_STUB_PROCS  #undef USE_TCL_STUB_PROCS
28    
29  #include "tclInt.h"  #include "tclInt.h"
30  #include "tclPort.h"  #include "tclPort.h"
31    
32  /*  /*
33   * Ensure that Tcl_InitStubs is built as an exported symbol.  The other stub   * Ensure that Tcl_InitStubs is built as an exported symbol.  The other stub
34   * functions should be built as non-exported symbols.   * functions should be built as non-exported symbols.
35   */   */
36    
37  #undef TCL_STORAGE_CLASS  #undef TCL_STORAGE_CLASS
38  #define TCL_STORAGE_CLASS DLLEXPORT  #define TCL_STORAGE_CLASS DLLEXPORT
39    
40  TclStubs *tclStubsPtr;  TclStubs *tclStubsPtr;
41  TclPlatStubs *tclPlatStubsPtr;  TclPlatStubs *tclPlatStubsPtr;
42  TclIntStubs *tclIntStubsPtr;  TclIntStubs *tclIntStubsPtr;
43  TclIntPlatStubs *tclIntPlatStubsPtr;  TclIntPlatStubs *tclIntPlatStubsPtr;
44    
45  static TclStubs *       HasStubSupport _ANSI_ARGS_((Tcl_Interp *interp));  static TclStubs *       HasStubSupport _ANSI_ARGS_((Tcl_Interp *interp));
46    
47  static TclStubs *  static TclStubs *
48  HasStubSupport (interp)  HasStubSupport (interp)
49      Tcl_Interp *interp;      Tcl_Interp *interp;
50  {  {
51      Interp *iPtr = (Interp *) interp;      Interp *iPtr = (Interp *) interp;
52    
53      if (iPtr->stubTable && (iPtr->stubTable->magic == TCL_STUB_MAGIC)) {      if (iPtr->stubTable && (iPtr->stubTable->magic == TCL_STUB_MAGIC)) {
54          return iPtr->stubTable;          return iPtr->stubTable;
55      }      }
56      interp->result = "This interpreter does not support stubs-enabled extensions.";      interp->result = "This interpreter does not support stubs-enabled extensions.";
57      interp->freeProc = TCL_STATIC;      interp->freeProc = TCL_STATIC;
58    
59      return NULL;      return NULL;
60  }  }
61    
62  /*  /*
63   *----------------------------------------------------------------------   *----------------------------------------------------------------------
64   *   *
65   * Tcl_InitStubs --   * Tcl_InitStubs --
66   *   *
67   *      Tries to initialise the stub table pointers and ensures that   *      Tries to initialise the stub table pointers and ensures that
68   *      the correct version of Tcl is loaded.   *      the correct version of Tcl is loaded.
69   *   *
70   * Results:   * Results:
71   *      The actual version of Tcl that satisfies the request, or   *      The actual version of Tcl that satisfies the request, or
72   *      NULL to indicate that an error occurred.   *      NULL to indicate that an error occurred.
73   *   *
74   * Side effects:   * Side effects:
75   *      Sets the stub table pointers.   *      Sets the stub table pointers.
76   *   *
77   *----------------------------------------------------------------------   *----------------------------------------------------------------------
78   */   */
79    
80  #ifdef Tcl_InitStubs  #ifdef Tcl_InitStubs
81  #undef Tcl_InitStubs  #undef Tcl_InitStubs
82  #endif  #endif
83    
84  char *  char *
85  Tcl_InitStubs (interp, version, exact)  Tcl_InitStubs (interp, version, exact)
86      Tcl_Interp *interp;      Tcl_Interp *interp;
87      char *version;      char *version;
88      int exact;      int exact;
89  {  {
90      char *actualVersion;      char *actualVersion;
91      TclStubs *tmp;      TclStubs *tmp;
92            
93      if (!tclStubsPtr) {      if (!tclStubsPtr) {
94          tclStubsPtr = HasStubSupport(interp);          tclStubsPtr = HasStubSupport(interp);
95          if (!tclStubsPtr) {          if (!tclStubsPtr) {
96              return NULL;              return NULL;
97          }          }
98      }      }
99    
100      actualVersion = Tcl_PkgRequireEx(interp, "Tcl", version, exact,      actualVersion = Tcl_PkgRequireEx(interp, "Tcl", version, exact,
101              (ClientData *) &tmp);              (ClientData *) &tmp);
102      if (actualVersion == NULL) {      if (actualVersion == NULL) {
103          tclStubsPtr = NULL;          tclStubsPtr = NULL;
104          return NULL;          return NULL;
105      }      }
106    
107      if (tclStubsPtr->hooks) {      if (tclStubsPtr->hooks) {
108          tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs;          tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs;
109          tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs;          tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs;
110          tclIntPlatStubsPtr = tclStubsPtr->hooks->tclIntPlatStubs;          tclIntPlatStubsPtr = tclStubsPtr->hooks->tclIntPlatStubs;
111      } else {      } else {
112          tclPlatStubsPtr = NULL;          tclPlatStubsPtr = NULL;
113          tclIntStubsPtr = NULL;          tclIntStubsPtr = NULL;
114          tclIntPlatStubsPtr = NULL;          tclIntPlatStubsPtr = NULL;
115      }      }
116            
117      return actualVersion;      return actualVersion;
118  }  }
119    
120  /* End of tclstublib.c */  /* End of tclstublib.c */
Legend:
Removed from v.70  
changed lines
  Added in v.71
dashley@gmail.com
 ViewVC Help
Powered by ViewVC 1.1.25