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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (show annotations) (download) (as text)
Fri Oct 29 20:54:12 2004 UTC (17 years, 8 months ago) by aw0a
Original Path: trunk/ascend4/interface/DisplayProc.c
File MIME type: text/x-csrc
File size: 14940 byte(s)
Setting up web subdirectory in repository
1 /*
2 * DisplayProc.c
3 * by Kirk Abbott and Ben Allan
4 * Created: 1/94
5 * Version: $Revision: 1.19 $
6 * Version control file: $RCSfile: DisplayProc.c,v $
7 * Date last modified: $Date: 2003/08/23 18:43:05 $
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 "tcl.h"
31 #include "utilities/ascConfig.h"
32 #include "utilities/ascMalloc.h"
33 #include "general/list.h"
34 #include "compiler/compiler.h"
35 #include "compiler/symtab.h"
36 #include "compiler/module.h"
37 #include "compiler/library.h"
38 #include "compiler/fractions.h"
39 #include "compiler/dimen.h"
40 #include "compiler/child.h"
41 #include "compiler/type_desc.h"
42 #include "compiler/type_descio.h"
43 #include "compiler/types.h"
44 #include "compiler/stattypes.h"
45 #include "compiler/statio.h"
46 #include "solver/slv_types.h"
47 #include "interface/HelpProc.h"
48 #include "interface/DisplayProc.h"
49 #include "interface/Commands.h"
50
51 #ifndef lint
52 static CONST char DisplayProcID[] = "$Id: DisplayProc.c,v 1.19 2003/08/23 18:43:05 ballan Exp $";
53 #endif
54
55
56 #define MAXIMUM_ID_LENGTH 80
57 #define MAXIMUM_STR_LENGTH 256
58 #define DISPTAB 4
59
60 int Asc_DispDefineCmd(ClientData cdata, Tcl_Interp *interp,
61 int argc, CONST84 char *argv[])
62 {
63 /* The format of this command is : ddefine ?arg?, where arg may
64 * be none or one. We might add a module arg.
65 */
66 struct TypeDescription *desc;
67 unsigned long length,c;
68 struct gl_list_t *list;
69 FILE *ddef_outfile=NULL;
70 int closefile=0;
71
72 (void)cdata; /* stop gcc whine about unused parameter */
73
74 if ( argc > 3 ) {
75 Tcl_SetResult(interp, "ddefine [type [filename]]", TCL_STATIC);
76 return TCL_ERROR;
77 }
78 if ( argc > 1 ) {/* we will print the types code - Toms argc + 1*/
79 desc = FindType(AddSymbol(argv[1]));
80 if (desc==NULL) {
81 FPRINTF(stderr,"Internal Error : the type %s does not exist\n",
82 argv[1]);
83 Tcl_SetResult(interp, "Type doesn't exist", TCL_STATIC);
84 return TCL_ERROR;
85 } else {
86 if ( argc == 3 ) {
87 ddef_outfile=fopen(argv[2],"w");
88 if (!ddef_outfile) {
89 Tcl_SetResult(interp, "ddefine: unable to open data file.",
90 TCL_STATIC);
91 return TCL_ERROR;
92 }
93 closefile=1;
94 } else {
95 ddef_outfile=stderr;
96 }
97 WriteDefinition(ddef_outfile,desc); /* later store this in a list */
98 if (closefile) {
99 fclose(ddef_outfile);
100 }
101 return TCL_OK;
102 }
103 } else {
104 list = DefinitionList();
105 if (list) {
106 length = gl_length(list);
107 for(c=1;c<=length;c++) {
108 desc = (struct TypeDescription *)gl_fetch(list,c);
109 PRINTF("\t%s\n",SCP(GetName(desc)));
110 }
111 return TCL_OK;
112 } else {
113 Tcl_SetResult(interp, "Strange Display Error", TCL_STATIC);
114 return TCL_ERROR;
115 }
116 }
117 /* not reached */
118 }
119 int Asc_DispDiffDefineCmd(ClientData cdata, Tcl_Interp *interp,
120 int argc, CONST84 char *argv[])
121 {
122 /* The format of this command is : ddiffdefine arg ?file? where arg
123 is a type and file is output destination.
124 */
125 struct TypeDescription *desc;
126 FILE *ddef_outfile=NULL;
127 int closefile=0;
128
129 (void)cdata; /* stop gcc whine about unused parameter */
130
131 if (argc > 3 || argc <2) {
132 Tcl_SetResult(interp, "ddiffdefine type [filename]", TCL_STATIC);
133 return TCL_ERROR;
134 }
135 desc = FindType(AddSymbol(argv[1]));
136 if (desc==NULL) {
137 FPRINTF(stderr,"ddiffdefine: the type %s does not exist\n", argv[1]);
138 Tcl_SetResult(interp, "Type doesn't exist", TCL_STATIC);
139 return TCL_ERROR;
140 } else {
141 if ( argc == 3 ) {
142 ddef_outfile=fopen(argv[2],"w");
143 if (!ddef_outfile) {
144 Tcl_SetResult(interp, "ddiffdefine: unable to open data file.",
145 TCL_STATIC);
146 return TCL_ERROR;
147 }
148 closefile=1;
149
150 } else {
151 ddef_outfile=stderr;
152 }
153 WriteDiffDefinition(ddef_outfile,desc);
154 if (closefile) {
155 fclose(ddef_outfile);
156 }
157 return TCL_OK;
158 }
159 }
160
161 int Asc_DispTypePartsCmd(ClientData cdata, Tcl_Interp *interp,
162 int argc, CONST84 char *argv[])
163 {
164 struct gl_list_t *names;
165 unsigned long len,c;
166 int atoms=FALSE,models=FALSE;
167 symchar *name,*oldname;
168 struct TypeDescription *t;
169
170 (void)cdata; /* stop gcc whine about unused parameter */
171
172 if ( argc != 3 ) {
173 Tcl_SetResult(interp, "wrong args: dgetparts <ATOM,MODEL,BOTH> <type>",
174 TCL_STATIC);
175 return TCL_ERROR;
176 }
177 switch (argv[1][0]) {
178 case 'A':
179 atoms=TRUE;
180 break;
181 case 'M':
182 models=TRUE;
183 break;
184 case 'B':
185 atoms=models=TRUE;
186 break;
187 default:
188 Tcl_SetResult(interp, "bad filter: dgetparts <ATOM,MODEL,BOTH> <type>",
189 TCL_STATIC);
190 return TCL_ERROR;
191 }
192 t = FindType(AddSymbol(argv[2]));
193 if (t==NULL) {
194 Tcl_SetResult(interp, "dgetparts called with nonexistent type",TCL_STATIC);
195 return TCL_ERROR;
196 }
197 names = GetTypeNamesFromStatList(GetStatementList(t));
198 len = gl_length(names);
199 oldname = NULL;
200 for (c=1;c<=len;c++) {
201 name=(symchar *)gl_fetch(names,c);
202 if (name == NULL) {
203 continue; /* ignore null */
204 }
205 if (name != oldname) { /*do this if not same symbol as last*/
206 t = FindType(name);
207 if (t) { /* check ATOM/MODEL and append accordingly */
208 switch (GetBaseType(t)) {
209 case model_type:
210 if (models) {
211 Tcl_AppendElement(interp,(char *)SCP(name));
212 }
213 break;
214 case real_type:
215 case boolean_type:
216 case integer_type:
217 case symbol_type:
218 case real_constant_type:
219 case boolean_constant_type:
220 case integer_constant_type:
221 case symbol_constant_type:
222 if (atoms) {
223 Tcl_AppendElement(interp,(char *)SCP(name));
224 }
225 break;
226 case set_type:
227 case relation_type:
228 case array_type:
229 break;
230 default:
231 break;
232 }
233 } else {
234 FPRINTF(stderr,"Type %s refers to missing type %s!\n",
235 argv[2],SCP(name));
236 }
237 }
238 oldname = name;
239 }
240 gl_destroy(names);
241 return TCL_OK;
242 }
243
244 int Asc_DispQueryCmd(ClientData cdata, Tcl_Interp *interp,
245 int argc, CONST84 char *argv[])
246 {
247 /* The format of this command is : disp arg ?arg?.
248 */
249 struct TypeDescription *desc;
250 unsigned long len,c;
251 struct gl_list_t *list;
252
253 (void)cdata; /* stop gcc whine about unused parameter */
254
255 if ( argc > 3 ) {
256 Tcl_SetResult(interp, "wrong # args to \"disp\" : try define", TCL_STATIC);
257 return TCL_ERROR;
258 }
259 if (( argc == 2 ) && (strncmp(argv[1],"define",3)==0)) {
260 list = DefinitionList();
261 if(list==NULL) {
262 Tcl_ResetResult(interp);
263 return TCL_OK;
264 }
265 len = gl_length(list);
266 if (len==0) {
267 Tcl_ResetResult(interp);
268 return TCL_OK;
269 }
270 for(c=1;c<=len;c++) {
271 desc = (struct TypeDescription *)gl_fetch(list,c);
272 if (desc!=NULL) {
273 Tcl_AppendElement(interp,(char *)SCP(GetName(desc)));
274 } else {
275 Tcl_ResetResult(interp);
276 return TCL_OK;
277 }
278 }
279 return TCL_OK;
280 } else {
281 FPRINTF(stderr,"Not yet supported\n");
282 return TCL_OK;
283 }
284 }
285
286
287 int Asc_DispHierarchyCmd(ClientData cdata, Tcl_Interp *interp,
288 int argc, CONST84 char *argv[])
289 {
290 struct TypeDescription *desc, *refines=NULL;
291 unsigned long c=0;
292
293 (void)cdata; /* stop gcc whine about unused parameter */
294
295 if ( argc != 2 ) {
296 Tcl_SetResult(interp, "wrong # args : Usage \"hierarchy type\"",
297 TCL_STATIC);
298 return TCL_ERROR;
299 }
300 desc = FindType(AddSymbol(argv[1]));
301 if (desc==NULL) {
302 return TCL_OK;
303 }
304 do {
305 refines = GetRefinement(desc);
306 if (refines!=NULL) {
307 Tcl_AppendElement(interp,(char *)SCP(GetName(refines)));
308 desc = refines;
309 c++;
310 }
311 } while (refines!=NULL);
312 if(c==0) {
313 Tcl_ResetResult(interp);
314 }
315 return TCL_OK;
316 }
317
318
319 /* This function accepts the name of a type and returns the filename that
320 * it was found in.
321 */
322 int Asc_DispFileByTypeCmd(ClientData cdata, Tcl_Interp *interp,
323 int argc, CONST84 char *argv[])
324 {
325 struct TypeDescription *desc;
326 char *filename;
327 symchar *tablename;
328 struct module_t *mod;
329
330 (void)cdata; /* stop gcc whine about unused parameter */
331
332 if ( argc != 2 ) {
333 Tcl_SetResult(interp, "wrong # args : Usage \"file_by_type type\"",
334 TCL_STATIC);
335 return TCL_ERROR;
336 }
337
338 tablename = AddSymbol(argv[1]);
339 /* Fundamental types are not defined externally -- hence no file */
340 if (CheckFundamental(tablename)) {
341 return TCL_OK;
342 }
343 desc = FindType(tablename);
344 if (desc==NULL) {
345 return TCL_OK;
346 }
347 mod = GetModule(desc);
348 filename = (char *)Asc_ModuleFileName(mod); /* cast for the CONST */
349 Tcl_AppendResult(interp, filename, (char *)NULL);
350 return TCL_OK;
351 }
352
353 int Asc_DispChildOneCmd(ClientData cdata, Tcl_Interp *interp,
354 int argc, CONST84 char *argv[])
355 {
356 CONST struct TypeDescription *desc;
357 ChildListPtr children;
358 char buf[MAXIMUM_NUMERIC_LENGTH]; /* string to hold long */
359 unsigned long nch, c=0;
360
361 (void)cdata; /* stop gcc whine about unused parameter */
362
363 if ( argc != 3 ) {
364 Tcl_SetResult(interp, "wrong # args to \"dchild name num\" ", TCL_STATIC);
365 return TCL_ERROR;
366 }
367 desc = FindType(AddSymbol(argv[1]));
368 if (desc==NULL) {
369 Tcl_ResetResult(interp);
370 return TCL_OK;
371 }
372 children = GetChildList(desc);
373 if (!children) {
374 Tcl_ResetResult(interp);
375 return TCL_OK;
376 }
377 nch = ChildListLen(children);
378 if(!nch) {
379 Tcl_ResetResult(interp);
380 return TCL_OK;
381 }
382 c = atol(argv[2]); /* bug. fixme use strtod */
383 if((strcmp(argv[2],"0")==0) || !(c)) {
384 sprintf(buf,"%lu",nch);
385 Tcl_SetResult(interp, buf, TCL_VOLATILE);
386 return TCL_OK;
387 }
388 if(c>nch) {
389 Tcl_AppendElement(interp,(char *)SCP(ChildStrPtr(children,nch)));
390 } else {
391 Tcl_AppendElement(interp,(char *)SCP(ChildStrPtr(children,c)));
392 }
393 return TCL_OK;
394 }
395
396 int Asc_DispRefinesMeCmd(ClientData cdata, Tcl_Interp *interp,
397 int argc, CONST84 char *argv[])
398 {
399 /* This function will search the entire library hash table for all types
400 that refine it. Hence if a refines b, and c refines b, calling this
401 function with b should return a and c. This should be expensive.
402 registered as \"drefines_me type\".
403 */
404 struct gl_list_t *refine_me=NULL;
405 symchar *refname=NULL;
406 unsigned long len,c;
407
408 if (argc!=2 && cdata) {
409 Tcl_SetResult(interp, "wrong # args to \"drefines_meall type\"",
410 TCL_STATIC);
411 return TCL_ERROR;
412 }
413 if ( argc != 2 ) {
414 Tcl_SetResult(interp, "wrong # args to \"drefines_me type\"", TCL_STATIC);
415 return TCL_ERROR;
416 }
417 if (cdata) {
418 refine_me = AllTypesThatRefineMe_Flat(AddSymbol(argv[1]));
419 } else {
420 refine_me =TypesThatRefineMe(AddSymbol(argv[1]));
421 }
422 if (!refine_me) {
423 Tcl_ResetResult(interp);
424 return TCL_OK;
425 }
426 len = gl_length(refine_me);
427 if (!len) {
428 Tcl_ResetResult(interp);
429 gl_destroy(refine_me);
430 return TCL_OK;
431 }
432 for (c=1;c<=len;c++) {
433 refname = (symchar *)gl_fetch(refine_me,c);
434 if (refname) {
435 Tcl_AppendElement(interp,(char *)SCP(refname));
436 }
437 }
438 gl_destroy(refine_me);
439 return TCL_OK;
440 }
441
442 static Tcl_Interp *writehierinterp;
443
444 static void DispWriteHierTreeChildless(struct HierarchyNode *h) {
445 if (!h) {
446 return;
447 }
448 if (!(h->descendents)) {
449 return;
450 }
451 if (gl_length(h->descendents)!=0L) {
452 return;
453 }
454 Tcl_AppendResult(writehierinterp,"{",(char *)SCP(GetName(h->desc)),
455 " {",(char *)NULL);
456 Tcl_AppendResult(writehierinterp,"}} ",(char *)NULL);
457 }
458
459 static void DispWriteHierTreeParents(struct HierarchyNode *h) {
460 if (!h) {
461 return;
462 }
463 if (!(h->descendents)) {
464 return;
465 }
466 if (gl_length(h->descendents)==0L) {
467 return;
468 }
469 Tcl_AppendResult(writehierinterp,"{",(char *)SCP(GetName(h->desc)),
470 " {",(char *)NULL);
471 gl_iterate(h->descendents,(void (*)(VOIDPTR))DispWriteHierTreeParents);
472 gl_iterate(h->descendents,(void (*)(VOIDPTR))DispWriteHierTreeChildless);
473 Tcl_AppendResult(writehierinterp,"}} ",(char *)NULL);
474 }
475
476 static void DispWriteHierTree(struct HierarchyNode *h) {
477 if (!h) {
478 return;
479 }
480 if (!(h->descendents) || gl_length(h->descendents)==0L) {
481 DispWriteHierTreeChildless(h);
482 } else {
483 DispWriteHierTreeParents(h);
484 }
485 }
486
487
488 int Asc_DispRefinesMeTreeCmd(ClientData cdata, Tcl_Interp *interp,
489 int argc, CONST84 char *argv[])
490 {
491 struct HierarchyNode *h=NULL;
492
493 (void)cdata; /* stop gcc whine about unused parameter */
494
495 if ( argc != 2 ) {
496 Tcl_SetResult(interp, "call is: drefinement_tree <type>", TCL_STATIC);
497 return TCL_ERROR;
498 }
499 h = AllTypesThatRefineMe_Tree(AddSymbol(argv[1]));
500 if (!h) {
501 Tcl_ResetResult(interp);
502 return TCL_OK;
503 }
504 writehierinterp=interp;
505 DispWriteHierTree(h);
506 DestroyHierarchyNode(h);
507 return TCL_OK;
508 }
509
510 /* still has a slight bug -- */
511
512 int Asc_DispIsRootTypeCmd(ClientData cdata, Tcl_Interp *interp,
513 int argc, CONST84 char *argv[])
514 {
515 /* Returns true if is type is a base type, or if the type is of type
516 model with no refinements.
517 */
518 unsigned int fundamental;
519 CONST struct TypeDescription *desc;
520
521 (void)cdata; /* stop gcc whine about unused parameter */
522
523 if ( argc != 2 ) {
524 Tcl_SetResult(interp, "wrong # args to \"disroot_type\"", TCL_STATIC);
525 return TCL_ERROR;
526 }
527 fundamental = CheckFundamental(AddSymbol(argv[1]));
528 if (fundamental) {
529 Tcl_SetResult(interp, "1", TCL_STATIC);
530 return TCL_OK;
531 } else {
532 desc = FindType(AddSymbol(argv[1]));
533 if (desc) {
534 desc=GetRefinement(desc);
535 if (!desc) {
536 Tcl_SetResult(interp, "1", TCL_STATIC);
537 return TCL_OK;
538 }
539 } else { /* cant find it, so it cannot be fundamental */
540 Tcl_SetResult(interp, "0", TCL_STATIC);
541 return TCL_ERROR;
542 }
543 }
544 Tcl_SetResult(interp, "0", TCL_STATIC);
545 return TCL_OK;
546 }
547

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