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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 583 - (show annotations) (download) (as text)
Tue May 9 19:14:25 2006 UTC (18 years, 11 months ago) by ben.allan
File MIME type: text/x-csrc
File size: 34719 byte(s)
Fixed the problems for Art/Krishnan/Ben and reverted
the undiscussed install tree change. 
If an alternate installed location is to be used, install a shell
script which sets ASCENDTK before invoking ascend, don't just randomly 
change the driver code to be something it's not
supposed to be.

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

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