/[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 571 - (hide annotations) (download) (as text)
Tue May 9 00:14:59 2006 UTC (18 years, 2 months ago) by johnpye
File MIME type: text/x-csrc
File size: 34637 byte(s)
Renaming 'tcltk98' to 'tcltk', continued...
1 johnpye 571 /*
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