/[ascend]/trunk/tcltk98/generic/interface/Driver.c
ViewVC logotype

Contents of /trunk/tcltk98/generic/interface/Driver.c

Parent Directory Parent Directory | Revision Log Revision Log


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

john.pye@anu.edu.au
ViewVC Help
Powered by ViewVC 1.1.22