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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 522 - (show annotations) (download) (as text)
Fri Apr 21 07:22:20 2006 UTC (16 years, 1 month ago) by johnpye
File MIME type: text/x-csrc
File size: 15198 byte(s)
Fixed all the missing symbols so that ASCEND Tcl/Tk interface builds with separate 'ascendtcl.dll'.
Split Driver.c across Driver.c and new main.c, which has no Tcl/Tk references.

1 /*
2 * BrowserMethod.c
3 * by Kirk Abbott and Ben Allan
4 * Created: 1/94
5 * Version: $Revision: 1.24 $
6 * Version control file: $RCSfile: BrowserMethod.c,v $
7 * Date last modified: $Date: 2003/08/23 18:43:04 $
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 <tcl.h>
32 #include <utilities/ascConfig.h>
33 #include <utilities/ascMalloc.h>
34 #include <general/list.h>
35 #include <compiler/compiler.h>
36 #include <compiler/instance_enum.h>
37 #include <compiler/symtab.h>
38 #include <compiler/fractions.h>
39 #include <compiler/dimen.h>
40 #include <compiler/types.h>
41 #include <compiler/stattypes.h>
42 #include <compiler/slist.h>
43 #include <compiler/statio.h>
44 #include <compiler/proc.h>
45 #include <compiler/watchpt.h>
46 #include <compiler/watchptio.h>
47 #include <compiler/name.h>
48 #include <compiler/instquery.h>
49 #include <compiler/atomvalue.h>
50 #include <compiler/initialize.h>
51 #include <compiler/child.h>
52 #include <compiler/parentchild.h>
53 #include <compiler/type_desc.h>
54 #include <compiler/units.h>
55 #include <compiler/qlfdid.h>
56 #include <solver/slv_types.h>
57 #include "HelpProc.h"
58 #include "BrowserProc.h"
59 #include "BrowserMethod.h"
60 #include "UnitsProc.h"
61 #include "Qlfdid.h"
62
63 #ifndef lint
64 static CONST char BrowserMethodID[] = "$Id: BrowserMethod.c,v 1.24 2003/08/23 18:43:04 ballan Exp $";
65 #endif
66
67
68 #define MAXID 256
69
70 #ifndef MAXIMUM_STRING_LENGTH
71 #define MAXIMUM_STRING_LENGTH 2048
72 #endif
73 #define BRSTRINGMALLOC \
74 (char *)ascmalloc(MAXIMUM_STRING_LENGTH * sizeof(char))
75
76
77 /*
78 */
79 STDHLF(Asc_BrowInitializeCmd,(Asc_BrowInitializeCmdHL,HLFSTOP));
80 int Asc_BrowInitializeCmd(ClientData cdata, Tcl_Interp *interp,
81 int argc, CONST84 char *argv[])
82 {
83 int status;
84 struct Name *name=NULL;
85 enum Proc_enum runstat;
86 int options=0;
87 CONST84 char *qlfdid=NULL;
88 struct Instance *i = NULL;
89 CONST84 char *stoponerr = NULL;
90 CONST84 char *btuifstop = NULL;
91 FILE *output=NULL;
92 CONST84 char *method=NULL;
93 CONST84 char *filename=NULL;
94 int k,tmp=0;
95
96 (void)cdata; /* stop gcc whine about unused parameter */
97
98 ASCUSE;
99
100 if (argc < 2) {
101 /* put help message here */
102 Tcl_SetResult(interp, "wrong # args: Usage: " Asc_BrowInitializeCmdHU,
103 TCL_STATIC);
104 return TCL_ERROR;
105 }
106 output = ASCERR;
107 /* this is safe because argv[argc]==NULL by convention */
108 for (k=1; k < argc;) {
109 if (strcmp(argv[k],"-stopOnErr")==0) {
110 stoponerr = argv[k+1];
111 k += 2;
112 continue;
113 }
114 if (strcmp(argv[k],"-backtrace")==0) {
115 btuifstop = argv[k+1];
116 k += 2;
117 continue;
118 }
119 if (strcmp(argv[k],"-method")==0) {
120 method = argv[k+1];
121 k += 2;
122 continue;
123 }
124 if (strcmp(argv[k],"-qlfdid")==0) {
125 qlfdid = argv[k+1];
126 k += 2;
127 continue;
128 }
129 if (strcmp(argv[k],"-output")==0) {
130 filename = argv[k+1];
131 k += 2;
132 continue;
133 }
134 Tcl_AppendResult(interp,"Unknown option '",argv[k],"' to ",
135 Asc_BrowInitializeCmdHN,(char *)NULL);
136 return TCL_ERROR;
137 }
138 status = Asc_QlfdidSearch3(qlfdid,0); /* does check for NULL, yes? */
139 if (status==0) { /* catch inst ptr */
140 i = g_search_inst;
141 } else { /* failed. bail out. */
142 Tcl_AppendResult(interp,Asc_BrowInitializeCmdHN,
143 "Could not find instance ",qlfdid,(char *)NULL);
144 return TCL_ERROR;
145 }
146 if (btuifstop != NULL) {
147 status = Tcl_GetInt(interp,btuifstop,&tmp);
148 if (status != TCL_OK || tmp < 0 || tmp > 1) {
149 Tcl_AppendResult(interp,"Non-boolean value (",btuifstop,") given for ",
150 argv[0]," ","-backtrace",(char *)NULL);
151 return TCL_ERROR;
152 }
153 if (tmp) {
154 options |= WP_BTUIFSTOP;
155 }
156 }
157 if (stoponerr != NULL) {
158 status = Tcl_GetInt(interp,stoponerr,&tmp);
159 if (status != TCL_OK || tmp < 0 || tmp > 1) {
160 Tcl_AppendResult(interp,"Non-boolean value (",stoponerr,") given for ",
161 argv[0]," ","-stopOnErr",(char *)NULL);
162 return TCL_ERROR;
163 }
164 if (tmp) {
165 options |= WP_STOPONERR;
166 }
167 }
168 if (method != NULL) {
169 name = CreateIdName(AddSymbol(method));
170 } else {
171 Tcl_AppendResult(interp,Asc_BrowInitializeCmdHN,
172 "-method <method name> not given",(char *)NULL);
173 return TCL_ERROR;
174 }
175 if (filename != NULL) {
176 output = fopen(filename,"w+");
177 if (output == NULL) {
178 Tcl_AppendResult(interp,Asc_BrowInitializeCmdHN,
179 "-output ",filename,
180 " cannot open/write",(char *)NULL);
181 DestroyName(name);
182 return TCL_ERROR;
183 }
184 }
185 runstat = Initialize(i,name,QUIET(qlfdid),output,options,NULL,NULL);
186 if (filename != NULL && output != ASCERR) {
187 fclose(output);
188 }
189 DestroyName(name);
190 if (runstat != Proc_all_ok) {
191 Tcl_AppendResult(interp, "Error executing method ",method,
192 " in ",qlfdid,(char *)NULL);
193 return TCL_ERROR;
194 }
195 return TCL_OK;
196 }
197
198 static void lowerstring(register char *str)
199 {
200 while (*str != '\0') {
201 if ((*str >= 'A')&&(*str <= 'Z')) {
202 *str = *str + ('a' - 'A');
203 }
204 str++;
205 }
206 }
207
208
209 static
210 int BrowDoAssignment(Tcl_Interp *interp,struct Instance *i,
211 char *value_str, char *unit_str)
212 {
213 char buffer[MAXID], *tmps;
214 symchar *sym;
215 int code = 0;
216 switch(InstanceKind(i)) {
217 case REAL_ATOM_INST:
218 case REAL_INST:
219 case REAL_CONSTANT_INST:
220 code = Asc_UnitSetRealAtomValue(i,value_str,unit_str,0);
221 switch (code) {
222 case 0:
223 break;
224 case 1:
225 Tcl_SetResult(interp, "Unparseable units given - Not assigned.",
226 TCL_STATIC);
227 return TCL_ERROR;
228 case 2:
229 Tcl_SetResult(interp, "Dimensionally incompatible units - Not assigned.",
230 TCL_STATIC);
231 return TCL_ERROR;
232 case 3:
233 Tcl_SetResult(interp,"Overflow in converting to SI value--Not assigned.",
234 TCL_STATIC);
235 return TCL_ERROR;
236 case 5:
237 Tcl_SetResult(interp, "Unparseable value given - Not assigned.",
238 TCL_STATIC);
239 return TCL_ERROR;
240 default:
241 return TCL_ERROR;
242 }
243 break;
244 case BOOLEAN_ATOM_INST:
245 case BOOLEAN_INST:
246 case BOOLEAN_CONSTANT_INST:
247 tmps = strcpy(buffer,value_str);
248 lowerstring(tmps);
249 if(strcmp(tmps,"true")==0 || strcmp(tmps,"1")==0 || strcmp(tmps,"yes")==0){
250 SetBooleanAtomValue(i,1,0);
251 } else if (strcmp(tmps,"false")==0
252 || strcmp(tmps,"0")==0
253 || strcmp(tmps,"no")==0) {
254 SetBooleanAtomValue(i,0,0);
255 } else {
256 Tcl_SetResult(interp, "Incorrect boolean value", TCL_STATIC);
257 return TCL_ERROR;
258 }
259 break;
260 case INTEGER_ATOM_INST:
261 case INTEGER_INST:
262 case INTEGER_CONSTANT_INST:
263 if (AtomMutable(i) || !AtomAssigned(i)) {
264 SetIntegerAtomValue(i,atol(value_str),0);
265 } else {
266 Tcl_SetResult(interp, "Attempting to assign to an immutable integer",
267 TCL_STATIC);
268 return TCL_ERROR;
269 }
270 break;
271 case SYMBOL_ATOM_INST:
272 case SYMBOL_INST:
273 /* the symtab in symtab.c owns the string.
274 * an instance only refers to it.
275 */
276 sym = AddSymbol(value_str); /* this will copy the string */
277 SetSymbolAtomValue(i,sym);
278 break;
279 case SYMBOL_CONSTANT_INST:
280 /* the symtab in symtab.c owns the string.
281 * an instance only refers to it.
282 */
283 if (!AtomAssigned(i)) {
284 sym = AddSymbol(value_str); /* this will copy the string */
285 SetSymbolAtomValue(i,sym);
286 }
287 break;
288 case SET_ATOM_INST:
289 case SET_INST:
290 /* not yet supported */
291 break;
292 default:
293 Tcl_SetResult(interp, "The argument to assign is not a atom", TCL_STATIC);
294 return TCL_ERROR;
295 }
296 return TCL_OK;
297 }
298
299 /*
300 * This function should probably go away. !!.
301 * We will at the next iteration.
302 */
303 int Asc_BrowRunAssignQlfdidCmd2(ClientData cdata, Tcl_Interp *interp,
304 int argc, CONST84 char *argv[])
305 {
306 struct Instance *i;
307 CONST84 char *value_str = NULL;
308 CONST84 char *unit_str = NULL;
309 int nok;
310
311 (void)cdata; /* stop gcc whine about unused parameter */
312
313 if (( argc < 3 ) || ( argc > 4 )) {
314 Tcl_AppendResult(interp,"wrong # args: ",
315 "Usage: \"qassgn2\" qlfdid value [units]",(char *)NULL);
316 return TCL_ERROR;
317 }
318 nok = Asc_QlfdidSearch2(QUIET(argv[1]));
319 if (nok) { /* failed. bail out. */
320 Tcl_AppendResult(interp," : Error -- Name not found",(char *)NULL);
321 return TCL_ERROR;
322 }
323 i = g_search_inst; /* catch inst ptr found in QlfdidSearch */
324 value_str = argv[2];
325 if ( argc == 4 ) {
326 unit_str = argv[3];
327 }
328 if (strcmp("UNDEFINED",value_str)==0) {
329 return TCL_OK;
330 }
331 nok = BrowDoAssignment(interp,i,QUIET(value_str),QUIET(unit_str));
332 return nok; /* whatever code returned by BrowDoAssignment */
333 }
334
335
336 int Asc_BrowRunAssignQlfdidCmd3(ClientData cdata, Tcl_Interp *interp,
337 int argc, CONST84 char *argv[])
338 {
339 struct Instance *i;
340 char *value_str = NULL;
341 char *unit_str = NULL;
342 int nok;
343 int relative = 0;
344
345 (void)cdata; /* stop gcc whine about unused parameter */
346
347 if (( argc < 3 ) || ( argc > 5 )) {
348 Tcl_AppendResult(interp,"wrong # args: ",
349 "Usage: \"qassgn3\" qlfdid value [units] [-relative]",
350 (char *)NULL);
351 return TCL_ERROR;
352 }
353 /* reading args out of order to get relative flag sorted out */
354 if ( argc == 4 ) {
355 if (strcmp("-relative",argv[3])==0) {
356 relative = 1;
357 } else {
358 unit_str = QUIET(argv[3]);
359 }
360 }
361 if ( argc == 5 ) {
362 relative = 1;
363 }
364
365 nok = Asc_QlfdidSearch3(QUIET(argv[1]),relative);
366 if (nok) { /* failed. bail out. */
367 Tcl_AppendResult(interp," : Error -- Name not found",(char *)NULL);
368 return TCL_ERROR;
369 }
370 i = g_search_inst; /* catch inst ptr found in QlfdidSearch */
371 value_str = QUIET(argv[2]);
372
373 if (strcmp("UNDEFINED",value_str)==0) {
374 return TCL_OK;
375 }
376 nok = BrowDoAssignment(interp,i,value_str,unit_str);
377 return nok; /* whatever code returned by BrowDoAssignment */
378 }
379
380
381 int Asc_BrowRunAssignmentCmd(ClientData cdata, Tcl_Interp *interp,
382 int argc, CONST84 char *argv[])
383 {
384 struct Instance *i;
385 char *unit_str = NULL;
386 char *value_str = NULL;
387 int argstart=1;
388 int nok;
389
390 (void)cdata; /* stop gcc whine about unused parameter */
391
392 if (argc<2 || argc>4) {
393 Tcl_AppendResult(interp, "Usage: \"", argv[0],
394 "\" [-search] value [units]",(char *)NULL);
395 return TCL_ERROR;
396 }
397 if (argv[1][0] == '-') {
398 if (strncmp("-search",argv[1],3)!=0) {
399 Tcl_AppendResult(interp,"Error: ",argv[0]," Unknown option ",argv[1],
400 " want \"-search\"", (char *)NULL);
401 return TCL_ERROR;
402 } else {
403 argstart++;
404 i = g_search_inst;
405 }
406 } else {
407 i = g_curinst; /* use the current instance as the context */
408 }
409 if (!i) {
410 Tcl_SetResult(interp, "Given instance is NULL", TCL_STATIC);
411 return TCL_ERROR;
412 }
413 value_str = QUIET(argv[argstart]);
414 if ( argc == 3 && argstart == 1) {
415 unit_str = QUIET(argv[2]);
416 }
417 if ( argc == 4) {
418 unit_str = QUIET(argv[3]);
419 }
420 if (strcmp("UNDEFINED",value_str)==0) {
421 return TCL_OK;
422 }
423 nok = BrowDoAssignment(interp,i,value_str,unit_str);
424 return nok; /* whatever code returned by BrowDoAssignment */
425 }
426
427
428 int Asc_BrowWriteProcedure(ClientData cdata, Tcl_Interp *interp,
429 int argc, CONST84 char *argv[])
430 {
431 struct InitProcedure *proc;
432 struct Instance *i;
433 FILE *fp=NULL;
434
435 (void)cdata; /* stop gcc whine about unused parameter */
436
437 if ( argc < 3 || argc >4) {
438 Tcl_SetResult(interp,"Usage bgetproc <methodname> <filepathname> [search]",
439 TCL_STATIC);
440 return TCL_ERROR;
441 }
442 if (argc==4) {
443 i = g_search_inst;
444 } else {
445 i = g_curinst;
446 }
447 if (i==NULL) {
448 Tcl_SetResult(interp, "no instance sent to bgetproc", TCL_STATIC);
449 return TCL_ERROR;
450 }
451 proc = FindProcedure(i,AddSymbol(argv[1]));
452 if (proc==NULL) {
453 Tcl_SetResult(interp, "method named not found", TCL_STATIC);
454 return TCL_ERROR;
455 }
456 fp=fopen(argv[2],"w");
457 if (fp==NULL) {
458 Tcl_SetResult(interp, "unable to open scratch file.", TCL_STATIC);
459 return TCL_ERROR;
460 }
461 WriteProcedure(fp,proc);
462 fclose(fp);
463
464 return TCL_OK;
465 }
466
467
468 int Asc_BrowSetAtomAttribute(Tcl_Interp *interp, struct Instance *i,
469 symchar *attr, enum inst_t kind, void *value)
470 {
471 struct Instance *ch;
472 if (interp==NULL) {
473 return TCL_ERROR;
474 }
475 if (i==NULL || attr == NULL || value == NULL) {
476 Tcl_SetResult(interp, "Bad input to C Asc_BrowSetAtomAttribute",
477 TCL_STATIC);
478 return TCL_ERROR;
479 }
480 assert(AscFindSymbol(attr) != NULL);
481 ch = ChildByChar(i,attr); /* symchar safe. no array child of atoms */
482 if (ch == NULL || InstanceKind(ch) != kind) {
483 Tcl_SetResult(interp, "Mismatched input to C Asc_BrowSetAtomAttribute",
484 TCL_STATIC);
485 return TCL_ERROR;
486 }
487 switch (InstanceKind(ch)) {
488 case REAL_INST:
489 SetRealAtomValue(ch,*(double *)value,0);
490 break;
491 case INTEGER_INST:
492 SetIntegerAtomValue(ch,*(long *)value,0);
493 break;
494 case BOOLEAN_INST:
495 SetBooleanAtomValue(ch,(*(int *)value != 0),0);
496 break;
497 case SYMBOL_INST:
498 SetSymbolAtomValue(ch,AddSymbol(*(char **)value));
499 break;
500 default:
501 Tcl_SetResult(interp, "Incorrect child type to C Asc_BrowSetAtomAttribute",
502 TCL_STATIC);
503 return TCL_ERROR;
504 }
505 return TCL_OK;
506 }
507 /*
508 * status = Asc_BrowSetAtomAttribute(interp,atominstance,
509 * childname,childtype,dataptr);
510 * Sets the value of an attribute of the ATOM/REL instance given.
511 * Childname must be from the compiler symbol table via AddSymbol or
512 * AddSymbolL. Childtype determines what dataptr contains.
513 * Childtype must be REAL_INST, INTEGER_INST, BOOLEAN_INST, SYMBOL_INST.
514 * SET_INST is not supported at this time. dataptr must point to
515 * an appropriate value object for each of the INST types above:
516 * double, long, int, symchar *, respectively. Note that a symbol
517 * value MUST come from the symbol table.
518 * Return a value and message other than TCL_OK if these conditions
519 * are not met. Except that if the childname or symbol value given
520 * are not in the symbol table, then does not return.
521 */
522
523
524
525

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