/[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 575 - (hide annotations) (download) (as text)
Tue May 9 01:07:41 2006 UTC (16 years, 7 months ago) by johnpye
File MIME type: text/x-csrc
File size: 34505 byte(s)
Commenting changes, GPL header.
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     * ASCTK_ENVIRONVAR ASCENDTK $ASCENDDIST/tcltk
491     * BITMAP_ENVIRONVAR ASCENDBITMAPS $ASCENDDIST/tcltk/bitmaps
492     * LIBR_ENVIRONVAR ASCENDLIBRARY .:$ASCENDDIST/models
493     *
494     */
495     static int AscCheckEnvironVars(Tcl_Interp *interp)
496     {
497     char *tmpenv; /* holds values returned by Asc_GetEnv() */
498     Tcl_DString ascenddist; /* holds the value of DIST_ENVIRONVAR */
499     Tcl_DString buffer2; /* used to incrementally build environment
500     * variable values
501     */
502     Tcl_DString buffer1; /* holds the environment variable value in the
503     * native format: result of passing buffer2
504     * into Tcl_TranslateFileName()
505     */
506     Tcl_Channel c; /* used to test if file exists */
507    
508     /* initialize */
509     Tcl_DStringInit(&ascenddist);
510     Tcl_DStringInit(&buffer1);
511     Tcl_DStringInit(&buffer2);
512    
513     /*
514     * Get the value of the ASCENDDIST environment variable;
515     * if not set, set it to the parent of the directory containing
516     * the ascend binary. For example, if the ascend binary is
517     * /foo/bar/bin/ascend4, set ASCENDDIST to /foo/bar
518     * If Tcl doesn't know where we are---the Tcl command
519     * `info nameofexecutable' returns ""---then ASCENDDIST is set
520    
521     /home/john/ascroot/bin/ascend4
522     /home/john/ascroot/share/ascend/
523 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     Tcl_DStringAppend(&ascenddist, "/share/ascend", -1);
540     if(Asc_SetPathList(DIST_ENVIRONVAR,Tcl_DStringValue(&ascenddist)) != 0) {
541     Asc_Panic(2, "AscCheckEnvironVars",
542     "Asc_SetPathList() returned Nonzero: "
543     "Not enough memory to extend the environment");
544     }
545     }
546     }
547     /* Make sure the Tcl side can also see this variable */
548     Tcl_SetVar2(interp, "env", DIST_ENVIRONVAR,
549     Tcl_DStringValue(&ascenddist), TCL_GLOBAL_ONLY);
550    
551     /*
552     * If the user's environment does not have ASCENDLIBRARY set, then set
553     * it to a reasonable default.
554     */
555     if( Asc_ImportPathList(LIBR_ENVIRONVAR) == 0 ) {
556     if( (tmpenv = Asc_GetEnv(LIBR_ENVIRONVAR)) == NULL ) {
557     /* shouldn't be NULL since we just imported it successfully */
558     Asc_Panic(2, "CheckEnvironmentVars",
559     "Asc_GetEnv(%s) returned NULL value.", LIBR_ENVIRONVAR);
560     }
561     /* Make sure the Tcl side can also see this variable */
562     Tcl_SetVar2(interp, "env", LIBR_ENVIRONVAR, tmpenv, TCL_GLOBAL_ONLY);
563     ascfree(tmpenv);
564     } else {
565     /* Add ``.'' to the ASCENDLIBRARY envar */
566     if( Asc_SetPathList(LIBR_ENVIRONVAR, ".") != 0 ) {
567     Asc_Panic(2, "AscCheckEnvironVars",
568     "Asc_SetPathList() returned Nonzero: "
569     "Not enough memory to extend the environment");
570     }
571    
572     /* Add ``$ASCENDDIST/models'' to the ASCENDLIBRARY envar */
573    
574     Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&ascenddist), -1);
575     Tcl_DStringAppend(&buffer2, "/models", -1);
576     if( NULL != (Tcl_TranslateFileName(interp, Tcl_DStringValue(&buffer2),
577     &buffer1))) {
578     if(Asc_AppendPath(LIBR_ENVIRONVAR, Tcl_DStringValue(&buffer1)) != 0) {
579     Asc_Panic(2, "AscCheckEnvironVars",
580     "Asc_AppendPath() returned Nonzero: "
581     "Not enough memory to extend the environment");
582     }
583     Tcl_DStringFree(&buffer1);
584     }
585     Tcl_DStringFree(&buffer2);
586    
587     /* Get the full value of the environment variable and set
588     * $env(ASCENDLIBRARY) in the Tcl code
589     */
590     if( (tmpenv = Asc_GetEnv(LIBR_ENVIRONVAR)) == NULL ) {
591     /* shouldn't be NULL since we just set it. memory error! */
592     Asc_Panic(2, "CheckEnvironmentVars",
593     "Asc_GetEnv(%s) returned NULL value.", LIBR_ENVIRONVAR);
594     }
595     /* Make sure the Tcl side can also see this variable */
596     Tcl_SetVar2(interp, "env", LIBR_ENVIRONVAR, tmpenv, TCL_GLOBAL_ONLY);
597     ascfree(tmpenv);
598     }
599    
600     /*
601     * If the user's environment does not have ASCENDTK set, then set it
602     * by appending 'tcltk' to ASCENDDIST. Later in this function, we check
603     * to make sure it is a valid directory by checking for the existence
604     * of `AscendRC' in that directory.
605     */
606     if( Asc_ImportPathList(ASCTK_ENVIRONVAR) == 0 ) {
607     if( (tmpenv = Asc_GetEnv(ASCTK_ENVIRONVAR)) == NULL ) {
608     /* shouldn't be NULL since we just imported it successfully */
609     Asc_Panic(2, "CheckEnvironmentVars",
610     "Asc_GetEnv(%s) returned NULL value.", ASCTK_ENVIRONVAR);
611     }
612     /* store ASCENDTK in ``buffer1'' so we can check for ASCENDTK/AscendRC
613     * below
614     */
615     Tcl_DStringAppend(&buffer1, tmpenv, -1);
616     ascfree(tmpenv);
617     } else {
618     Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&ascenddist), -1);
619     /* AWW20041208: Tcl_DStringAppend(&buffer2, "/tcltk", -1);
620     */
621     Tcl_DStringAppend(&buffer2, "/tcltk", -1);
622     if(NULL != (Tcl_TranslateFileName(interp, Tcl_DStringValue(&buffer2),
623     &buffer1))) {
624     if( Asc_SetPathList(ASCTK_ENVIRONVAR, Tcl_DStringValue(&buffer1)) != 0) {
625     Asc_Panic(2, "Asc_EnvironmentInit",
626     "Not enough memory to initialize the environment");
627     }
628     }
629     Tcl_DStringFree(&buffer2);
630     }
631     /* Make sure the Tcl side can also see this variable */
632     Tcl_SetVar2(interp, "env", ASCTK_ENVIRONVAR,
633     Tcl_DStringValue(&buffer1), TCL_GLOBAL_ONLY);
634    
635     /*
636     * Check to see if ASCENDTK looks reasonable by checking
637     * for ASCENDTK/AscendRC We use the Tcl channel
638     * mechanism to see if file exists.
639     */
640     Tcl_DStringAppend(&buffer1, "/AscendRC", -1 );
641     c = Tcl_OpenFileChannel( NULL, Tcl_DStringValue(&buffer1), "r", 0 );
642     if( c != (Tcl_Channel)NULL ) {
643     /*
644     * file exists. close the channel and set tcl_rcfilename to
645     * this location
646     */
647     Tcl_Close( NULL, c );
648     Tcl_SetVar(interp, "tcl_rcFileName", Tcl_DStringValue(&buffer1),
649     TCL_GLOBAL_ONLY);
650     } else {
651     Asc_Panic(2, "AscCheckEnvironVars",
652     "ERROR: Cannot find the file \"%s\" in the subdirectory \"tcltk\"\n"
653     "under the directory \"%s\"\n"
654     "Please check the value of the environment variables %s and\n"
655     "and %s and start ASCEND again.\n",
656     "AscendRC", Tcl_DStringValue(&ascenddist), DIST_ENVIRONVAR,
657     ASCTK_ENVIRONVAR);
658     }
659     Tcl_DStringFree(&buffer1);
660    
661     /*
662     * If the user's environment does not have ASCENDBITMAPS set, then set
663     * it by appending `bitmaps' to ASCENDTK.
664     */
665     if( Asc_ImportPathList(BITMAP_ENVIRONVAR) == 0 ) {
666     if( (tmpenv = Asc_GetEnv(BITMAP_ENVIRONVAR)) == NULL ) {
667     /* shouldn't be NULL since we just imported it successfully */
668     Asc_Panic(2, "CheckEnvironmentVars",
669     "Asc_GetEnv(%s) returned NULL value.", BITMAP_ENVIRONVAR);
670     }
671     /* Make sure the Tcl side can also see this variable */
672     Tcl_SetVar2(interp, "env", BITMAP_ENVIRONVAR, tmpenv, TCL_GLOBAL_ONLY);
673     ascfree(tmpenv);
674     } else {
675     Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&ascenddist), -1);
676     Tcl_DStringAppend(&buffer2, "/tcltk/bitmaps", -1);
677     if(NULL != (Tcl_TranslateFileName(interp, Tcl_DStringValue(&buffer2),
678     &buffer1))) {
679     if(Asc_SetPathList(BITMAP_ENVIRONVAR, Tcl_DStringValue(&buffer1)) != 0) {
680     Asc_Panic(2, "Asc_EnvironmentInit",
681     "Not enough memory to initialize the environment");
682     }
683     }
684     Tcl_DStringFree(&buffer2);
685     /* Make sure the Tcl side can also see this variable */
686     Tcl_SetVar2(interp, "env", BITMAP_ENVIRONVAR,
687     Tcl_DStringValue(&buffer1), TCL_GLOBAL_ONLY);
688     Tcl_DStringFree(&buffer1);
689     }
690    
691     /* Cleanup */
692     Tcl_DStringFree(&ascenddist);
693    
694     return TCL_OK;
695     }
696    
697    
698     /*
699     * int AscSetStartupFile(interp)
700     * Tcl_Interp *interp;
701     *
702     * Look for ~/.ascendrc; if found, set the Tcl variable tcl_rcFileName
703     * to this file's location. This overrides the value set in
704     * AscCheckEnvironVars().
705     * If ~/_ascendrc is available it only gets used if ~/.ascendrc is not.
706     * Returns a standard Tcl return code.
707     */
708     static int AscSetStartupFile(Tcl_Interp *interp)
709     {
710     char *fullname; /* try to find this if first fails */
711     Tcl_DString buffer;
712     Tcl_Channel c; /* used to check for file existance */
713    
714     Tcl_ResetResult(interp);
715    
716     fullname = Tcl_TranslateFileName( interp, "~/.ascendrc", &buffer );
717     if( fullname != NULL ) {
718     /*
719     * Use the Tcl file channel routines to determine if ~/.ascendrc
720     * exists. We cannot use access() since Windows doesn't use it.
721     */
722     c = Tcl_OpenFileChannel( NULL, fullname, "r", 0 );
723     if( c != (Tcl_Channel)NULL ) {
724     /* file exists. close the channel and set tcl_rcFileName. */
725     Tcl_Close( NULL, c );
726     Tcl_SetVar(interp, "tcl_rcFileName", fullname, TCL_GLOBAL_ONLY);
727     Tcl_DStringFree(&buffer);
728     return TCL_OK;
729     }
730     Tcl_DStringFree(&buffer);
731     }
732     fullname = Tcl_TranslateFileName( interp, "~/_ascendrc", &buffer );
733     if( fullname != NULL ) {
734     /*
735     * Use the Tcl file channel routines to determine if ~/_ascendrc
736     * exists. We cannot use access() since Windows doesn't use it.
737     */
738     c = Tcl_OpenFileChannel( NULL, fullname, "r", 0 );
739     if( c != (Tcl_Channel)NULL ) {
740     /* file exists. close the channel and set tcl_rcFileName */
741     Tcl_Close( NULL, c );
742     Tcl_SetVar(interp, "tcl_rcFileName", fullname, TCL_GLOBAL_ONLY);
743     Tcl_DStringFree(&buffer);
744     return TCL_OK;
745     }
746     Tcl_DStringFree(&buffer);
747     }
748     return TCL_OK; /* probably should be TCL_ERROR */
749     }
750    
751    
752    
753     /*
754     * file = AscProcessCommandLine(argc, argv)
755     * char *file;
756     * int argc;
757     * char *argv[];
758     *
759     * Process the options given on the command line `argv' where `argc' is
760     * the length of argv.
761     *
762     * Strip out ASCEND specific flags and then pass the rest to Tcl so it
763     * can set what it needs.
764     *
765     * This function may call exit() if the user requests help.
766     */
767     static int AscProcessCommandLine(Tcl_Interp *interp, int argc, CONST char **argv)
768     {
769     int i;
770     int flag; /* set to 1 for `+arg', -1 for `-arg' */
771     size_t length; /* length of an argv */
772     char *args;
773     char buf[MAXIMUM_NUMERIC_LENGTH]; /* space for integer->string conversion */
774     int new_argc = 0; /* the argc we will pass to Tcl */
775     #ifdef ZZ_DEBUG
776     zz_debug = 0; /* nonzero to print parser debugging info*/
777     #endif
778    
779     for( i = 1; i < argc; i++ ) {
780     if( (length = strlen(argv[i])) == 0 ) {
781     /* ignore 0-length arguments */
782     continue;
783     }
784    
785     if(( length >= 2 ) && ( strncmp(argv[i],"-h",2) == 0 )) {
786     AscPrintHelpExit(argv[0]);
787     }
788     if(( length >= 2 ) && ( strncmp(argv[i],"-H",2) == 0 )) {
789     AscPrintHelpExit(argv[0]);
790     }
791     if(( length >= 4 ) && ( strncmp(argv[i],"help",4) == 0 )) {
792     AscPrintHelpExit(argv[0]);
793     }
794    
795     if( argv[i][0] == '-' ) {
796     flag = -1;
797     } else if( argv[i][0] == '+' ) {
798     flag = 1;
799     } else {
800     flag = 0;
801     }
802    
803     if(( length == 2 ) && ( flag != 0 )) {
804     switch( argv[i][1] ) {
805     case 'd':
806     /* '-d' turns on scanner debugging (if ascend was built with it)
807     * '+d' turns off scanner debugging [default]
808     */
809     if( flag == -1 ) {
810     #ifdef ZZ_DEBUG
811     zz_debug = 1;
812     } else {
813     zz_debug = 0;
814     #else
815     FPRINTF(ASCERR, "Sorry, %s wasn't compiled with %s defined.\n",
816     argv[0], "ZZ_DEBUG");
817     #endif /* ZZ_DEBUG */
818     }
819     break;
820     case 's':
821     /* '-s' turns on compiler optimizations [default]
822     * '+s' turns off compiler optimizations
823     */
824     if( flag == -1 ) {
825     g_interface_simplify_relations = 1;
826     } else {
827     g_interface_simplify_relations = 0;
828     }
829     break;
830     case 't':
831     /* '-t' turns on timing of compiler optimizations
832     * '+t' turns off timing of compiler optimizations [default]
833     */
834     if( flag == 0 ) {
835     g_compiler_timing = 1;
836     } else {
837     g_compiler_timing = 0;
838     }
839     break;
840     case 'c':
841     case 'g':
842     fprintf(ASCERR, "WARNING! Obsolete ASCEND option \"%s\"\n", argv[i]);
843     break;
844     default:
845     /* unknown ASCEND option, pass it on to Tcl
846     */
847     argv[++new_argc] = argv[i];
848     break;
849     }
850     } else {
851     /* unknown ASCEND option, pass it on to Tcl
852     */
853     argv[++new_argc] = argv[i];
854     }
855     }
856    
857     /*
858     * Make command-line arguments available in the Tcl variables "argc"
859     * and "argv".
860     */
861     args = Tcl_Merge(new_argc, (argv+1));
862     Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY);
863     ckfree(args);
864     sprintf(buf, "%d", new_argc);
865     Tcl_SetVar(interp, "argc", buf, TCL_GLOBAL_ONLY);
866     Tcl_SetVar(interp, "argv0", argv[0], TCL_GLOBAL_ONLY);
867    
868     return TCL_OK;
869     }
870    
871    
872     /*
873     * AscPrintHelpExit(invoke_name)
874     * CONST char *invoke_name;
875     *
876     * Print a help message and exit. Use invoke_name as the name of
877     * the binary
878     */
879     static
880     void AscPrintHelpExit(CONST char *invoke_name)
881     {
882     PRINTF("usage: %s [options]\n"
883     "\n"
884     "where options include [default value]:\n"
885     " -h print this message\n"
886     " -/+d turn on/off yacc debugging [off]\n"
887     " -/+s turn on/off compiler optimizations [on]\n"
888     " -/+t turn on/off timing of compiler operations [off]\n",
889     invoke_name);
890     Tcl_Exit(0); /* Show this help message and leave */
891     }
892    
893    
894     /*
895     * AscTrap(sig)
896     * int sig;
897     *
898     * Function to call when we receive an interrupt.
899     */
900     static
901     void AscTrap(int sig)
902     {
903     putchar('\n');
904     Asc_Panic(sig, "AscTrap", "Caught Signal: %d", sig);
905     }
906    
907    
908     /*
909     * See this file's header for documentation.
910     */
911     int Asc_LoadWin(ClientData cdata, Tcl_Interp *interp,
912     int argc, CONST84 char *argv[])
913     {
914     (void)cdata; /* stop gcc whine about unused parameter */
915     (void)argv; /* stop gcc whine about unused parameter */
916    
917     if ( argc != 1 ) {
918     FPRINTF(stderr,"call is: ascloadwin <no args> \n");
919     return TCL_ERROR;
920     }
921     if (g_interfacever) {
922     Tcl_SetResult(interp, "1", TCL_STATIC);
923     } else {
924     Tcl_SetResult(interp, "0", TCL_STATIC);
925     }
926     return TCL_OK;
927     }
928    
929    
930     /*
931     *----------------------------------------------------------------------
932     *----------------------------------------------------------------------
933     * The following StdinProc() and Prompt() are from tkMain.c in
934     * the Tk4.1 distribution (and did not change in Tk8.0).
935     *----------------------------------------------------------------------
936     *----------------------------------------------------------------------
937     */
938     /*
939     *----------------------------------------------------------------------
940     *
941     * StdinProc --
942     *
943     * This procedure is invoked by the event dispatcher whenever
944     * standard input becomes readable. It grabs the next line of
945     * input characters, adds them to a command being assembled, and
946     * executes the command if it's complete.
947     *
948     * Results:
949     * None.
950     *
951     * Side effects:
952     * Could be almost arbitrary, depending on the command that's
953     * typed.
954     *
955     *----------------------------------------------------------------------
956     */
957    
958     /* ARGSUSED */
959     static void
960     StdinProc(ClientData clientData, int mask)
961     {
962     static int gotPartial = 0;
963     char *cmd;
964     int code, count;
965     Tcl_Channel chan = (Tcl_Channel) clientData;
966    
967     Tcl_Interp *interp = g_interp; /* use a local copy of the
968     * global tcl interpreter
969     */
970    
971     (void)clientData; /* stop gcc whine about unused parameter */
972     (void)mask; /* stop gcc whine about unused parameter */
973    
974     count = Tcl_Gets(chan, &g_line);
975    
976     if (count < 0) {
977     if (!gotPartial) {
978     if (tty) {
979     return;
980     } else {
981     Tcl_DeleteChannelHandler(chan, StdinProc, (ClientData) chan);
982     }
983     return;
984     } else {
985     count = 0;
986     }
987     }
988    
989     (void) Tcl_DStringAppend(&g_command, Tcl_DStringValue(&g_line), -1);
990     cmd = Tcl_DStringAppend(&g_command, "\n", -1);
991     Tcl_DStringFree(&g_line);
992    
993     if (!Tcl_CommandComplete(cmd)) {
994     gotPartial = 1;
995     goto prompt;
996     }
997     gotPartial = 0;
998    
999     /*
1000     * Disable the stdin channel handler while evaluating the command;
1001     * otherwise if the command re-enters the event loop we might
1002     * process commands from stdin before the current command is
1003     * finished. Among other things, this will trash the text of the
1004     * command being evaluated.
1005     */
1006    
1007     Tcl_CreateChannelHandler(chan, 0, StdinProc, (ClientData) chan);
1008     code = Tcl_RecordAndEval(interp, cmd, TCL_EVAL_GLOBAL);
1009     Tcl_CreateChannelHandler(chan, TCL_READABLE, StdinProc,
1010     (ClientData) chan);
1011     Tcl_DStringFree(&g_command);
1012     if (*interp->result != 0) {
1013     if ((code != TCL_OK) || (tty)) {
1014     /*
1015     * The statement below used to call "printf", but that resulted
1016     * in core dumps under Solaris 2.3 if the result was very long.
1017     *
1018     * NOTE: This probably will not work under Windows either.
1019     */
1020    
1021     puts(interp->result);
1022     }
1023     }
1024    
1025     /*
1026     * Output a prompt.
1027     */
1028    
1029     prompt:
1030     if (tty) {
1031     Prompt(interp, gotPartial);
1032     }
1033     Tcl_ResetResult(interp);
1034     }
1035    
1036     /*
1037     *----------------------------------------------------------------------
1038     *
1039     * Prompt --
1040     *
1041     * Issue a prompt on standard output, or invoke a script
1042     * to issue the prompt.
1043     *
1044     * Results:
1045     * None.
1046     *
1047     * Side effects:
1048     * A prompt gets output, and a Tcl script may be evaluated
1049     * in interp.
1050     *
1051     * Parameters:
1052     * interp Interpreter to use for prompting.
1053     * partial Non-zero means there already exists a partial
1054     * command, so use the secondary prompt.
1055     *
1056     *----------------------------------------------------------------------
1057     */
1058    
1059     static void
1060     Prompt(Tcl_Interp *interp, int partial)
1061     {
1062     CONST84 char *promptCmd;
1063     int code;
1064     Tcl_Channel outChannel, errChannel;
1065     CONST84 char *subPrompt;
1066    
1067     errChannel = Tcl_GetChannel(interp, "stderr", NULL);
1068    
1069     subPrompt = (partial ? "tcl_prompt2" : "tcl_prompt1");
1070     promptCmd = Tcl_GetVar(interp, subPrompt, TCL_GLOBAL_ONLY);
1071     if (promptCmd == NULL) {
1072     defaultPrompt:
1073    
1074     /*
1075     * We must check that outChannel is a real channel - it
1076     * is possible that someone has transferred stdout out of
1077     * this interpreter with "interp transfer".
1078     */
1079    
1080     outChannel = Tcl_GetChannel(interp, "stdout", NULL);
1081     if (outChannel != (Tcl_Channel) NULL) {
1082     if (!partial) {
1083     Tcl_Write(outChannel, "AscendIV% ", 10);
1084     } else {
1085     Tcl_Write(outChannel, "more? ", 6);
1086     }
1087     }
1088     } else {
1089     code = Tcl_Eval(interp, promptCmd);
1090     if (code != TCL_OK) {
1091     Tcl_AddErrorInfo(interp,
1092     "\n (script that generates prompt)");
1093     /*
1094     * We must check that errChannel is a real channel - it
1095     * is possible that someone has transferred stderr out of
1096     * this interpreter with "interp transfer".
1097     */
1098    
1099     errChannel = Tcl_GetChannel(interp, "stderr", NULL);
1100     if (errChannel != (Tcl_Channel) NULL) {
1101     Tcl_Write(errChannel, interp->result, -1);
1102     Tcl_Write(errChannel, "\n", 1);
1103     }
1104     goto defaultPrompt;
1105     }
1106     }
1107     outChannel = Tcl_GetChannel(interp, "stdout", NULL);
1108     if (outChannel != (Tcl_Channel) NULL) {
1109     Tcl_Flush(outChannel);
1110     }
1111     }
1112    
1113     /*
1114     *----------------------------------------------------------------------
1115     * Tom Epperly's Malloc Debugger
1116     *----------------------------------------------------------------------
1117     */
1118     #ifdef DEBUG_MALLOC
1119     static void InitDebugMalloc(void)
1120     {
1121     union dbmalloptarg m;
1122     m.str = NULL;
1123     m.i = 0;
1124     dbmallopt(MALLOC_CKDATA,&m);
1125     }
1126    
1127     int Asc_DebugMallocCmd(ClientData cdata, Tcl_Interp *interp,
1128     int argc, CONST84 char *argv[])
1129     {
1130     union dbmalloptarg m;
1131    
1132     if ( argc != 2 ) {
1133     Tcl_SetResult(interp, "wrong # args : Usage __dbmalloc ?on?off?",
1134     TCL_STATIC);
1135     return TCL_ERROR;
1136     }
1137     m.str = NULL;
1138     if (strcmp(argv[1],"on")==0) {
1139     m.i = 1;
1140     } else if (strcmp(argv[1],"off")==0) {
1141     m.i = 0;
1142     } else {
1143     Tcl_SetResult(interp, "incorrect args : should be \"on\" or \"off\"",
1144     TCL_STATIC);
1145     return TCL_ERROR;
1146     }
1147     dbmallopt(MALLOC_CKDATA,&m); /* turn on str* mem* and b* checking */
1148     return TCL_OK;
1149     }
1150     #endif /* DEBUG_MALLOC */
1151    
1152    

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