/[ascend]/trunk/tcltk98/generic/interface/ScriptProc.c
ViewVC logotype

Contents of /trunk/tcltk98/generic/interface/ScriptProc.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 411 - (show annotations) (download) (as text)
Sun Apr 2 07:05:54 2006 UTC (16 years, 1 month ago) by ben.allan
File MIME type: text/x-csrc
File size: 10812 byte(s)
Restored autotools to working, parsers to typ_ and zz_,
Fixed many missing initializations, many casting insanities
that have been creeping in, many missing forward declarations
in preparation for fixing external relations.

1 /*
2 * ScriptProc.c
3 * by Kirk Abbott and Ben Allan
4 * Created: 1/94
5 * Version: $Revision: 1.22 $
6 * Version control file: $RCSfile: ScriptProc.c,v $
7 * Date last modified: $Date: 2003/08/23 18:43:07 $
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 <time.h>
31 #include <tcl.h>
32 #include <tk.h>
33 #include <utilities/ascConfig.h>
34 #include <utilities/ascMalloc.h>
35 #include <general/list.h>
36 #include <compiler/compiler.h>
37 #include <compiler/symtab.h>
38 #include <compiler/instance_enum.h>
39 #include <compiler/instquery.h>
40 #include <compiler/mergeinst.h>
41 #include "HelpProc.h"
42 #include "Qlfdid.h"
43 #include "BrowserProc.h"
44 #include "ScriptProc.h"
45
46 #ifndef lint
47 static CONST char ScriptProcID[] = "$Id: ScriptProc.c,v 1.22 2003/08/23 18:43:07 ballan Exp $";
48 #endif
49
50
51 #define SCRBUF_SIZE 1024
52
53 #if defined(sun) || defined(__sun__)
54 /* until sun headers are full ansi */
55 #ifndef CLOCKS_PER_SEC
56 #define CLOCKS_PER_SEC 1000000 /* ANSI C clock ticks per sec */
57 #endif
58 #endif
59
60 /* this variable is linked to a tcl variable. */
61 int Asc_ScriptInterrupt = 0;
62
63 extern int Asc_ScriptConfigureInterrupt(int start, Tcl_Interp *interp)
64 {
65 static char *varName;
66 int result;
67 /* assumes ansi NULL initialization of varName */
68 if (start) {
69 if (varName == NULL) {
70 varName = (char *)ascmalloc(60);
71 if (varName == NULL) {
72 return 1;
73 }
74 sprintf(varName,"%s","set ascScripVect(menubreak) 0");
75 Asc_ScriptInterrupt = 0;
76 result = Tcl_GlobalEval(interp,varName);
77 if (result != TCL_OK) {
78 return 2;
79 }
80 /*
81 Tcl_SetVar(interp,varName,"0",TCL_GLOBAL_ONLY);
82 */
83 sprintf(varName,"%s","ascScripVect(menubreak)");
84 Tcl_LinkVar(interp,varName,
85 (char *)&Asc_ScriptInterrupt,TCL_LINK_INT);
86 } /* else double call, ignore it */
87 return 0;
88 } else {
89 if (varName!=NULL) {
90 sprintf(varName,"%s","ascScripVect(menubreak)");
91 Tcl_UnlinkVar(interp, varName);
92 ascfree(varName);
93 varName = NULL;
94 return 0;
95 } else {
96 return 1;
97 }
98 }
99 }
100
101 /*
102 * Refine a qlfdid, if found, to the type specified, if possible.
103 */
104 int Asc_ScriptRefineCmd(ClientData cdata, Tcl_Interp *interp,
105 int argc, CONST84 char *argv[])
106 {
107 struct Instance *i;
108 int status;
109
110 if (argc!=4) {
111 Tcl_SetResult(interp,"wrong # args : Usage srefine <type> search <qlfdid>",
112 TCL_STATIC);
113 return TCL_ERROR;
114 }
115 status = Asc_QlfdidSearch3(argv[3],0);
116 if (status==0) {
117 i = g_search_inst;
118 if (!i) {
119 Tcl_SetResult(interp, "srefine: NULL instance found in qlfdid search.",
120 TCL_STATIC);
121 return TCL_ERROR;
122 }
123 status = Asc_BrowInstanceRefineCmd(cdata, interp,(int)3,argv);
124 } else {
125 Tcl_AppendResult(interp,"srefine: QlfdidSearch error,",
126 argv[3]," not found.",(char *)NULL);
127 }
128 return status;
129 }
130
131
132 int Asc_ScriptMergeCmd(ClientData cdata, Tcl_Interp *interp,
133 int argc, CONST84 char *argv[])
134 {
135 struct Instance *i, *result=NULL;
136 int status;
137
138 (void)cdata; /* stop gcc whine about unused parameter */
139
140 if (argc!=3) {
141 Tcl_SetResult(interp, "wrong # args : Usage smerge <qlfdid> <qlfdid>",
142 TCL_STATIC);
143 return TCL_ERROR;
144 }
145
146 /* Process first qlfdid */
147 status = Asc_QlfdidSearch3(argv[1],0);
148 if (status==0) {
149 i = g_search_inst;
150 if (!i) {
151 Tcl_SetResult(interp, "smerge: NULL instance found in qlfdid1 search.",
152 TCL_STATIC);
153 return TCL_ERROR;
154 }
155 } else {
156 Tcl_AppendResult(interp, "smerge: QlfdidSearch: ",argv[1],
157 " not found,",(char *)NULL);
158 return TCL_ERROR;
159 }
160
161 /* Process second qlfdid */
162 status = Asc_QlfdidSearch3(argv[2],0);
163 if (status!=0) {
164 Tcl_AppendResult(interp, "smerge: QlfdidSearch: ",argv[2],
165 " not found,",(char *)NULL);
166 return TCL_ERROR;
167 }
168 if (!g_search_inst) {
169 Tcl_SetResult(interp, "smerge: NULL instance found in qlfdid2 search.",
170 TCL_STATIC);
171 return TCL_ERROR;
172 }
173
174 switch(InstanceKind(i)) {
175 case REAL_INST: case BOOLEAN_INST:
176 case INTEGER_INST: case SYMBOL_INST:
177 case SET_INST: case REL_INST:
178 Tcl_AppendResult(interp,"AscendIV does not allow merging ",
179 "of children of Atoms.",argv[1],(char *)NULL);
180 return TCL_ERROR;
181 default:
182 break;
183 }
184 switch(InstanceKind(g_search_inst)) {
185 case REAL_INST: case BOOLEAN_INST:
186 case INTEGER_INST: case SYMBOL_INST:
187 case SET_INST: case REL_INST:
188 Tcl_AppendResult(interp,"AscendIV does not allow merging ",
189 "of children of Atoms:",argv[2],(char *)NULL);
190 return TCL_ERROR;
191 default:
192 break;
193 }
194
195 /* Do the merge */
196 result = MergeInstances(i,g_search_inst);
197 PostMergeCheck(result);
198 if (!result) {
199 Tcl_SetResult(interp, "Error in merging instances.", TCL_STATIC);
200 return TCL_ERROR;
201 }
202 return TCL_OK;
203 }
204
205 int Asc_FastRaiseCmd(ClientData cdata, Tcl_Interp *interp,
206 int argc, CONST84 char *argv[])
207 {
208 Tk_Window tkwin,mainwin;
209 Window window;
210 Display *display;
211
212 (void)cdata; /* stop gcc whine about unused parameter */
213
214 if (argc!=2) {
215 Tcl_SetResult(interp, "wrong # args to asc_raise", TCL_STATIC);
216 return TCL_ERROR;
217 }
218 mainwin = Tk_MainWindow(interp);
219 tkwin = Tk_NameToWindow(interp,argv[1],mainwin);
220 if (!tkwin) {
221 return TCL_ERROR; /* a message should be in the interp->result */
222 }
223 display = Tk_Display(tkwin);
224 window = Tk_WindowId(tkwin);
225 XRaiseWindow(display,window);
226 return TCL_OK;
227 }
228
229 int Asc_ScriptEvalCmd(ClientData cdata, Tcl_Interp *interp,
230 int argc, CONST84 char *argv[])
231 {
232 /* see page 264 of the Tcl book. */
233 int result;
234
235 (void)cdata; /* stop gcc whine about unused parameter */
236
237 if (argc!=2) {
238 Tcl_SetResult(interp, "Error in running ScriptEval", TCL_STATIC);
239 return TCL_ERROR;
240 }
241 if (Asc_ScriptInterrupt==1) {
242 Asc_ScriptInterrupt = 0;
243 Tcl_SetResult(interp, "Solver or Script interrupted by user", TCL_STATIC);
244 return TCL_ERROR;
245 }
246 /* if (interp != g_interp) {
247 * FPRINTF(stderr,
248 * "ERROR: script_eval called from nested tcl scope. Trying anyway.\n");
249 * }
250 */
251 result = Tcl_GlobalEval(interp,argv[1]);
252 return result;
253 }
254
255 STDHLF(Asc_TimeCmd,(Asc_TimeCmdHL1,Asc_TimeCmdHL2,HLFSTOP));
256
257 int Asc_TimeCmd(ClientData cdata, Tcl_Interp *interp,
258 int argc, CONST84 char *argv[])
259 {
260 clock_t max_clocks=0,min_clocks=0,avg_clocks=0,start=0,stop=0,dc=0,all_start=0,all_stop=0;
261 double time_avg, real_time_avg;
262 time_t time0, time1;
263 int i,n=1, status=TCL_OK;
264 char tmps[40];
265
266 (void)cdata; /* stop gcc whine about unused parameter */
267
268 ASCUSE;
269
270 if (argc<2||argc>3) {
271 Tcl_SetResult(interp, "call is: asc_clock {TCL script} iterations",
272 TCL_STATIC);
273 return TCL_ERROR;
274 }
275 if (argc==3) {
276 status=Tcl_GetInt(interp,argv[2],&n);
277 if (n<1 || status != TCL_OK) {
278 Tcl_SetResult(interp, "asc_clock: called with bad number of iterations.",
279 TCL_STATIC);
280 return status;
281 }
282 }
283 time(&time0);
284 all_start=clock();
285 for (i=0; i<n; i++) {
286 if (status != TCL_OK) {
287 return status;
288 }
289 start=clock();
290 status=Tcl_GlobalEval(interp,argv[1]);
291 stop=clock();
292 dc=stop-start;
293 if (i==0) {
294 min_clocks=max_clocks=dc;
295 }
296 if (dc> max_clocks) {
297 max_clocks=dc;
298 }
299 if (dc< min_clocks) {
300 min_clocks=dc;
301 }
302 }
303 all_stop=clock();
304 time(&time1);
305
306 dc=all_stop-all_start;
307 avg_clocks=dc/n;
308 time_avg = ((double)dc) / ((double)CLOCKS_PER_SEC) / ((double)n);
309 #ifdef ASCDIFFTIME
310 real_time_avg=(time1-time0)/((double)n);
311 #else
312 real_time_avg=difftime(time1,time0)/n;
313 #endif
314
315 sprintf(tmps,"%.8g",real_time_avg);
316 Tcl_AppendElement(interp,tmps);
317
318 sprintf(tmps,"%.8g",time_avg);
319 Tcl_AppendElement(interp,tmps);
320
321 sprintf(tmps,"%ld",(long)avg_clocks);
322 Tcl_AppendElement(interp,tmps);
323
324 sprintf(tmps,"%ld",(long)max_clocks);
325 Tcl_AppendElement(interp,tmps);
326
327 sprintf(tmps,"%ld",(long)min_clocks);
328 Tcl_AppendElement(interp,tmps);
329
330 sprintf(tmps,"%ld",(long)CLOCKS_PER_SEC);
331 Tcl_AppendElement(interp,tmps);
332
333 return TCL_OK;
334 }
335
336 /*
337 * String Compact: eat extra space in a string and detabify
338 */
339 int Asc_StringCompact(ClientData cdata, Tcl_Interp *interp,
340 int argc, CONST84 char *argv[])
341 {
342 size_t len,i ,c;
343 int bracenest=0,wcnt;
344 char *result=NULL;
345
346 (void)cdata; /* stop gcc whine about unused parameter */
347
348 if (argc != 2) {
349 Tcl_SetResult(interp, "wrong args: stringcompact string", TCL_STATIC);
350 return TCL_ERROR;
351 }
352 len = strlen(argv[1]);
353 if (!len) {
354 Tcl_SetResult(interp, "", TCL_STATIC);
355 return TCL_OK;
356 }
357 result= (char *)ascmalloc(sizeof(char)*(len+1));
358 if (result == NULL) {
359 Tcl_SetResult(interp, "stringcompact: insufficient memory", TCL_STATIC);
360 return TCL_ERROR;
361 }
362 memset(result,'#',len+1); /* fill whole array with #, including last spot */
363 wcnt=1; /* trim leading whitespace */
364 for (i=c=0; i < len; i++) {
365 switch (argv[1][i]) {
366 case '\t':
367 if(!wcnt) {
368 result[c++] = ' ';
369 if (!bracenest) {
370 wcnt++;
371 }
372 }
373 break;
374 case ' ':
375 if(!wcnt) {
376 result[c++] = argv[1][i];
377 if (!bracenest) {
378 wcnt++;
379 }
380 }
381 break;
382 case '{':
383 wcnt = 0;
384 bracenest++;
385 result[c++] = argv[1][i];
386 break;
387 case '}':
388 wcnt = 0;
389 bracenest--;
390 result[c++] = argv[1][i];
391 if (bracenest < 0) {
392 bracenest = 0;
393 }
394 break;
395 default:
396 wcnt = 0;
397 result[c++] = argv[1][i];
398 }
399 }
400 if (!bracenest && result[c]==' ') {
401 result[c-1] = '\0';
402 } else {
403 result[c] = '\0';
404 }
405 Tcl_AppendResult(interp,result,(char *)NULL);
406 ascfree(result);
407 return TCL_OK;
408 }

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