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

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

Parent Directory Parent Directory | Revision Log Revision Log


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

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