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

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