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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 583 - (hide annotations) (download) (as text)
Tue May 9 19:14:25 2006 UTC (16 years, 6 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 johnpye 575 /* ASCEND modelling environment
2     Copyright 1997, Carnegie Mellon University
3     Copyright (C) 2006 Carnegie Mellon University
4 johnpye 571
5 johnpye 575 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 johnpye 571 #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 johnpye 575 /* jp - i took it back out of ascConfig.h - Apr 2005 */
43 johnpye 571 # 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 ben.allan 583 * ASCTK_ENVIRONVAR ASCENDTK $ASCENDDIST/TK
491     * BITMAP_ENVIRONVAR ASCENDBITMAPS $ASCENDDIST/TK/bitmaps
492 johnpye 571 * 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 johnpye 575
524 johnpye 571 * 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 ben.allan 583 /* Tcl_DStringAppend(&ascenddist, "/share/ascend", -1); */
540 johnpye 571 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 ben.allan 583 * by appending 'TK' to ASCENDDIST. Later in this function, we check
603 johnpye 571 * to make sure it is a valid directory by checking for the existence
604     * of `AscendRC' in that directory.
605 ben.allan 583 *
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 johnpye 571 */
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 ben.allan 583 /* AWW20041208: Tcl_DStringAppend(&buffer2, "/TK", -1);
625 johnpye 571 */
626 ben.allan 583 Tcl_DStringAppend(&buffer2, "/TK", -1);
627 johnpye 571 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 ben.allan 583 "ERROR: Cannot find the file \"%s\" in the subdirectory \"TK\"\n"
658 johnpye 571 "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 ben.allan 583 Tcl_DStringAppend(&buffer2, "/TK/bitmaps", -1);
682 johnpye 571 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