1 |
/* ASCEND modelling environment |
2 |
Copyright 1997, Carnegie Mellon University |
3 |
Copyright (C) 2006 Carnegie Mellon University |
4 |
|
5 |
This program is free software; you can redistribute it and/or modify |
6 |
it under the terms of the GNU General Public License as published by |
7 |
the Free Software Foundation; either version 2, or (at your option) |
8 |
any later version. |
9 |
|
10 |
This program is distributed in the hope that it will be useful, |
11 |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
12 |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
13 |
GNU General Public License for more details. |
14 |
|
15 |
You should have received a copy of the GNU General Public License |
16 |
along with this program; if not, write to the Free Software |
17 |
Foundation, Inc., 59 Temple Place - Suite 330, |
18 |
Boston, MA 02111-1307, USA. |
19 |
*//* |
20 |
Driver.c |
21 |
by Kirk Abbott and Ben Allan |
22 |
Created: 1/94 |
23 |
Version: $Revision: 1.48 $ |
24 |
Version control file: $RCSfile: Driver.c,v $ |
25 |
Date last modified: $Date: 2003/08/23 18:43:06 $ |
26 |
Last modified by: $Author: ballan $ |
27 |
*/ |
28 |
|
29 |
#include <stdarg.h> |
30 |
#include <ctype.h> |
31 |
#include <signal.h> |
32 |
#include <time.h> |
33 |
#include <tcl.h> |
34 |
#include <tk.h> |
35 |
#include <utilities/ascConfig.h> |
36 |
|
37 |
#ifndef __WIN32__ |
38 |
# include <unistd.h> |
39 |
#else |
40 |
|
41 |
/* jds20041229 - windows.h now included in ascConfig.h. */ |
42 |
/* jp - i took it back out of ascConfig.h - Apr 2005 */ |
43 |
# define WIN32_LEAN_AND_MEAN |
44 |
# include <windows.h> |
45 |
|
46 |
# include <locale.h> |
47 |
# include "tkConsole.h" |
48 |
# undef WIN32_LEAN_AND_MEAN |
49 |
#endif /* __WIN32__ */ |
50 |
|
51 |
#include <utilities/config.h> |
52 |
#include <utilities/ascMalloc.h> /* for ascshutdown */ |
53 |
#include <utilities/ascPanic.h> /* for Asc_Panic */ |
54 |
#include <utilities/ascEnvVar.h> |
55 |
#include <compiler/compiler.h> |
56 |
#include <compiler/ascCompiler.h> |
57 |
#include <compiler/instance_enum.h> |
58 |
#include <compiler/fractions.h> |
59 |
#include <compiler/dimen.h> |
60 |
#include <compiler/compiler.h> /* for symchar for units.h */ |
61 |
#include <compiler/units.h> |
62 |
#include <compiler/redirectFile.h> /* for Asc_RedirectCompilerDefault() */ |
63 |
#include <solver/slv_types.h> |
64 |
#include <solver/var.h> |
65 |
#include <solver/rel.h> |
66 |
#include <solver/logrel.h> |
67 |
#include <solver/discrete.h> |
68 |
#include <solver/mtx.h> |
69 |
#include <solver/slv_stdcalls.h> |
70 |
#include "AscBitmaps.h" |
71 |
#include <utilities/ascPrint.h> |
72 |
#include "AscPrintTcl.h" |
73 |
#include "HelpProc.h" |
74 |
#include "Commands.h" |
75 |
#include "Driver.h" |
76 |
#include "ScriptProc.h" |
77 |
#include "SolverProc.h" |
78 |
#include "UnitsProc.h" |
79 |
|
80 |
#ifndef lint |
81 |
static CONST char DriverID[] = "$Id: Driver.c,v 1.48 2003/08/23 18:43:06 ballan Exp $"; |
82 |
#endif |
83 |
|
84 |
/* |
85 |
* EXPORTED VARIABLES |
86 |
*/ |
87 |
|
88 |
/** |
89 |
* g_compiler_timing |
90 |
* |
91 |
* TRUE if compiler timing is to be printed. |
92 |
* default is false, set to TRUE by passing -t on the command line |
93 |
*/ |
94 |
/* int g_compiler_timing = 0; */ |
95 |
/* moved to compiler/simlist.c */ |
96 |
|
97 |
/** |
98 |
* g_interp |
99 |
* |
100 |
* Interpreter for this application. We need to make it global |
101 |
* so that our signal/floating-porint traps can access it. |
102 |
*/ |
103 |
Tcl_Interp *g_interp; |
104 |
|
105 |
/* |
106 |
* zz_debug |
107 |
* |
108 |
* Comes from the yacc file if yacc was built with debugging information |
109 |
*/ |
110 |
#ifdef ZZ_DEBUG |
111 |
extern int zz_debug; |
112 |
#endif |
113 |
|
114 |
|
115 |
/* |
116 |
* Declarations for procedures defined outside of this file. |
117 |
*/ |
118 |
extern int Tktable_Init(Tcl_Interp*); |
119 |
|
120 |
static void AscTrap(int); |
121 |
static int AscCheckEnvironVars(Tcl_Interp*); |
122 |
static void AscPrintHelpExit(CONST char *); |
123 |
static int AscProcessCommandLine(Tcl_Interp*, int, CONST char **); |
124 |
static void Prompt(Tcl_Interp*, int); |
125 |
static int AscSetStartupFile(Tcl_Interp*); |
126 |
static void StdinProc(ClientData, int); |
127 |
#ifdef DEBUG_MALLOC |
128 |
static void InitDebugMalloc(void); |
129 |
#endif /* DEBUG_MALLOC */ |
130 |
|
131 |
|
132 |
|
133 |
/* |
134 |
* LOCALLY GLOBAL VARIABLES |
135 |
*/ |
136 |
|
137 |
/* |
138 |
* g_interface_simplify_relations |
139 |
* |
140 |
* TRUE for compiler optimizations |
141 |
* default is TRUE, set to FALSE by passing +s on the command line |
142 |
*/ |
143 |
static int g_interface_simplify_relations = TRUE; |
144 |
|
145 |
/* |
146 |
* g_interfacever |
147 |
* |
148 |
* TRUE if windows to be built; default is TRUE, false is not supported |
149 |
*/ |
150 |
static int g_interfacever = 1; |
151 |
|
152 |
/* |
153 |
* g_command |
154 |
* |
155 |
* Used to assemble lines of terminal input into Tcl commands. |
156 |
*/ |
157 |
static Tcl_DString g_command; |
158 |
|
159 |
/* |
160 |
* g_line |
161 |
* |
162 |
* Used to read the next line from the terminal input. |
163 |
*/ |
164 |
static Tcl_DString g_line; |
165 |
|
166 |
/* |
167 |
* tty |
168 |
* |
169 |
* Non-zero means standard input is a terminal-like device. |
170 |
* Zero means it's a file. |
171 |
*/ |
172 |
static int tty; |
173 |
|
174 |
/* |
175 |
* initScriptTclAdjust |
176 |
* initScriptTkAdjust |
177 |
* |
178 |
* These two variables hold Tcl scripts that will set the TCL_LIBRARY |
179 |
* and TK_LIBRARY environment variables if they are not already |
180 |
* set in the user's environment. |
181 |
* TCL_LIBRARY is set to: dirnameofexecutable/../../Tcl/lib/tcl8.0 |
182 |
* TK_LIBRARY is set to $tcl_library/../tk8.0 |
183 |
*/ |
184 |
static char initScriptTclAdjust[] = |
185 |
"proc asc_tclInit {} {\n\ |
186 |
global env\n\ |
187 |
rename asc_tclInit {}\n\ |
188 |
set errors {}\n\ |
189 |
set dirs {}\n\ |
190 |
if [info exists env(TCL_LIBRARY)] {\n\ |
191 |
return\n\ |
192 |
} else {\n\ |
193 |
set parentDir [file dirname [info nameofexecutable]]\n\ |
194 |
set env(TCL_LIBRARY) $parentDir/../../Tcl/lib/tcl8.0\n\ |
195 |
}\n\ |
196 |
}\n\ |
197 |
asc_tclInit"; |
198 |
/* for tcl, FOO/ascend4/bin/ascend4.exe is the executable, then |
199 |
* /-- up to FOO/ascend4/bin |
200 |
* set parentDir [file dirname [info nameofexecutable]]\n\ |
201 |
* Then if Tcl is next to ascend4, ../../Tcl/lib/tcl8.0 should work. |
202 |
*/ |
203 |
|
204 |
static char initScriptTkAdjust[] = |
205 |
"proc asc_tkInit {} {\n\ |
206 |
global env\n\ |
207 |
rename asc_tkInit {}\n\ |
208 |
set errors {}\n\ |
209 |
set dirs {}\n\ |
210 |
if [info exists env(TK_LIBRARY)] {\n\ |
211 |
return\n\ |
212 |
} else {\n\ |
213 |
set parentDir [file dirname [info library]]\n\ |
214 |
set env(TK_LIBRARY) $parentDir/tk8.0\n\ |
215 |
}\n\ |
216 |
}\n\ |
217 |
asc_tkInit"; |
218 |
/* |
219 |
* This assumes tcl_library has been found and that tcl8.0 and tk8.0 |
220 |
* are installed in the same lib directory -- the default tcl/tk install. |
221 |
*/ |
222 |
|
223 |
/* |
224 |
* build_name |
225 |
* |
226 |
* who built this binary and when |
227 |
*/ |
228 |
#ifndef TIMESTAMP |
229 |
static char build_name[]="by anonymous"; |
230 |
#else |
231 |
static char build_name[]=TIMESTAMP; |
232 |
#endif /* TIMESTAMP */ |
233 |
|
234 |
|
235 |
/** |
236 |
Moved 'main' and 'WinMain' to separate 'main.c' |
237 |
so that ascend4.exe can be built without linkage to Tcl/Tk |
238 |
*/ |
239 |
|
240 |
|
241 |
/* |
242 |
* int AscDriver( argc, argv ) |
243 |
* int argc; |
244 |
* char *argv; |
245 |
* |
246 |
* A common entry point for Windows and Unix. The corresponding |
247 |
* WinMain() and main() functions just call this function. |
248 |
* |
249 |
* This function creates a Tcl interpreter, initializes Tcl and Tk, |
250 |
* initializes the Ascend data structures, sets up the user's |
251 |
* environment, sources ASCEND's startup script, and calls Tk_MainLoop |
252 |
* so the user can interact with ASCEND. Cleans up and exits the |
253 |
* program when Tk_MainLoop returns. |
254 |
* |
255 |
* This function is based on the functions Tk_Main and Tcl_AppInit |
256 |
* from the Tk8.0 distribution. See the files tkMain.c and tkAppInit.c |
257 |
* in the Tk sources. |
258 |
* |
259 |
*/ |
260 |
int AscDriver(int argc, CONST char *argv[]) |
261 |
{ |
262 |
Tcl_Interp *interp; /* local version of global g_interp */ |
263 |
Tcl_Channel inChannel; |
264 |
Tcl_Channel outChannel; |
265 |
|
266 |
/* jds20050119: Initialize ASCERR before any calls to ascPanic(). */ |
267 |
/* TODO: revisit when interface is decoupled from base - this may change. */ |
268 |
Asc_RedirectCompilerDefault(); |
269 |
#ifdef USE_ASC_PRINTF |
270 |
Asc_PrintInit_TclVtable(); |
271 |
#endif /* USE_ASC_PRINTF */ |
272 |
/* |
273 |
* Create the Tk Console |
274 |
* |
275 |
* Create the console channels and install them as the standard |
276 |
* channels. All I/O will be discarded until TkConsoleInit() is |
277 |
* called to attach the console to a text widget. |
278 |
*/ |
279 |
#ifdef ASC_USE_TK_CONSOLE |
280 |
TkConsoleCreate(); |
281 |
#endif /* ASC_USE_TK_CONSOLE */ |
282 |
|
283 |
/* |
284 |
* Find the name of the current executable---available in the |
285 |
* Tcl command `info nameofexecutable' |
286 |
*/ |
287 |
Tcl_FindExecutable(argv[0]); |
288 |
|
289 |
/* |
290 |
* Create the interpreter |
291 |
*/ |
292 |
g_interp = Tcl_CreateInterp(); |
293 |
interp = g_interp; |
294 |
if( interp == NULL ) { |
295 |
Asc_Panic(2, "Asc_Driver", |
296 |
"Call to Tcl_CreateInterp returned NULL interpreter"); |
297 |
} |
298 |
|
299 |
/* |
300 |
* Check the arguments on the command line |
301 |
*/ |
302 |
AscProcessCommandLine(interp, argc, argv); |
303 |
|
304 |
/* |
305 |
* Set the "tcl_interactive" variable. |
306 |
* |
307 |
* ASCEND sets tty to `1', since we assume ASCEND is always interactive. |
308 |
*/ |
309 |
tty = 1; |
310 |
Tcl_SetVar(interp, "tcl_interactive", "1", TCL_GLOBAL_ONLY); |
311 |
|
312 |
/* |
313 |
* Initialize Tcl and Tk |
314 |
*/ |
315 |
(void)Tcl_Eval(interp,initScriptTclAdjust); |
316 |
if (Tcl_Init(interp) == TCL_ERROR) { |
317 |
Asc_Panic(2, "Asc_Driver", "Tcl initialization failed:\n%s", |
318 |
Tcl_GetStringResult(interp)); |
319 |
} |
320 |
(void)Tcl_Eval(interp,initScriptTkAdjust); |
321 |
if (Tk_Init(interp) == TCL_ERROR) { |
322 |
Asc_Panic(2, "Asc_Driver", "Tk initialization failed:\n%s", |
323 |
Tcl_GetStringResult(interp)); |
324 |
} |
325 |
Tcl_StaticPackage( interp, "Tk", Tk_Init, Tk_SafeInit ); |
326 |
|
327 |
/* |
328 |
* Initialize the console and the ASCEND printf() substitutes. |
329 |
* All output before this point is lost. |
330 |
*/ |
331 |
#ifdef ASC_USE_TK_CONSOLE |
332 |
if (TkConsoleInit(interp) == TCL_ERROR) { |
333 |
Asc_Panic(2, "Asc_Driver", |
334 |
"Call to TkConsoleInit failed:\n%s", |
335 |
Tcl_GetStringResult(interp)); |
336 |
} |
337 |
#endif /* ASC_USE_TK_CONSOLE */ |
338 |
#ifdef USE_ASC_PRINTF |
339 |
Asc_PrintInit_Tcl(); |
340 |
#endif /* USE_ASC_PRINTF */ |
341 |
|
342 |
/* |
343 |
* Now that our console and printing functions are properly |
344 |
* initialized, print our startup banner. |
345 |
*/ |
346 |
PRINTF("ASCEND VERSION IV\n"); |
347 |
PRINTF("Compiler Implemention Version: 2.0\n"); |
348 |
PRINTF("Written by Tom Epperly, Kirk Abbott, and Ben Allan\n"); |
349 |
PRINTF(" Built: %s %s %s\n",__DATE__,__TIME__,build_name); |
350 |
PRINTF("Copyright(C) 1990, 1993, 1994 Thomas Guthrie Epperly\n"); |
351 |
PRINTF("Copyright(C) 1993-1996 Kirk Andre Abbott, Ben Allan\n"); |
352 |
PRINTF("Copyright(C) 1997 Carnegie Mellon University\n"); |
353 |
|
354 |
/* |
355 |
* Call the init procedures for included packages. |
356 |
*/ |
357 |
#ifdef STATIC_TKTABLE |
358 |
if( Tktable_Init(interp) == TCL_ERROR ) { |
359 |
Asc_Panic(2, "Asc_Driver", |
360 |
"Call to Tktable_Init failed:\n%s", |
361 |
Tcl_GetStringResult(interp)); |
362 |
} |
363 |
#endif /* STATIC_TKTABLE */ |
364 |
|
365 |
/* |
366 |
* Initialize ASCEND C Structures |
367 |
* Create ASCEND Tcl Commands |
368 |
*/ |
369 |
clock(); |
370 |
/* the next line should NOT be Asc_SignalHandlerPush */ |
371 |
(void)signal(SIGINT, AscTrap); |
372 |
#ifdef DEBUG_MALLOC |
373 |
InitDebugMalloc(); |
374 |
ascstatus("Memory status after calling InitDebugMalloc()"); |
375 |
#endif /* DEBUG_MALLOC */ |
376 |
if ( Asc_CompilerInit(g_interface_simplify_relations) != 0 ) { |
377 |
Asc_Panic(2, "Asc_CompilerInit", |
378 |
"Insufficient memory to initialize compiler."); |
379 |
} |
380 |
SlvRegisterStandardClients(); |
381 |
if( Asc_HelpInit() == TCL_ERROR ) { |
382 |
Asc_Panic(2, "Asc_HelpInit", |
383 |
"Insufficient memory to initialize help system."); |
384 |
} |
385 |
Asc_CreateCommands(interp); |
386 |
Asc_RegisterBitmaps(interp); |
387 |
|
388 |
/* |
389 |
* Set the environment, and set find the |
390 |
* location of ASCEND's startup file. |
391 |
*/ |
392 |
AscCheckEnvironVars(interp); |
393 |
if( AscSetStartupFile(interp) != TCL_OK ) { |
394 |
Asc_Panic(2, "Asc_Driver", |
395 |
"Cannot find ~/.ascendrc nor the default AscendRC\n%s", |
396 |
Tcl_GetStringResult(interp)); |
397 |
} |
398 |
|
399 |
/* |
400 |
* Evaluate the ~/.ascendrc or $ASCENDTK/AscendRC file |
401 |
*/ |
402 |
Tcl_SourceRCFile(interp); |
403 |
|
404 |
/* |
405 |
* Establish a channel handlers for stdin and stdout |
406 |
*/ |
407 |
inChannel = Tcl_GetStdChannel(TCL_STDIN); |
408 |
if (inChannel) { |
409 |
Tcl_CreateChannelHandler(inChannel, TCL_READABLE, StdinProc, |
410 |
(ClientData) inChannel); |
411 |
} |
412 |
if (tty) { |
413 |
Prompt(interp, 0); |
414 |
} |
415 |
outChannel = Tcl_GetStdChannel(TCL_STDOUT); |
416 |
if (outChannel) { |
417 |
Tcl_Flush(outChannel); |
418 |
} |
419 |
|
420 |
/* |
421 |
* Initialize the Dynamic Strings used in StdinProc() |
422 |
*/ |
423 |
Tcl_DStringInit(&g_command); |
424 |
Tcl_DStringInit(&g_line); |
425 |
Tcl_ResetResult(interp); |
426 |
|
427 |
/* |
428 |
* Loop infinitely, waiting for commands to execute. When there |
429 |
* are no windows left, Tk_MainLoop returns and we exit. |
430 |
*/ |
431 |
#ifdef DEBUG_MALLOC |
432 |
ascstatus("Memory status before calling Tk_MainLoop()"); |
433 |
#endif /* DEBUG_MALLOC */ |
434 |
if (Asc_ScriptConfigureInterrupt(1,interp)!=0) { |
435 |
Asc_Panic(2, "Asc_ScriptConfigureInterrupt", |
436 |
"Unable to configure script interrupt."); |
437 |
} |
438 |
Tk_MainLoop(); |
439 |
Asc_ScriptConfigureInterrupt(0,interp); |
440 |
#ifdef USE_ASC_PRINTF |
441 |
Asc_PrintFinalize_Tcl(); |
442 |
#endif /* USE_ASC_PRINTF */ |
443 |
#ifdef DEBUG_MALLOC |
444 |
ascstatus("Memory status after Tk_MainLoop() exits"); |
445 |
#endif /* DEBUG_MALLOC */ |
446 |
|
447 |
/* |
448 |
* Do ASCEND Cleanup |
449 |
*/ |
450 |
Asc_HelpDestroy(); |
451 |
Asc_UnitValue(NULL); |
452 |
Asc_SolvMemoryCleanup(); |
453 |
Asc_CompilerDestroy(); |
454 |
Asc_DestroyEnvironment(); |
455 |
#ifdef DEBUG_MALLOC |
456 |
ascshutdown("Memory status just before exiting"); |
457 |
#endif /* DEBUG_MALLOC */ |
458 |
|
459 |
/* |
460 |
* Destroy the interpreter and exit |
461 |
*/ |
462 |
Tcl_DeleteInterp(interp); |
463 |
Tcl_Exit(0); |
464 |
return 0; |
465 |
} |
466 |
|
467 |
|
468 |
/* |
469 |
*----------------------------------------------------------------- |
470 |
* int AscCheckEnvironVars(interp) |
471 |
* Tcl_Interp *interp; |
472 |
* |
473 |
* This function checks the following environment variables and sets them |
474 |
* to the default value if they are not set. This function will set |
475 |
* DIST_ENVIRONVAR to the parent of the directory where the ASCEND binary |
476 |
* lives if it is not set, e.g., if the ascend binary is |
477 |
* /foo/bar/ascend4 |
478 |
* DIST_ENVIRONVAR is set to "/foo". |
479 |
* |
480 |
* We check to see if ASCTK_ENVIRONVAR points to the proper place by |
481 |
* looking for the ASCEND startup script "AscendRC". If we find it, set |
482 |
* the Tcl variable tcl_rcFileName to its location, otherwise, call |
483 |
* Asc_Panic() to exit. |
484 |
* |
485 |
* Returns a standard Tcl return code. |
486 |
* |
487 |
* CPP_MACRO ENVIRONMENT VAR DEFAULT VALUE |
488 |
* ================= =============== ============= |
489 |
* DIST_ENVIRONVAR ASCENDDIST /usr/share/ascend |
490 |
* ASCTK_ENVIRONVAR ASCENDTK $ASCENDDIST/TK |
491 |
* BITMAP_ENVIRONVAR ASCENDBITMAPS $ASCENDDIST/TK/bitmaps |
492 |
* LIBR_ENVIRONVAR ASCENDLIBRARY .:$ASCENDDIST/models |
493 |
* |
494 |
*/ |
495 |
static int AscCheckEnvironVars(Tcl_Interp *interp) |
496 |
{ |
497 |
char *tmpenv; /* holds values returned by Asc_GetEnv() */ |
498 |
Tcl_DString ascenddist; /* holds the value of DIST_ENVIRONVAR */ |
499 |
Tcl_DString buffer2; /* used to incrementally build environment |
500 |
* variable values |
501 |
*/ |
502 |
Tcl_DString buffer1; /* holds the environment variable value in the |
503 |
* native format: result of passing buffer2 |
504 |
* into Tcl_TranslateFileName() |
505 |
*/ |
506 |
Tcl_Channel c; /* used to test if file exists */ |
507 |
|
508 |
/* initialize */ |
509 |
Tcl_DStringInit(&ascenddist); |
510 |
Tcl_DStringInit(&buffer1); |
511 |
Tcl_DStringInit(&buffer2); |
512 |
|
513 |
/* |
514 |
* Get the value of the ASCENDDIST environment variable; |
515 |
* if not set, set it to the parent of the directory containing |
516 |
* the ascend binary. For example, if the ascend binary is |
517 |
* /foo/bar/bin/ascend4, set ASCENDDIST to /foo/bar |
518 |
* If Tcl doesn't know where we are---the Tcl command |
519 |
* `info nameofexecutable' returns ""---then ASCENDDIST is set |
520 |
|
521 |
/home/john/ascroot/bin/ascend4 |
522 |
/home/john/ascroot/share/ascend/ |
523 |
|
524 |
* to "." |
525 |
*/ |
526 |
if( Asc_ImportPathList(DIST_ENVIRONVAR) == 0 ) { |
527 |
if( (tmpenv = Asc_GetEnv(DIST_ENVIRONVAR)) == NULL ) { |
528 |
/* shouldn't be NULL since we just imported it successfully */ |
529 |
Asc_Panic(2, "CheckEnvironmentVars", |
530 |
"Asc_GetEnv(%s) returned NULL value.", DIST_ENVIRONVAR); |
531 |
} |
532 |
Tcl_DStringAppend(&ascenddist, tmpenv, -1); |
533 |
ascfree(tmpenv); |
534 |
} else { |
535 |
char cmd[] = |
536 |
"file nativename [file dirname [file dirname [info nameofexecutable]]]"; |
537 |
if( Tcl_Eval(interp, cmd) == TCL_OK ) { |
538 |
Tcl_DStringGetResult(interp, &ascenddist); |
539 |
/* Tcl_DStringAppend(&ascenddist, "/share/ascend", -1); */ |
540 |
if(Asc_SetPathList(DIST_ENVIRONVAR,Tcl_DStringValue(&ascenddist)) != 0) { |
541 |
Asc_Panic(2, "AscCheckEnvironVars", |
542 |
"Asc_SetPathList() returned Nonzero: " |
543 |
"Not enough memory to extend the environment"); |
544 |
} |
545 |
} |
546 |
} |
547 |
/* Make sure the Tcl side can also see this variable */ |
548 |
Tcl_SetVar2(interp, "env", DIST_ENVIRONVAR, |
549 |
Tcl_DStringValue(&ascenddist), TCL_GLOBAL_ONLY); |
550 |
|
551 |
/* |
552 |
* If the user's environment does not have ASCENDLIBRARY set, then set |
553 |
* it to a reasonable default. |
554 |
*/ |
555 |
if( Asc_ImportPathList(LIBR_ENVIRONVAR) == 0 ) { |
556 |
if( (tmpenv = Asc_GetEnv(LIBR_ENVIRONVAR)) == NULL ) { |
557 |
/* shouldn't be NULL since we just imported it successfully */ |
558 |
Asc_Panic(2, "CheckEnvironmentVars", |
559 |
"Asc_GetEnv(%s) returned NULL value.", LIBR_ENVIRONVAR); |
560 |
} |
561 |
/* Make sure the Tcl side can also see this variable */ |
562 |
Tcl_SetVar2(interp, "env", LIBR_ENVIRONVAR, tmpenv, TCL_GLOBAL_ONLY); |
563 |
ascfree(tmpenv); |
564 |
} else { |
565 |
/* Add ``.'' to the ASCENDLIBRARY envar */ |
566 |
if( Asc_SetPathList(LIBR_ENVIRONVAR, ".") != 0 ) { |
567 |
Asc_Panic(2, "AscCheckEnvironVars", |
568 |
"Asc_SetPathList() returned Nonzero: " |
569 |
"Not enough memory to extend the environment"); |
570 |
} |
571 |
|
572 |
/* Add ``$ASCENDDIST/models'' to the ASCENDLIBRARY envar */ |
573 |
|
574 |
Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&ascenddist), -1); |
575 |
Tcl_DStringAppend(&buffer2, "/models", -1); |
576 |
if( NULL != (Tcl_TranslateFileName(interp, Tcl_DStringValue(&buffer2), |
577 |
&buffer1))) { |
578 |
if(Asc_AppendPath(LIBR_ENVIRONVAR, Tcl_DStringValue(&buffer1)) != 0) { |
579 |
Asc_Panic(2, "AscCheckEnvironVars", |
580 |
"Asc_AppendPath() returned Nonzero: " |
581 |
"Not enough memory to extend the environment"); |
582 |
} |
583 |
Tcl_DStringFree(&buffer1); |
584 |
} |
585 |
Tcl_DStringFree(&buffer2); |
586 |
|
587 |
/* Get the full value of the environment variable and set |
588 |
* $env(ASCENDLIBRARY) in the Tcl code |
589 |
*/ |
590 |
if( (tmpenv = Asc_GetEnv(LIBR_ENVIRONVAR)) == NULL ) { |
591 |
/* shouldn't be NULL since we just set it. memory error! */ |
592 |
Asc_Panic(2, "CheckEnvironmentVars", |
593 |
"Asc_GetEnv(%s) returned NULL value.", LIBR_ENVIRONVAR); |
594 |
} |
595 |
/* Make sure the Tcl side can also see this variable */ |
596 |
Tcl_SetVar2(interp, "env", LIBR_ENVIRONVAR, tmpenv, TCL_GLOBAL_ONLY); |
597 |
ascfree(tmpenv); |
598 |
} |
599 |
|
600 |
/* |
601 |
* If the user's environment does not have ASCENDTK set, then set it |
602 |
* by appending 'TK' to ASCENDDIST. Later in this function, we check |
603 |
* to make sure it is a valid directory by checking for the existence |
604 |
* of `AscendRC' in that directory. |
605 |
* |
606 |
* The location of this directory is not subject to debate. It is |
607 |
* $prefix/TK. If one wants it anywhere else, for any reason, one |
608 |
* can provide a wrapper that sets the environment variable to override |
609 |
* it. |
610 |
*/ |
611 |
if( Asc_ImportPathList(ASCTK_ENVIRONVAR) == 0 ) { |
612 |
if( (tmpenv = Asc_GetEnv(ASCTK_ENVIRONVAR)) == NULL ) { |
613 |
/* shouldn't be NULL since we just imported it successfully */ |
614 |
Asc_Panic(2, "CheckEnvironmentVars", |
615 |
"Asc_GetEnv(%s) returned NULL value.", ASCTK_ENVIRONVAR); |
616 |
} |
617 |
/* store ASCENDTK in ``buffer1'' so we can check for ASCENDTK/AscendRC |
618 |
* below |
619 |
*/ |
620 |
Tcl_DStringAppend(&buffer1, tmpenv, -1); |
621 |
ascfree(tmpenv); |
622 |
} else { |
623 |
Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&ascenddist), -1); |
624 |
/* AWW20041208: Tcl_DStringAppend(&buffer2, "/TK", -1); |
625 |
*/ |
626 |
Tcl_DStringAppend(&buffer2, "/TK", -1); |
627 |
if(NULL != (Tcl_TranslateFileName(interp, Tcl_DStringValue(&buffer2), |
628 |
&buffer1))) { |
629 |
if( Asc_SetPathList(ASCTK_ENVIRONVAR, Tcl_DStringValue(&buffer1)) != 0) { |
630 |
Asc_Panic(2, "Asc_EnvironmentInit", |
631 |
"Not enough memory to initialize the environment"); |
632 |
} |
633 |
} |
634 |
Tcl_DStringFree(&buffer2); |
635 |
} |
636 |
/* Make sure the Tcl side can also see this variable */ |
637 |
Tcl_SetVar2(interp, "env", ASCTK_ENVIRONVAR, |
638 |
Tcl_DStringValue(&buffer1), TCL_GLOBAL_ONLY); |
639 |
|
640 |
/* |
641 |
* Check to see if ASCENDTK looks reasonable by checking |
642 |
* for ASCENDTK/AscendRC We use the Tcl channel |
643 |
* mechanism to see if file exists. |
644 |
*/ |
645 |
Tcl_DStringAppend(&buffer1, "/AscendRC", -1 ); |
646 |
c = Tcl_OpenFileChannel( NULL, Tcl_DStringValue(&buffer1), "r", 0 ); |
647 |
if( c != (Tcl_Channel)NULL ) { |
648 |
/* |
649 |
* file exists. close the channel and set tcl_rcfilename to |
650 |
* this location |
651 |
*/ |
652 |
Tcl_Close( NULL, c ); |
653 |
Tcl_SetVar(interp, "tcl_rcFileName", Tcl_DStringValue(&buffer1), |
654 |
TCL_GLOBAL_ONLY); |
655 |
} else { |
656 |
Asc_Panic(2, "AscCheckEnvironVars", |
657 |
"ERROR: Cannot find the file \"%s\" in the subdirectory \"TK\"\n" |
658 |
"under the directory \"%s\"\n" |
659 |
"Please check the value of the environment variables %s and\n" |
660 |
"and %s and start ASCEND again.\n", |
661 |
"AscendRC", Tcl_DStringValue(&ascenddist), DIST_ENVIRONVAR, |
662 |
ASCTK_ENVIRONVAR); |
663 |
} |
664 |
Tcl_DStringFree(&buffer1); |
665 |
|
666 |
/* |
667 |
* If the user's environment does not have ASCENDBITMAPS set, then set |
668 |
* it by appending `bitmaps' to ASCENDTK. |
669 |
*/ |
670 |
if( Asc_ImportPathList(BITMAP_ENVIRONVAR) == 0 ) { |
671 |
if( (tmpenv = Asc_GetEnv(BITMAP_ENVIRONVAR)) == NULL ) { |
672 |
/* shouldn't be NULL since we just imported it successfully */ |
673 |
Asc_Panic(2, "CheckEnvironmentVars", |
674 |
"Asc_GetEnv(%s) returned NULL value.", BITMAP_ENVIRONVAR); |
675 |
} |
676 |
/* Make sure the Tcl side can also see this variable */ |
677 |
Tcl_SetVar2(interp, "env", BITMAP_ENVIRONVAR, tmpenv, TCL_GLOBAL_ONLY); |
678 |
ascfree(tmpenv); |
679 |
} else { |
680 |
Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&ascenddist), -1); |
681 |
Tcl_DStringAppend(&buffer2, "/TK/bitmaps", -1); |
682 |
if(NULL != (Tcl_TranslateFileName(interp, Tcl_DStringValue(&buffer2), |
683 |
&buffer1))) { |
684 |
if(Asc_SetPathList(BITMAP_ENVIRONVAR, Tcl_DStringValue(&buffer1)) != 0) { |
685 |
Asc_Panic(2, "Asc_EnvironmentInit", |
686 |
"Not enough memory to initialize the environment"); |
687 |
} |
688 |
} |
689 |
Tcl_DStringFree(&buffer2); |
690 |
/* Make sure the Tcl side can also see this variable */ |
691 |
Tcl_SetVar2(interp, "env", BITMAP_ENVIRONVAR, |
692 |
Tcl_DStringValue(&buffer1), TCL_GLOBAL_ONLY); |
693 |
Tcl_DStringFree(&buffer1); |
694 |
} |
695 |
|
696 |
/* Cleanup */ |
697 |
Tcl_DStringFree(&ascenddist); |
698 |
|
699 |
return TCL_OK; |
700 |
} |
701 |
|
702 |
|
703 |
/* |
704 |
* int AscSetStartupFile(interp) |
705 |
* Tcl_Interp *interp; |
706 |
* |
707 |
* Look for ~/.ascendrc; if found, set the Tcl variable tcl_rcFileName |
708 |
* to this file's location. This overrides the value set in |
709 |
* AscCheckEnvironVars(). |
710 |
* If ~/_ascendrc is available it only gets used if ~/.ascendrc is not. |
711 |
* Returns a standard Tcl return code. |
712 |
*/ |
713 |
static int AscSetStartupFile(Tcl_Interp *interp) |
714 |
{ |
715 |
char *fullname; /* try to find this if first fails */ |
716 |
Tcl_DString buffer; |
717 |
Tcl_Channel c; /* used to check for file existance */ |
718 |
|
719 |
Tcl_ResetResult(interp); |
720 |
|
721 |
fullname = Tcl_TranslateFileName( interp, "~/.ascendrc", &buffer ); |
722 |
if( fullname != NULL ) { |
723 |
/* |
724 |
* Use the Tcl file channel routines to determine if ~/.ascendrc |
725 |
* exists. We cannot use access() since Windows doesn't use it. |
726 |
*/ |
727 |
c = Tcl_OpenFileChannel( NULL, fullname, "r", 0 ); |
728 |
if( c != (Tcl_Channel)NULL ) { |
729 |
/* file exists. close the channel and set tcl_rcFileName. */ |
730 |
Tcl_Close( NULL, c ); |
731 |
Tcl_SetVar(interp, "tcl_rcFileName", fullname, TCL_GLOBAL_ONLY); |
732 |
Tcl_DStringFree(&buffer); |
733 |
return TCL_OK; |
734 |
} |
735 |
Tcl_DStringFree(&buffer); |
736 |
} |
737 |
fullname = Tcl_TranslateFileName( interp, "~/_ascendrc", &buffer ); |
738 |
if( fullname != NULL ) { |
739 |
/* |
740 |
* Use the Tcl file channel routines to determine if ~/_ascendrc |
741 |
* exists. We cannot use access() since Windows doesn't use it. |
742 |
*/ |
743 |
c = Tcl_OpenFileChannel( NULL, fullname, "r", 0 ); |
744 |
if( c != (Tcl_Channel)NULL ) { |
745 |
/* file exists. close the channel and set tcl_rcFileName */ |
746 |
Tcl_Close( NULL, c ); |
747 |
Tcl_SetVar(interp, "tcl_rcFileName", fullname, TCL_GLOBAL_ONLY); |
748 |
Tcl_DStringFree(&buffer); |
749 |
return TCL_OK; |
750 |
} |
751 |
Tcl_DStringFree(&buffer); |
752 |
} |
753 |
return TCL_OK; /* probably should be TCL_ERROR */ |
754 |
} |
755 |
|
756 |
|
757 |
|
758 |
/* |
759 |
* file = AscProcessCommandLine(argc, argv) |
760 |
* char *file; |
761 |
* int argc; |
762 |
* char *argv[]; |
763 |
* |
764 |
* Process the options given on the command line `argv' where `argc' is |
765 |
* the length of argv. |
766 |
* |
767 |
* Strip out ASCEND specific flags and then pass the rest to Tcl so it |
768 |
* can set what it needs. |
769 |
* |
770 |
* This function may call exit() if the user requests help. |
771 |
*/ |
772 |
static int AscProcessCommandLine(Tcl_Interp *interp, int argc, CONST char **argv) |
773 |
{ |
774 |
int i; |
775 |
int flag; /* set to 1 for `+arg', -1 for `-arg' */ |
776 |
size_t length; /* length of an argv */ |
777 |
char *args; |
778 |
char buf[MAXIMUM_NUMERIC_LENGTH]; /* space for integer->string conversion */ |
779 |
int new_argc = 0; /* the argc we will pass to Tcl */ |
780 |
#ifdef ZZ_DEBUG |
781 |
zz_debug = 0; /* nonzero to print parser debugging info*/ |
782 |
#endif |
783 |
|
784 |
for( i = 1; i < argc; i++ ) { |
785 |
if( (length = strlen(argv[i])) == 0 ) { |
786 |
/* ignore 0-length arguments */ |
787 |
continue; |
788 |
} |
789 |
|
790 |
if(( length >= 2 ) && ( strncmp(argv[i],"-h",2) == 0 )) { |
791 |
AscPrintHelpExit(argv[0]); |
792 |
} |
793 |
if(( length >= 2 ) && ( strncmp(argv[i],"-H",2) == 0 )) { |
794 |
AscPrintHelpExit(argv[0]); |
795 |
} |
796 |
if(( length >= 4 ) && ( strncmp(argv[i],"help",4) == 0 )) { |
797 |
AscPrintHelpExit(argv[0]); |
798 |
} |
799 |
|
800 |
if( argv[i][0] == '-' ) { |
801 |
flag = -1; |
802 |
} else if( argv[i][0] == '+' ) { |
803 |
flag = 1; |
804 |
} else { |
805 |
flag = 0; |
806 |
} |
807 |
|
808 |
if(( length == 2 ) && ( flag != 0 )) { |
809 |
switch( argv[i][1] ) { |
810 |
case 'd': |
811 |
/* '-d' turns on scanner debugging (if ascend was built with it) |
812 |
* '+d' turns off scanner debugging [default] |
813 |
*/ |
814 |
if( flag == -1 ) { |
815 |
#ifdef ZZ_DEBUG |
816 |
zz_debug = 1; |
817 |
} else { |
818 |
zz_debug = 0; |
819 |
#else |
820 |
FPRINTF(ASCERR, "Sorry, %s wasn't compiled with %s defined.\n", |
821 |
argv[0], "ZZ_DEBUG"); |
822 |
#endif /* ZZ_DEBUG */ |
823 |
} |
824 |
break; |
825 |
case 's': |
826 |
/* '-s' turns on compiler optimizations [default] |
827 |
* '+s' turns off compiler optimizations |
828 |
*/ |
829 |
if( flag == -1 ) { |
830 |
g_interface_simplify_relations = 1; |
831 |
} else { |
832 |
g_interface_simplify_relations = 0; |
833 |
} |
834 |
break; |
835 |
case 't': |
836 |
/* '-t' turns on timing of compiler optimizations |
837 |
* '+t' turns off timing of compiler optimizations [default] |
838 |
*/ |
839 |
if( flag == 0 ) { |
840 |
g_compiler_timing = 1; |
841 |
} else { |
842 |
g_compiler_timing = 0; |
843 |
} |
844 |
break; |
845 |
case 'c': |
846 |
case 'g': |
847 |
fprintf(ASCERR, "WARNING! Obsolete ASCEND option \"%s\"\n", argv[i]); |
848 |
break; |
849 |
default: |
850 |
/* unknown ASCEND option, pass it on to Tcl |
851 |
*/ |
852 |
argv[++new_argc] = argv[i]; |
853 |
break; |
854 |
} |
855 |
} else { |
856 |
/* unknown ASCEND option, pass it on to Tcl |
857 |
*/ |
858 |
argv[++new_argc] = argv[i]; |
859 |
} |
860 |
} |
861 |
|
862 |
/* |
863 |
* Make command-line arguments available in the Tcl variables "argc" |
864 |
* and "argv". |
865 |
*/ |
866 |
args = Tcl_Merge(new_argc, (argv+1)); |
867 |
Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY); |
868 |
ckfree(args); |
869 |
sprintf(buf, "%d", new_argc); |
870 |
Tcl_SetVar(interp, "argc", buf, TCL_GLOBAL_ONLY); |
871 |
Tcl_SetVar(interp, "argv0", argv[0], TCL_GLOBAL_ONLY); |
872 |
|
873 |
return TCL_OK; |
874 |
} |
875 |
|
876 |
|
877 |
/* |
878 |
* AscPrintHelpExit(invoke_name) |
879 |
* CONST char *invoke_name; |
880 |
* |
881 |
* Print a help message and exit. Use invoke_name as the name of |
882 |
* the binary |
883 |
*/ |
884 |
static |
885 |
void AscPrintHelpExit(CONST char *invoke_name) |
886 |
{ |
887 |
PRINTF("usage: %s [options]\n" |
888 |
"\n" |
889 |
"where options include [default value]:\n" |
890 |
" -h print this message\n" |
891 |
" -/+d turn on/off yacc debugging [off]\n" |
892 |
" -/+s turn on/off compiler optimizations [on]\n" |
893 |
" -/+t turn on/off timing of compiler operations [off]\n", |
894 |
invoke_name); |
895 |
Tcl_Exit(0); /* Show this help message and leave */ |
896 |
} |
897 |
|
898 |
|
899 |
/* |
900 |
* AscTrap(sig) |
901 |
* int sig; |
902 |
* |
903 |
* Function to call when we receive an interrupt. |
904 |
*/ |
905 |
static |
906 |
void AscTrap(int sig) |
907 |
{ |
908 |
putchar('\n'); |
909 |
Asc_Panic(sig, "AscTrap", "Caught Signal: %d", sig); |
910 |
} |
911 |
|
912 |
|
913 |
/* |
914 |
* See this file's header for documentation. |
915 |
*/ |
916 |
int Asc_LoadWin(ClientData cdata, Tcl_Interp *interp, |
917 |
int argc, CONST84 char *argv[]) |
918 |
{ |
919 |
(void)cdata; /* stop gcc whine about unused parameter */ |
920 |
(void)argv; /* stop gcc whine about unused parameter */ |
921 |
|
922 |
if ( argc != 1 ) { |
923 |
FPRINTF(stderr,"call is: ascloadwin <no args> \n"); |
924 |
return TCL_ERROR; |
925 |
} |
926 |
if (g_interfacever) { |
927 |
Tcl_SetResult(interp, "1", TCL_STATIC); |
928 |
} else { |
929 |
Tcl_SetResult(interp, "0", TCL_STATIC); |
930 |
} |
931 |
return TCL_OK; |
932 |
} |
933 |
|
934 |
|
935 |
/* |
936 |
*---------------------------------------------------------------------- |
937 |
*---------------------------------------------------------------------- |
938 |
* The following StdinProc() and Prompt() are from tkMain.c in |
939 |
* the Tk4.1 distribution (and did not change in Tk8.0). |
940 |
*---------------------------------------------------------------------- |
941 |
*---------------------------------------------------------------------- |
942 |
*/ |
943 |
/* |
944 |
*---------------------------------------------------------------------- |
945 |
* |
946 |
* StdinProc -- |
947 |
* |
948 |
* This procedure is invoked by the event dispatcher whenever |
949 |
* standard input becomes readable. It grabs the next line of |
950 |
* input characters, adds them to a command being assembled, and |
951 |
* executes the command if it's complete. |
952 |
* |
953 |
* Results: |
954 |
* None. |
955 |
* |
956 |
* Side effects: |
957 |
* Could be almost arbitrary, depending on the command that's |
958 |
* typed. |
959 |
* |
960 |
*---------------------------------------------------------------------- |
961 |
*/ |
962 |
|
963 |
/* ARGSUSED */ |
964 |
static void |
965 |
StdinProc(ClientData clientData, int mask) |
966 |
{ |
967 |
static int gotPartial = 0; |
968 |
char *cmd; |
969 |
int code, count; |
970 |
Tcl_Channel chan = (Tcl_Channel) clientData; |
971 |
|
972 |
Tcl_Interp *interp = g_interp; /* use a local copy of the |
973 |
* global tcl interpreter |
974 |
*/ |
975 |
|
976 |
(void)clientData; /* stop gcc whine about unused parameter */ |
977 |
(void)mask; /* stop gcc whine about unused parameter */ |
978 |
|
979 |
count = Tcl_Gets(chan, &g_line); |
980 |
|
981 |
if (count < 0) { |
982 |
if (!gotPartial) { |
983 |
if (tty) { |
984 |
return; |
985 |
} else { |
986 |
Tcl_DeleteChannelHandler(chan, StdinProc, (ClientData) chan); |
987 |
} |
988 |
return; |
989 |
} else { |
990 |
count = 0; |
991 |
} |
992 |
} |
993 |
|
994 |
(void) Tcl_DStringAppend(&g_command, Tcl_DStringValue(&g_line), -1); |
995 |
cmd = Tcl_DStringAppend(&g_command, "\n", -1); |
996 |
Tcl_DStringFree(&g_line); |
997 |
|
998 |
if (!Tcl_CommandComplete(cmd)) { |
999 |
gotPartial = 1; |
1000 |
goto prompt; |
1001 |
} |
1002 |
gotPartial = 0; |
1003 |
|
1004 |
/* |
1005 |
* Disable the stdin channel handler while evaluating the command; |
1006 |
* otherwise if the command re-enters the event loop we might |
1007 |
* process commands from stdin before the current command is |
1008 |
* finished. Among other things, this will trash the text of the |
1009 |
* command being evaluated. |
1010 |
*/ |
1011 |
|
1012 |
Tcl_CreateChannelHandler(chan, 0, StdinProc, (ClientData) chan); |
1013 |
code = Tcl_RecordAndEval(interp, cmd, TCL_EVAL_GLOBAL); |
1014 |
Tcl_CreateChannelHandler(chan, TCL_READABLE, StdinProc, |
1015 |
(ClientData) chan); |
1016 |
Tcl_DStringFree(&g_command); |
1017 |
if (*interp->result != 0) { |
1018 |
if ((code != TCL_OK) || (tty)) { |
1019 |
/* |
1020 |
* The statement below used to call "printf", but that resulted |
1021 |
* in core dumps under Solaris 2.3 if the result was very long. |
1022 |
* |
1023 |
* NOTE: This probably will not work under Windows either. |
1024 |
*/ |
1025 |
|
1026 |
puts(interp->result); |
1027 |
} |
1028 |
} |
1029 |
|
1030 |
/* |
1031 |
* Output a prompt. |
1032 |
*/ |
1033 |
|
1034 |
prompt: |
1035 |
if (tty) { |
1036 |
Prompt(interp, gotPartial); |
1037 |
} |
1038 |
Tcl_ResetResult(interp); |
1039 |
} |
1040 |
|
1041 |
/* |
1042 |
*---------------------------------------------------------------------- |
1043 |
* |
1044 |
* Prompt -- |
1045 |
* |
1046 |
* Issue a prompt on standard output, or invoke a script |
1047 |
* to issue the prompt. |
1048 |
* |
1049 |
* Results: |
1050 |
* None. |
1051 |
* |
1052 |
* Side effects: |
1053 |
* A prompt gets output, and a Tcl script may be evaluated |
1054 |
* in interp. |
1055 |
* |
1056 |
* Parameters: |
1057 |
* interp Interpreter to use for prompting. |
1058 |
* partial Non-zero means there already exists a partial |
1059 |
* command, so use the secondary prompt. |
1060 |
* |
1061 |
*---------------------------------------------------------------------- |
1062 |
*/ |
1063 |
|
1064 |
static void |
1065 |
Prompt(Tcl_Interp *interp, int partial) |
1066 |
{ |
1067 |
CONST84 char *promptCmd; |
1068 |
int code; |
1069 |
Tcl_Channel outChannel, errChannel; |
1070 |
CONST84 char *subPrompt; |
1071 |
|
1072 |
errChannel = Tcl_GetChannel(interp, "stderr", NULL); |
1073 |
|
1074 |
subPrompt = (partial ? "tcl_prompt2" : "tcl_prompt1"); |
1075 |
promptCmd = Tcl_GetVar(interp, subPrompt, TCL_GLOBAL_ONLY); |
1076 |
if (promptCmd == NULL) { |
1077 |
defaultPrompt: |
1078 |
|
1079 |
/* |
1080 |
* We must check that outChannel is a real channel - it |
1081 |
* is possible that someone has transferred stdout out of |
1082 |
* this interpreter with "interp transfer". |
1083 |
*/ |
1084 |
|
1085 |
outChannel = Tcl_GetChannel(interp, "stdout", NULL); |
1086 |
if (outChannel != (Tcl_Channel) NULL) { |
1087 |
if (!partial) { |
1088 |
Tcl_Write(outChannel, "AscendIV% ", 10); |
1089 |
} else { |
1090 |
Tcl_Write(outChannel, "more? ", 6); |
1091 |
} |
1092 |
} |
1093 |
} else { |
1094 |
code = Tcl_Eval(interp, promptCmd); |
1095 |
if (code != TCL_OK) { |
1096 |
Tcl_AddErrorInfo(interp, |
1097 |
"\n (script that generates prompt)"); |
1098 |
/* |
1099 |
* We must check that errChannel is a real channel - it |
1100 |
* is possible that someone has transferred stderr out of |
1101 |
* this interpreter with "interp transfer". |
1102 |
*/ |
1103 |
|
1104 |
errChannel = Tcl_GetChannel(interp, "stderr", NULL); |
1105 |
if (errChannel != (Tcl_Channel) NULL) { |
1106 |
Tcl_Write(errChannel, interp->result, -1); |
1107 |
Tcl_Write(errChannel, "\n", 1); |
1108 |
} |
1109 |
goto defaultPrompt; |
1110 |
} |
1111 |
} |
1112 |
outChannel = Tcl_GetChannel(interp, "stdout", NULL); |
1113 |
if (outChannel != (Tcl_Channel) NULL) { |
1114 |
Tcl_Flush(outChannel); |
1115 |
} |
1116 |
} |
1117 |
|
1118 |
/* |
1119 |
*---------------------------------------------------------------------- |
1120 |
* Tom Epperly's Malloc Debugger |
1121 |
*---------------------------------------------------------------------- |
1122 |
*/ |
1123 |
#ifdef DEBUG_MALLOC |
1124 |
static void InitDebugMalloc(void) |
1125 |
{ |
1126 |
union dbmalloptarg m; |
1127 |
m.str = NULL; |
1128 |
m.i = 0; |
1129 |
dbmallopt(MALLOC_CKDATA,&m); |
1130 |
} |
1131 |
|
1132 |
int Asc_DebugMallocCmd(ClientData cdata, Tcl_Interp *interp, |
1133 |
int argc, CONST84 char *argv[]) |
1134 |
{ |
1135 |
union dbmalloptarg m; |
1136 |
|
1137 |
if ( argc != 2 ) { |
1138 |
Tcl_SetResult(interp, "wrong # args : Usage __dbmalloc ?on?off?", |
1139 |
TCL_STATIC); |
1140 |
return TCL_ERROR; |
1141 |
} |
1142 |
m.str = NULL; |
1143 |
if (strcmp(argv[1],"on")==0) { |
1144 |
m.i = 1; |
1145 |
} else if (strcmp(argv[1],"off")==0) { |
1146 |
m.i = 0; |
1147 |
} else { |
1148 |
Tcl_SetResult(interp, "incorrect args : should be \"on\" or \"off\"", |
1149 |
TCL_STATIC); |
1150 |
return TCL_ERROR; |
1151 |
} |
1152 |
dbmallopt(MALLOC_CKDATA,&m); /* turn on str* mem* and b* checking */ |
1153 |
return TCL_OK; |
1154 |
} |
1155 |
#endif /* DEBUG_MALLOC */ |
1156 |
|
1157 |
|