/[ascend]/trunk/base/generic/compiler/type_desc.c
ViewVC logotype

Contents of /trunk/base/generic/compiler/type_desc.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 709 - (show annotations) (download) (as text)
Wed Jun 28 16:28:57 2006 UTC (13 years, 5 months ago) by johnpye
File MIME type: text/x-csrc
File size: 48165 byte(s)
Monster commit!
Lots of recommenting and reorganising of external relations-related stuff.
Replaced a lot of ascmalloc and asccalloc calls with the new ASC_NEW* macros.
Fixed (?) the problem Art is having with icons in PyGTK.
Turned on -Wall in SConstruct and fixed up a stack of warnings.
Removed the redundant exit(2) from after Asc_Panic calls and added __attribute__((noreturn)).
Set doxygen to create callgraphs to level 2, updated doxyfile to version 1.4.7.
Fixed up building of extfntest.c.
1 /*
2 * Type description structure Implementation
3 * by Tom Epperly
4 * Created: 1/12/90
5 * Version: $Revision: 1.41 $
6 * Version control file: $RCSfile: type_desc.c,v $
7 * Date last modified: $Date: 1998/05/18 16:36:48 $
8 * Last modified by: $Author: ballan $
9 *
10 * This file is part of the Ascend Language Interpreter.
11 *
12 * Copyright (C) 1990, 1993, 1994 Thomas Guthrie Epperly
13 *
14 * The Ascend Language Interpreter 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 Language Interpreter 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.
28 *
29 */
30
31 #include <stdarg.h>
32 #include <utilities/ascConfig.h>
33 #include <utilities/ascMalloc.h>
34 #include "compiler.h"
35 #include <utilities/ascPanic.h>
36 #include <general/list.h>
37 #include "fractions.h"
38 #include "dimen.h"
39 #include "functype.h"
40 #include "expr_types.h"
41 #include "sets.h"
42 #include "proc.h"
43 #include "symtab.h"
44 #include "vlist.h"
45 #include "stattypes.h"
46 #include "statement.h"
47 #include "statio.h"
48 #include "slist.h"
49 #include "select.h"
50 #include "child.h"
51 #include "childinfo.h"
52 #include "instance_enum.h"
53 #include "cmpfunc.h"
54 #include "module.h"
55 #include "library.h"
56 #include "watchpt.h"
57 #include "initialize.h"
58 #include "type_desc.h"
59 #include "type_descio.h"
60
61 #ifndef lint
62 static CONST char TypeDescRCSid[] = "$Id: type_desc.c,v 1.41 1998/05/18 16:36:48 ballan Exp $";
63 #endif
64
65 #if 0 /* a debugging version of tmalloc. change 0 to 1 to use it. */
66 #define TMALLOC(x) (x) = \
67 (struct TypeDescription *)ascmalloc(sizeof(struct TypeDescription)); \
68 ascbfill((void *)(x),sizeof(struct TypeDescription))
69 #else
70 #define TMALLOC(x) (x) = \
71 (struct TypeDescription *)ascmalloc(sizeof(struct TypeDescription))
72 #endif
73
74 #define TYPELINKDEBUG 0
75 /*
76 * When this is 1, generates lots of spew about type linking
77 * and unlinking using d->refiners.
78 */
79
80 static
81 long g_parse_count = 1;
82 /*
83 * This is the total number of times a create type of any sort
84 * has been called. It can be used to disambiguate type
85 * queries by assigning the parseid from parse_count.
86 * by initialization, 0 is never a valid parseid.
87 * negative parseid indicate something destroyed.
88 */
89
90 struct ArrayDescList {
91 struct ArrayDescList *next;
92 struct TypeDescription *desc;
93 };
94
95 static unsigned long g_array_desc_count = 0L;
96 /*
97 * Count of the number of names ever made for array nodes, which normally
98 * are invisible but having names is awfully convenient in some places.
99 * should be reset 0 when list goes empty.
100 */
101 static struct ArrayDescList *g_array_desc_list=NULL;
102 /*
103 * Singly linked list of array type descriptions.
104 * Descriptions are added/deleted/searched linearly all the time
105 * which may be a very bad idea.
106 */
107
108
109 static struct IndexType g_it_dummy_enum = {NULL,NULL,0};
110 static struct IndexType g_it_dummy_int = {NULL,NULL,1};
111
112 struct IndexType *CreateDummyIndexType(int intindex)
113 {
114 if (intindex) {
115 return &g_it_dummy_int;
116 } else {
117 return &g_it_dummy_enum;
118 }
119 }
120
121 struct IndexType *CreateIndexType(struct Set *set, int int_index)
122 {
123 char *set_str; /* KAA_DEBUG */
124 struct IndexType *result;
125 result = (struct IndexType *)ascmalloc(sizeof(struct IndexType));
126 result->int_index = int_index ? 1 : 0;
127 set_str = CreateStrFromSet(set);
128 result->set = set; /* this will NOT go away. baa */
129 result->sptr = AddSymbol(set_str);
130 ascfree(set_str);
131 return result;
132 }
133
134 struct IndexType *CreateIndexTypeFromStr(char *str, int int_index)
135 {
136 struct IndexType *result; /* KAA_DEBUG */
137 result = (struct IndexType *)ascmalloc(sizeof(struct IndexType));
138 result->int_index = int_index ? 1 : 0;
139 result->sptr = AddSymbol(str); /* in symbol table */
140 result->set = NULL;
141 return result;
142 }
143
144
145 void DestroyIndexType(struct IndexType *ind)
146 {
147 if (ind == &g_it_dummy_int || ind == &g_it_dummy_enum) return;
148 AssertAllocatedMemory(ind,sizeof(struct IndexType));
149 ind->sptr = NULL; /* we own the string in symtab */
150 if (ind->set) {
151 DestroySetList(ind->set);
152 ind->set = NULL;
153 }
154 ascfree(ind);
155 }
156
157 /*
158 * This function compares two types by name and if identical complains
159 * unless ptrs are also identical.
160 * Does not tolerate null input very well.
161 * We need a function to compare symchar properly here.
162 * Breaks ties with parseid.
163 */
164 static
165 int CmpLinkedTypes(struct TypeDescription *t1, struct TypeDescription *t2)
166 {
167 int result;
168 assert(t1!=NULL);
169 assert(t2!=NULL);
170 if (t1==t2) {
171 return 0;
172 }
173 result = CmpSymchar(t1->name,t2->name);
174 if (!result) {
175 /* same name */
176 #if TYPELINKDEBUG
177 FPRINTF(ASCERR,"Distinct refinements with same name (%s) found %ld %ld\n",
178 SCP(t1->name),GetParseId(t1),GetParseId(t2));
179 #endif
180 assert(GetParseId(t1)>0 && GetParseId(t2)>0);
181 /* assumes parseid are unique! */
182 return ((GetParseId(t1) > GetParseId(t2))? 1 : -1);
183 }
184 return result;
185 }
186 /*
187 * This functions establishes the forward pointer to the new type
188 * from the old type. The new type is the more refined one.
189 * Whines if another refinement of the same name is found.
190 */
191 static
192 void LinkTypeDesc(struct TypeDescription *old,
193 struct TypeDescription *new)
194 {
195 if (old==NULL || new == NULL) {
196 Asc_Panic(2, NULL,
197 "Attempt to link bad types- old (%p) new (%p)\n"
198 "Extreme error. Please notify \n\t%s\n",
199 old, new, ASC_BIG_BUGMAIL);
200 }
201 if (old->refiners == NULL) {
202 old->refiners = gl_create(2);
203 }
204 assert(old->refiners != NULL);
205 #if TYPELINKDEBUG
206 if (1) {
207 unsigned long int c,len;
208 struct TypeDescription *desc;
209
210 FPRINTF(ASCERR,"%s refiners:\n",GetName(old));
211 len = gl_length(old->refiners);
212 for (c=1; c <= len; c++) {
213 desc = (struct TypeDescription *)gl_fetch(old->refiners,c);
214 FPRINTF(ASCERR,"%s (%ld)\n",GetName(desc),GetParseId(desc));
215 }
216 }
217 #endif
218 gl_insert_sorted(old->refiners,new,(CmpFunc)CmpLinkedTypes);
219 #if TYPELINKDEBUG
220 if (1) {
221 unsigned long int c,len;
222 struct TypeDescription *desc;
223
224 FPRINTF(ASCERR,"%s refiners:\n",GetName(old));
225 len = gl_length(old->refiners);
226 for (c=1; c <= len; c++) {
227 desc = (struct TypeDescription *)gl_fetch(old->refiners,c);
228 FPRINTF(ASCERR,"%s (%ld)\n",GetName(desc),GetParseId(desc));
229 }
230 }
231 #endif
232 }
233 /*
234 * deletes the reference to new in old->refiners
235 * so that new can be tossed.
236 */
237 static
238 void UnLinkTypeDesc(struct TypeDescription *old,
239 struct TypeDescription *new)
240 {
241 unsigned long int pos;
242 assert(old!=NULL);
243 assert(new!=NULL);
244 assert(old->refiners!=NULL);
245 pos = gl_search(old->refiners,new,(CmpFunc)CmpLinkedTypes);
246 if (!pos) {
247 FPRINTF(ASCERR,"Attempt to unlink corrupted type descriptions");
248 return;
249 }
250 #if TYPELINKDEBUG
251 if (1) {
252 struct TypeDescription *desc;
253 desc = (struct TypeDescription *)gl_fetch(old->refiners,pos);
254 FPRINTF(ASCERR,"Unlinking attempt %s (%ld)\n",new->name,GetParseId(new));
255 FPRINTF(ASCERR,"Unlinking type %s (%ld)\n",desc->name,GetParseId(desc));
256 }
257 #endif
258 gl_delete(old->refiners,pos,0);
259 }
260
261 /* a widget to check for := in a statement list. returns the bit
262 * TYPECONTAINSDEFAULTS appropriate for defaults if so and 0 otherwise.
263 * handle null input gracefully.
264 */
265 static
266 unsigned short int StatListHasDefaults(struct StatementList *sl) {
267 register unsigned long len,c;
268 register CONST struct gl_list_t *l;
269
270 len = StatementListLength(sl);
271 if (len==0L) return 0;
272 l = GetList(sl);
273 for(c=1;c<=len;c++) {
274 if ( StatementType((struct Statement *)gl_fetch(l,c)) == ASGN ) {
275 return TYPECONTAINSDEFAULTS;
276 }
277 }
278 return 0;
279 }
280
281 /* forward declaration */
282 static
283 unsigned short int ParametersInType(struct StatementList *,
284 struct StatementList *);
285
286 /*
287 * To check for () in the statements lists of a SELECT
288 * statement. returns 1 for parameters if so and 0 otherwise.
289 */
290 static
291 int ParametersInTypeInsideSelect(struct Statement *stat)
292 {
293 struct SelectList *cases;
294 struct StatementList *sl;
295
296 cases = SelectStatCases(stat);
297
298 while ( cases!=NULL ) {
299 sl = SelectStatementList(cases);
300 if (ParametersInType(sl,NULL) != 0) {
301 return 1;
302 }
303 cases = NextSelectCase(cases);
304 }
305 return 0;
306 }
307
308
309 /* a widget to check for () in a statement list. returns the bit
310 * TYPECONTAINSPARINSTS appropriate for parameters if so and 0 otherwise.
311 * handle null input gracefully.
312 */
313 static
314 unsigned short int ParametersInType(struct StatementList *sl,
315 struct StatementList *psl) {
316 register unsigned long len,c;
317 register CONST struct gl_list_t *l;
318 struct TypeDescription *d;
319 struct Statement *stat;
320 unsigned int forflags = (contains_ISA | contains_WILLBE | contains_IRT );
321
322 if (StatementListLength(psl)!=0L) {
323 return TYPECONTAINSPARINSTS;
324 }
325 len = StatementListLength(sl);
326 if (len==0L) return 0;
327 l = GetList(sl);
328 for(c=1;c<=len;c++) {
329 stat = (struct Statement *)gl_fetch(l,c);
330 switch ( StatementType(stat) ) {
331 case WILLBE:
332 case ISA:
333 case IRT:
334 d = GetStatTypeDesc(stat);
335 if ( d != NULL && TypeHasParameterizedInsts(d)!=0 ) {
336 return TYPECONTAINSPARINSTS;
337 }
338 break;
339 case FOR:
340 if ((ForContains(stat) & forflags) != 0 ) {
341 if (ParametersInType(ForStatStmts(stat),NULL) != 0) {
342 return TYPECONTAINSPARINSTS;
343 }
344 }
345 break;
346 case SELECT:
347 if (ParametersInTypeInsideSelect(stat) != 0) {
348 return TYPECONTAINSPARINSTS;
349 }
350 break;
351 default:
352 break;
353 }
354 }
355 return 0;
356 }
357
358 /* counts total lhs names in a list of IS_A's
359 * and WILL_BE's. list given may be null.
360 */
361 static
362 unsigned int CountParameters(CONST struct StatementList *sl)
363 {
364 unsigned cnt=0;
365 unsigned long c,len;
366 CONST struct Statement *s;
367 /* count the IS_A's and WILL_BE's, then add the number
368 * of extra identifiers the WILL_BE's have.
369 */
370 len = StatementListLength(sl);
371 cnt = len;
372 if (cnt > 0) {
373 for (c=1;c<=len;c++) {
374 s = GetStatement(sl,c);
375 switch(StatementType(s)) {
376 case WILLBE:
377 cnt += (VariableListLength(GetStatVarList(s)) - 1);
378 break;
379 case ISA:
380 default:
381 break;
382 }
383 }
384 }
385 return cnt;
386 }
387
388 /* returns old, the number of procedures in pl already
389 * claimed by another type.
390 */
391 static
392 int ClaimNewMethodsTypeDesc(long parseid, struct gl_list_t *pl)
393 {
394 unsigned long c;
395 struct InitProcedure *p;
396 int old=0;
397 assert(parseid != 0);
398 if (pl==NULL) {
399 return 0;
400 }
401 for (c = gl_length(pl); c > 0; c--) {
402 p = (struct InitProcedure *)gl_fetch(pl,c);
403 if (p != NULL && GetProcParseId(p) == 0) {
404 SetProcParseId(p,parseid);
405 } else {
406 old++;
407 }
408 }
409 return old;
410 }
411
412 struct TypeDescription
413 *CreateModelTypeDesc(symchar *name, /* name of the type*/
414 struct TypeDescription *rdesc,/* type that it */
415 /* refines or NULL */
416 struct module_t *mod, /* module it is defined in */
417 ChildListPtr cl, /* list of the type's */
418 /* child names */
419 struct gl_list_t *pl, /* list of initialization */
420 /* procedures */
421 struct StatementList *sl, /* list of declarative */
422 /* statements */
423 int univ, /* UNIVERSAL flag */
424 struct StatementList *psl, /* list of parameter */
425 /* statements */
426 struct StatementList *rsl, /* list of reduction */
427 /* statements */
428 struct StatementList *tsl, /* list of reduced */
429 /* statements */
430 struct StatementList *wsl /* list of wbts statements */
431 )
432
433 {
434 register struct TypeDescription *result;
435 TMALLOC(result);
436 result->ref_count = 1;
437 result->t = model_type;
438 result->name = name;
439 result->refines = rdesc;
440 result->refiners = NULL;
441 result->parseid = g_parse_count++;
442 ClaimNewMethodsTypeDesc(result->parseid,pl);
443 if (rdesc!=NULL) CopyTypeDesc(rdesc);
444 if (rdesc!=NULL) LinkTypeDesc(rdesc,result);
445 result->mod = mod;
446 result->children = cl;
447 result->init = pl;
448 result->stats = sl;
449 result->universal = univ;
450 result->flags = 0;
451 result->flags |= StatListHasDefaults(sl);
452 result->flags |= ParametersInType(sl,psl);
453 result->flags |= TYPESHOW;
454 result->u.modarg.declarations = psl;
455 result->u.modarg.absorbed = tsl;
456 result->u.modarg.reductions = rsl;
457 result->u.modarg.wheres = wsl;
458 /*
459 result->u.modarg.argdata = NULL;
460 */
461 result->u.modarg.argcnt = CountParameters(psl);
462 return result;
463 }
464
465 struct TypeDescription
466 *CreateDummyTypeDesc(symchar *name)
467 {
468 register struct TypeDescription *result;
469 TMALLOC(result);
470 result->ref_count = 1;
471 result->t = dummy_type;
472 result->name = name;
473 result->refines = NULL;
474 result->refiners = NULL;
475 result->parseid = g_parse_count++;
476 result->mod = NULL;
477 result->children = NULL;
478 result->init = NULL;
479 result->stats = EmptyStatementList();
480 result->universal = 1;
481 result->flags = 0;
482 result->flags |= TYPESHOW;
483 return result;
484 }
485
486 struct TypeDescription
487 *CreateConstantTypeDesc(symchar *name, /* name of type */
488 enum type_kind t, /* base type of atom */
489 struct TypeDescription *rdesc, /* type */
490 /* description */
491 /* what it refines */
492 struct module_t *mod, /* module where the type */
493 /* is defined */
494 unsigned long bytesize, /* instance size */
495 int defaulted, /* valid for constants */
496 /* indicates default value was */
497 /* assigned */
498 double rval, /* default value for real const */
499 CONST dim_type *dim, /* dimensions of default real */
500 long ival, /* default integer const */
501 symchar *sval, /* default symbol */
502 int univ)
503 {
504 register struct TypeDescription *result;
505 TMALLOC(result);
506 result->t = t;
507 result->ref_count = 1;
508 result->name = name;
509 result->refines = rdesc;
510 result->refiners = NULL;
511 result->parseid = g_parse_count++;
512 if (rdesc!=NULL) CopyTypeDesc(rdesc);
513 if (rdesc!=NULL) LinkTypeDesc(rdesc,result);
514 result->mod = mod;
515 result->children = NULL;
516 result->init = NULL;
517 result->stats = EmptyStatementList();
518 result->universal = univ;
519 result->flags = 0;
520 result->flags |= TYPESHOW;
521 result->u.constant.byte_length = bytesize;
522 result->u.constant.defaulted = (defaulted) ? 1 : 0;
523 switch (t) {
524 case real_constant_type:
525 result->u.constant.u.defreal = rval;
526 result->u.constant.dimp = dim;
527 break;
528 case integer_constant_type:
529 result->u.constant.u.definteger = ival;
530 break;
531 case boolean_constant_type:
532 result->u.constant.u.defboolean = (ival) ? 1 : 0;
533 break;
534 case symbol_constant_type:
535 result->u.constant.u.defsymbol = sval;
536 break;
537 default: /* not reached we hope */
538 Asc_Panic(2, NULL, "ERROR 666\n");
539 break;
540 }
541 return result;
542 }
543
544 struct TypeDescription
545 *CreateAtomTypeDesc(symchar *name, /* name of type */
546 enum type_kind t, /* base type of atom */
547 struct TypeDescription *rdesc, /* type */
548 /* description */
549 /* what it refines */
550 struct module_t *mod, /* module where the type */
551 /* is defined */
552 ChildListPtr childl, /* list of children names */
553 struct gl_list_t *procl, /* list of */
554 /* initialization procedures */
555 struct StatementList *statl, /* list of */
556 /* declarative statements */
557 unsigned long int bytesize, /* size of an */
558 /* instance in bytes. */
559 struct ChildDesc *childd, /* description of the */
560 /* atom's children */
561 int defaulted, /* TRUE indicates default value was */
562 /* assigned */
563 double dval, /* default value for real atoms */
564 CONST dim_type *ddim, /* dimensions of default value */
565 int univ,
566 long ival,
567 symchar *sval
568 )
569 {
570 register struct TypeDescription *result;
571 TMALLOC(result);
572 #if TYPELINKDEBUG
573 FPRINTF(ASCERR,"\n");
574 #endif
575 result->t = t;
576 result->ref_count = 1;
577 result->name = name;
578 result->refines = rdesc;
579 result->refiners = NULL;
580 result->parseid = g_parse_count++;
581 ClaimNewMethodsTypeDesc(result->parseid,procl);
582 if (rdesc!=NULL) CopyTypeDesc(rdesc);
583 if (rdesc!=NULL) LinkTypeDesc(rdesc,result);
584 result->mod = mod;
585 result->children = childl;
586 result->init = procl;
587 result->stats = statl;
588 result->universal = univ;
589 result->flags = 0;
590 result->flags |= StatListHasDefaults(statl);
591 result->flags |= TYPESHOW;
592 result->u.atom.byte_length = bytesize;
593 result->u.atom.childinfo = childd;
594 result->u.atom.defaulted = (defaulted) ? 1 : 0;
595 switch(t) {
596 case real_type:
597 result->u.atom.u.defval = dval;
598 break;
599 case integer_type:
600 result->u.atom.u.defint = ival;
601 break;
602 case boolean_type:
603 result->u.atom.u.defbool = ival ? 1 : 0;
604 break;
605 case symbol_type:
606 result->u.atom.u.defsym = sval;
607 break;
608 case set_type: /* don't have defaults, but are atoms... eww! */
609 break;
610 default:
611 FPRINTF(ASCERR,"CreateAtomTypeDesc called with unexpected type for %s\n",
612 SCP(name));
613 break;
614 }
615 result->u.atom.dimp = ddim;
616 return result;
617 }
618
619 static
620 int IndicesEqual(struct gl_list_t *i1, struct gl_list_t *i2)
621 {
622 unsigned long c,len;
623 struct IndexType *ind1,*ind2;
624 if (gl_length(i1)!=gl_length(i2)) return 0;
625 len = gl_length(i1);
626 for(c=1;c<=len;c++){
627 ind1 = (struct IndexType *)gl_fetch(i1,c);
628 ind2 = (struct IndexType *)gl_fetch(i2,c);
629 if (ind1==ind2) continue; /* matching dummies */
630 if (ind1->int_index!=ind2->int_index) return 0;
631 /* FOR loop ALIASES-IS_A has forced the dummies into the typedesc. */
632 if (ind1->sptr == NULL || ind2->sptr==NULL) {
633 /* unequal dummies or dummy vs real index are only possible NULL */
634 return 0;
635 }
636 assert(AscFindSymbol(ind1->sptr)!=NULL);
637 assert(AscFindSymbol(ind2->sptr)!=NULL);
638 if (ind1->sptr != ind2->sptr) {
639 return 0;
640 }
641 }
642 return 1;
643 }
644
645 static
646 int ArrayDescsEqual(struct TypeDescription *src,
647 struct module_t *mod,
648 struct TypeDescription *desc,
649 int isintset,
650 int isrel,
651 int islogrel,
652 int iswhen,
653 struct gl_list_t *indices)
654 {
655 if (src->mod != mod) return 0;
656 if (src->u.array.desc != desc) return 0;
657 if ((src->u.array.isrelation&&!isrel)||
658 (isrel&&!src->u.array.isrelation)) return 0;
659 if ((src->u.array.islogrel&&!islogrel)||
660 (islogrel&&!src->u.array.islogrel)) return 0;
661 if ((src->u.array.iswhen&&!iswhen)||
662 (iswhen&&!src->u.array.iswhen)) return 0;
663 if ((src->u.array.isintset&&!isintset)||(isintset&&!src->u.array.isintset))
664 return 0;
665 return IndicesEqual(src->u.array.indices,indices);
666 }
667
668 static
669 struct TypeDescription *FindArray(struct module_t *mod,
670 struct TypeDescription *desc,
671 int isintset,
672 int isrel,
673 int islogrel,
674 int iswhen,
675 struct gl_list_t *indices)
676 {
677 register struct ArrayDescList *ptr;
678 int ade;
679 ptr = g_array_desc_list;
680 while(ptr!=NULL){
681 ade =
682 ArrayDescsEqual(ptr->desc,mod,desc,isintset,
683 isrel,islogrel,iswhen,indices);
684 if (ade) {
685 CopyTypeDesc(ptr->desc);
686 return ptr->desc;
687 }
688 ptr = ptr->next;
689 }
690 return NULL;
691 }
692
693 static
694 void AddArray(struct TypeDescription *d)
695 {
696 register struct ArrayDescList *ptr;
697 ptr = g_array_desc_list;
698 g_array_desc_list =
699 (struct ArrayDescList *)ascmalloc(sizeof(struct ArrayDescList));
700 g_array_desc_list->next = ptr;
701 g_array_desc_list->desc = d;
702 }
703
704 static
705 void RemoveArrayTypeDesc(struct TypeDescription *d)
706 {
707 register struct ArrayDescList *ptr , *next;
708 ptr = g_array_desc_list;
709 if (ptr!=NULL){
710 if (ptr->desc == d){
711 g_array_desc_list = ptr->next;
712 ascfree(ptr);
713 } else {
714 while(NULL != (next = ptr->next)){
715 if (next->desc == d){
716 ptr->next = next->next;
717 ascfree(next);
718 return;
719 } else {
720 ptr = next;
721 }
722 }
723 }
724 }
725 if (g_array_desc_list==NULL) {
726 g_array_desc_count = 0L; /* reset the count if all gone */
727 }
728 }
729
730 struct TypeDescription *CreateArrayTypeDesc(struct module_t *mod,
731 struct TypeDescription *desc,
732 int isint,
733 int isrel,
734 int islogrel,
735 int iswhen,
736 struct gl_list_t *indices)
737 {
738 register struct TypeDescription *result;
739 #if MAKEARRAYNAMES
740 char name[64];
741 #endif
742 if ((result =FindArray(mod,desc,isint,isrel,islogrel,iswhen,indices))==NULL){
743 TMALLOC(result);
744 result->t = array_type;
745 #if MAKEARRAYNAMES
746 sprintf(name,"array_%lu",g_array_desc_count++);
747 result->name = AddSymbol(name);
748 #else
749 result->name = NULL;
750 #endif
751 result->refines = NULL;
752 result->refiners = NULL;
753 result->parseid = g_parse_count++;
754 result->mod = mod;
755 result->children = NULL;
756 result->init = NULL;
757 result->stats = NULL;
758 result->universal = 0;
759 result->flags = 0;
760 result->flags |= TYPESHOW;
761 result->ref_count = 1;
762 result->u.array.indices = indices;
763 result->u.array.isintset = isint;
764 result->u.array.isrelation = isrel;
765 result->u.array.islogrel = islogrel;
766 result->u.array.iswhen = iswhen;
767 if (desc) CopyTypeDesc(desc);
768 result->u.array.desc = desc;
769 AddArray(result);
770 }
771 else{ /* array type already exists */
772 if (indices){
773 gl_iterate(indices,(void (*)(VOIDPTR))DestroyIndexType);
774 gl_destroy(indices);
775 }
776 }
777 return result;
778 }
779
780 struct TypeDescription *CreateRelationTypeDesc(struct module_t *mod,
781 ChildListPtr clist,
782 struct gl_list_t *plist,
783 struct StatementList *statl,
784 unsigned long int bytesize,
785 struct ChildDesc *childd)
786 {
787 struct TypeDescription *result;
788 TMALLOC(result);
789 result->t = relation_type;
790 result->ref_count = 1;
791 result->name = GetBaseTypeName(relation_type);
792 result->refines = NULL;
793 result->refiners = NULL;
794 result->parseid = g_parse_count++;
795 result->mod = mod;
796 result->children = clist;
797 result->init = plist;
798 result->stats = statl;
799 result->universal = 0;
800 result->flags = 0;
801 result->flags |= StatListHasDefaults(statl);
802 result->flags |= TYPESHOW;
803 result->u.atom.byte_length = bytesize;
804 result->u.atom.childinfo = childd;
805 result->u.atom.defaulted = 0;
806 result->u.atom.defval = 0.0;
807 result->u.atom.dimp = NULL;
808 return result;
809 }
810
811
812 struct TypeDescription *CreateLogRelTypeDesc(struct module_t *mod,
813 ChildListPtr clist,
814 struct gl_list_t *plist,
815 struct StatementList *statl,
816 unsigned long int bytesize,
817 struct ChildDesc *childd)
818 {
819 struct TypeDescription *result;
820 TMALLOC(result);
821 result->t = logrel_type;
822 result->ref_count = 1;
823 result->name = GetBaseTypeName(logrel_type);
824 result->refines = NULL;
825 result->refiners = NULL;
826 result->parseid = g_parse_count++;
827 result->mod = mod;
828 result->children = clist;
829 result->init = plist;
830 result->stats = statl;
831 result->universal = 0;
832 result->flags = 0;
833 result->flags |= StatListHasDefaults(statl);
834 result->flags |= TYPESHOW;
835 result->u.atom.byte_length = bytesize;
836 result->u.atom.childinfo = childd;
837 result->u.atom.defaulted = 0;
838 result->u.atom.defval = 0.0;
839 result->u.atom.dimp = NULL;
840 result->u.atom.u.defbool = 0;
841 return result;
842 }
843
844
845 struct TypeDescription
846 *CreateWhenTypeDesc(struct module_t *mod, /* module it is defined in */
847 struct gl_list_t *plist,
848 struct StatementList *statl)
849 {
850 struct TypeDescription *result;
851 TMALLOC(result);
852 result->ref_count = 1;
853 result->t = when_type;
854 result->name = GetBaseTypeName(when_type);
855 result->refines = NULL;
856 result->refiners = NULL;
857 result->parseid = g_parse_count++;
858 result->mod = mod;
859 result->children = NULL;
860 result->init = plist;
861 result->stats = statl;
862 result->universal = 0;
863 result->flags = 0;
864 result->flags |= TYPESHOW;
865 return result;
866 }
867
868
869 struct TypeDescription
870 *CreatePatchTypeDesc(symchar *name, /* name of the type*/
871 struct TypeDescription *rdesc,/* type that it patches*/
872 struct module_t *mod, /* module patch was defined */
873 struct gl_list_t *pl, /* procedures */
874 struct StatementList *sl) /* declarative */
875 {
876 register struct TypeDescription *result;
877 assert(rdesc!=NULL); /* mandatory */
878 TMALLOC(result);
879 result->ref_count = 1;
880 result->t = patch_type;
881 result->name = name;
882 result->refines = rdesc;
883 result->refiners = NULL;
884 result->parseid = g_parse_count++;
885 if (rdesc!=NULL) CopyTypeDesc(rdesc);
886 result->mod = mod;
887 result->children = NULL;
888 result->init = pl;
889 result->stats = sl;
890 result->flags = 0;
891 result->flags |= StatListHasDefaults(sl);
892 result->flags |= TYPESHOW;
893 result->universal = 0;
894 return result;
895 }
896
897
898 struct TypeDescription *MoreRefined(CONST struct TypeDescription *desc1,
899 CONST struct TypeDescription *desc2)
900 {
901 register CONST struct TypeDescription *ptr1,*ptr2;
902 AssertAllocatedMemory(desc1,sizeof(struct TypeDescription));
903 AssertAllocatedMemory(desc2,sizeof(struct TypeDescription));
904 if (desc1->t!=desc2->t) return NULL; /* base types unequal */
905 ptr1 = desc1;
906 ptr2 = desc2;
907 while (((ptr1!=NULL)||(ptr2!=NULL))&&(ptr1!=desc2)&&(ptr2!=desc1)){
908 if (ptr1!=NULL) ptr1 = ptr1->refines;
909 if (ptr2!=NULL) ptr2 = ptr2->refines;
910 }
911 if (ptr1==desc2) {
912 /* desc1 is more refined */
913 return (struct TypeDescription *)desc1;
914 }
915 if (ptr2==desc1) {
916 /* desc2 is more refined */
917 return (struct TypeDescription *)desc2;
918 }
919 return NULL; /* unconformable */
920 }
921
922 struct ancestor {
923 CONST struct TypeDescription *d;
924 struct ancestor *next;
925 };
926 #define CreateAncestor(p) \
927 (p) = (struct ancestor *)ascmalloc(sizeof(struct ancestor))
928 #define DestroyAncestor(p) ascfree(p)
929 /*
930 * produce a list of ancestors starting at a base type and
931 * continuing through d;
932 */
933 static struct ancestor *CreateAncestorList(CONST struct TypeDescription *d) {
934 struct ancestor *list=NULL, *new;
935 while (d!=NULL) {
936 CreateAncestor(new);
937 new->d = d;
938 new->next = list;
939 list = new;
940 d = d->refines;
941 }
942 return list;
943 }
944
945 static void DestroyAncestorList(struct ancestor *list) {
946 struct ancestor *old;
947 while (list != NULL) {
948 old = list;
949 list = list->next;
950 DestroyAncestor(old);
951 }
952 }
953
954 CONST struct TypeDescription *
955 GreatestCommonAncestor(CONST struct TypeDescription *d1,
956 CONST struct TypeDescription *d2)
957 {
958 CONST struct TypeDescription *result;
959 struct ancestor *head1, *head2, *a1, *a2;
960 if (d1==d2) {
961 return d1;
962 }
963 if (d1 == NULL || d2 == NULL || d1->t != d2->t) {
964 return NULL; /* base types unequal */
965 }
966 a1 = head1 = CreateAncestorList(d1);
967 a2 = head2 = CreateAncestorList(d2);
968 assert(a1!=NULL);
969 assert(a2!=NULL);
970 /* now we know the head1->d == head2->d by construction, unless the
971 * types in question are of MODEL, which has no base.
972 * So walk, looking one step ahead for type incompatibility
973 * or the end of either list.
974 */
975 while (a1->next != NULL && /* stop if a1 is at its last node */
976 a2->next != NULL && /* stop if a2 is at its last node */
977 a1->next->d == a2->next->d /* stop if next is incompatible */) {
978 a1 = a1->next;
979 a2 = a2->next;
980 }
981 /* we are now at the last place a1 and a2 are compatible
982 * or we are stuck at the head of each list so may
983 * return a1 or a2 ->d if both are the same, else NULL.
984 */
985 result = (a1->d==a2->d) ? a1->d : NULL;
986 DestroyAncestorList(head1);
987 DestroyAncestorList(head2);
988 return result;
989 }
990
991 struct gl_list_t *GetAncestorNames(CONST struct TypeDescription *d)
992 {
993 struct gl_list_t *result;
994 AssertAllocatedMemory(d,sizeof(struct TypeDescription));
995 assert((d->t&ERROR_KIND)==0);
996 assert(d->ref_count > 0);
997 result = gl_create(4L);
998 while (GetRefinement(d) != NULL) {
999 d = GetRefinement(d);
1000 gl_append_ptr(result,(VOIDPTR)GetName(d));
1001 }
1002 return result;
1003 }
1004
1005 ChildListPtr GetChildListF(CONST struct TypeDescription *d)
1006 {
1007 AssertAllocatedMemory(d,sizeof(struct TypeDescription));
1008 assert((d->t&ERROR_KIND)==0);
1009 assert(d->ref_count > 0);
1010 return (CONST ChildListPtr)(d->children);
1011 }
1012
1013 enum type_kind GetBaseTypeF(CONST struct TypeDescription *d)
1014 {
1015 AssertAllocatedMemory(d,sizeof(struct TypeDescription));
1016 assert((d->t&ERROR_KIND)==0);
1017 assert(d->ref_count > 0);
1018 return d->t;
1019 }
1020
1021 CONST struct StatementList *GetStatementListF(CONST struct TypeDescription *d)
1022 {
1023 AssertAllocatedMemory(d,sizeof(struct TypeDescription));
1024 assert((d->t&ERROR_KIND)==0);
1025 assert(d->ref_count > 0);
1026 return d->stats;
1027 }
1028
1029 struct gl_list_t *GetInitializationListF(CONST struct TypeDescription *d)
1030 {
1031 AssertAllocatedMemory(d,sizeof(struct TypeDescription));
1032 assert((d->t&ERROR_KIND)==0);
1033 assert(d->ref_count > 0);
1034 return d->init;
1035 }
1036
1037 /* This recursively adds a method to d and its refiners.
1038 * When following a refiner trail, if we reach a type that
1039 * has a method with the same name as new, that type remains
1040 * undisturbed and that trail stops. This is because that
1041 * other definition of the method in the new type would supercede the
1042 * proc we are inserting in the ancestor type if the method
1043 * had been written in the ancestor when first the ancestor
1044 * was parsed.
1045 *
1046 * The method pointer this is called with does not become
1047 * part of anything. if it is kept, it is by copying.
1048 *
1049 * Due to the implementation of the base MODEL methods in
1050 * a global list, this function will allow you to Add
1051 * a method with the same name as a global one. This is
1052 * inconsistent but desirable. If you wish to disallow that,
1053 * then the filter should be in AddMethods, not in this function.
1054 */
1055 static
1056 void RealAddMethod(struct TypeDescription *d, struct InitProcedure *new)
1057 {
1058 unsigned long c;
1059 struct gl_list_t *opl;
1060 struct InitProcedure *old, *copy;
1061 struct gl_list_t *refiners;
1062
1063 assert(d != NULL);
1064 assert(new != NULL);
1065
1066 opl = GetInitializationList(d);
1067 old = SearchProcList(opl,ProcName(new));
1068 if (old != NULL) {
1069 return;
1070 }
1071 copy = CopyProcedure(new);
1072 gl_insert_sorted(opl,copy,(CmpFunc)CmpProcs);
1073 refiners = GetRefiners(d);
1074 if (refiners != NULL) {
1075 for (c=gl_length(refiners); c > 0; c--) {
1076 d = (struct TypeDescription *)gl_fetch(refiners,c);
1077 RealAddMethod(d,new);
1078 }
1079 }
1080 }
1081
1082 static
1083 void RealReplaceMethod(struct TypeDescription *d, struct InitProcedure *new)
1084 {
1085 unsigned long c,pos;
1086 struct gl_list_t *opl;
1087 struct InitProcedure *old = NULL, *copy;
1088 struct gl_list_t *refiners;
1089
1090 assert(d != NULL);
1091 assert(new != NULL);
1092
1093 opl = GetInitializationList(d);
1094 pos = gl_search(opl,new,(CmpFunc)CmpProcs);
1095
1096 if ((pos == 0) || (0 != (old = (struct InitProcedure *)gl_fetch(opl,pos))),
1097 GetProcParseId(old) > GetProcParseId(new)) {
1098 return; /* type never had it or type redefined it */
1099 }
1100 copy = CopyProcedure(new);
1101 gl_store(opl,pos,copy);
1102 DestroyProcedure(old);
1103 refiners = GetRefiners(d);
1104 if (refiners != NULL) {
1105 c = gl_length(refiners);
1106 for (; c > 0; c--) {
1107 d = (struct TypeDescription *)gl_fetch(refiners,c);
1108 RealReplaceMethod(d,new);
1109 }
1110 }
1111 }
1112
1113 /* what's legal in the next two functions is different and needs
1114 * different checking.
1115 */
1116 int AddMethods(struct TypeDescription *d, struct gl_list_t *pl, int err)
1117 {
1118 unsigned long c,len;
1119 int old;
1120 struct gl_list_t *opl;
1121 struct InitProcedure *newproc, *oldproc;
1122 if (d==NULL) {
1123 return 1;
1124 }
1125 if (err!= 0) {
1126 FPRINTF(ASCERR, "%sADD METHODS abandoned due to previous syntax errors.\n",
1127 StatioLabel(3));
1128 return 1;
1129 }
1130 if (d == ILLEGAL_DEFINITION) {
1131 /* stick in UNIVERSAL list */
1132 opl = GetUniversalProcedureList();
1133 if (opl == NULL) {
1134 SetUniversalProcedureList(pl);
1135 return 0;
1136 }
1137 len = gl_length(pl);
1138 for (c = 1; c <= len; c++) {
1139 newproc = (struct InitProcedure *)gl_fetch(pl,c);
1140 oldproc = SearchProcList(opl,ProcName(newproc));
1141 if (oldproc != NULL) {
1142 err++;
1143 FPRINTF(ASCERR,
1144 "%s: ADD METHODS cannot replace MODEL DEFINITION METHOD %s.\n",
1145 StatioLabel(3),SCP(ProcName(newproc)));
1146 DestroyProcedure(newproc);
1147 } else {
1148 gl_append_ptr(opl,newproc);
1149 }
1150 }
1151 SetUniversalProcedureList(opl);
1152 gl_destroy(pl);
1153 return (int)err;
1154 } else {
1155 if (pl==NULL) {
1156 return 0;
1157 }
1158 old = ClaimNewMethodsTypeDesc(GetParseId(d),pl);
1159 if (old) {
1160 return 1; /* we want virgin pl only */
1161 }
1162 len = gl_length(pl);
1163 opl = GetInitializationList(d);
1164 for (c = 1; c <= len; c++) {
1165 newproc = (struct InitProcedure *)gl_fetch(pl,c);
1166 oldproc = SearchProcList(opl,ProcName(newproc));
1167 if (oldproc != NULL) {
1168 err++;
1169 /* should whine something here */
1170 FPRINTF(ASCERR,
1171 "%s: ADD METHODS cannot replace METHOD %s in type %s.\n",
1172 StatioLabel(3),SCP(ProcName(newproc)),SCP(GetName(d)));
1173 } else {
1174 RealAddMethod(d,newproc);
1175 /* find and copy to destinations recursively */
1176 }
1177 }
1178 if (!err) {
1179 DestroyProcedureList(pl);
1180 return 0;
1181 }
1182 return 1;
1183 }
1184 }
1185
1186 int ReplaceMethods(struct TypeDescription *d,struct gl_list_t *pl, int err)
1187 {
1188 unsigned long c,len,pos;
1189 int old;
1190 struct gl_list_t *opl;
1191 struct InitProcedure *newproc, *oldproc;
1192
1193 if (d==NULL) {
1194 return 1;
1195 }
1196 if (err!= 0) {
1197 FPRINTF(ASCERR,
1198 "%sREPLACE METHODS abandoned due to previous syntax errors.\n",
1199 StatioLabel(3));
1200 return 1;
1201 }
1202 if (d == ILLEGAL_DEFINITION) {
1203 /* replace in UNIVERSAL list */
1204 opl = GetUniversalProcedureList();
1205 if (opl == NULL) {
1206 SetUniversalProcedureList(pl);
1207 return 0;
1208 }
1209 len = gl_length(pl);
1210 for (c = 1; c <= len; c++) {
1211 newproc = (struct InitProcedure *)gl_fetch(pl,c);
1212 pos = gl_search(opl,newproc,(CmpFunc)CmpProcs);
1213 if (pos == 0) {
1214 err++;
1215 FPRINTF(ASCERR,
1216 "%s: REPLACE METHODS cannot ADD method %s in MODEL DEFINITION.\n",
1217 StatioLabel(3),SCP(ProcName(newproc)));
1218 DestroyProcedure(newproc);
1219 } else {
1220 oldproc = (struct InitProcedure *)gl_fetch(opl,pos);
1221 gl_store(opl,pos,newproc);
1222 DestroyProcedure(oldproc);
1223 }
1224 }
1225 SetUniversalProcedureList(opl);
1226 gl_destroy(pl);
1227 return (int)err;
1228 } else {
1229 if (pl==NULL) {
1230 return 0;
1231 }
1232 old = ClaimNewMethodsTypeDesc(GetParseId(d),pl);
1233 if (old) {
1234 return 1; /* we want virgin pl only */
1235 }
1236 len = gl_length(pl);
1237 opl = GetInitializationList(d);
1238 for (c = 1; c <= len; c++) {
1239 newproc = (struct InitProcedure *)gl_fetch(pl,c);
1240 oldproc = SearchProcList(opl,ProcName(newproc));
1241 if (oldproc == NULL) {
1242 err++;
1243 FPRINTF(ASCERR,
1244 "%s: REPLACE METHODS cannot add METHOD %s in type %s.\n",
1245 StatioLabel(3),SCP(ProcName(newproc)),SCP(GetName(d)));
1246 } else {
1247 RealReplaceMethod(d,newproc);
1248 /* find and copy to destinations (existing) recursively */
1249 }
1250 }
1251 if (!err) {
1252 DestroyProcedureList(pl);
1253 return 0;
1254 }
1255 return 1;
1256 }
1257 }
1258
1259 void CopyTypeDescF(struct TypeDescription *d)
1260 {
1261 AssertAllocatedMemory(d,sizeof(struct TypeDescription));
1262 assert((d->t&ERROR_KIND)==0);
1263 assert(d->ref_count > 0);
1264 d->ref_count++;
1265 }
1266
1267 void DeleteNewTypeDesc(struct TypeDescription *d)
1268 {
1269 if (d->ref_count!=1) {
1270 FPRINTF(ASCERR,"New type definition %s with unexpectedly high ref_count\n",
1271 SCP(GetName(d)));
1272 }
1273 DeleteTypeDesc(d);
1274 }
1275
1276 void DeleteTypeDesc(struct TypeDescription *d)
1277 {
1278 AssertAllocatedMemory(d,sizeof(struct TypeDescription));
1279 assert((d->t&ERROR_KIND)==0);
1280 assert(d->ref_count > 0);
1281 --d->ref_count;
1282 if (d->ref_count == 0){
1283 #if (TYPELINKDEBUG)
1284 FPRINTF(ASCERR,"Deleteing type: %s, parseid %ld\n",
1285 d->name,GetParseId(d));
1286 #endif
1287 switch(d->t){
1288 case relation_type:
1289 case logrel_type:
1290 case real_type:
1291 case boolean_type:
1292 case integer_type:
1293 case set_type:
1294 case symbol_type:
1295 if (d->u.atom.childinfo && d->children)
1296 DestroyChildDescArray(d->u.atom.childinfo,
1297 ChildListLen(d->children));
1298 break;
1299 case array_type:
1300 if (d->u.array.desc) DeleteTypeDesc(d->u.array.desc);
1301 if (d->u.array.indices){
1302 gl_iterate(d->u.array.indices,(void (*)(VOIDPTR))DestroyIndexType);
1303 gl_destroy(d->u.array.indices);
1304 }
1305 RemoveArrayTypeDesc(d);
1306 break;
1307 case model_type:
1308 DestroyStatementList(d->u.modarg.declarations);
1309 DestroyStatementList(d->u.modarg.absorbed);
1310 DestroyStatementList(d->u.modarg.reductions);
1311 DestroyStatementList(d->u.modarg.wheres);
1312 /* not in use. probably needs to be smarter if it was.
1313 if (d->u.modarg.argdata!=NULL) {
1314 gl_destroy(d->u.modarg.argdata);
1315 }
1316 */
1317 break;
1318 case patch_type:
1319 break;
1320 case when_type:
1321 break;
1322 case dummy_type:
1323 break;
1324 default:
1325 break;
1326 }
1327 if (d->refines != NULL) {
1328 UnLinkTypeDesc(d->refines,d); /* tell ancestor to forget d */
1329 DeleteTypeDesc(d->refines); /* remove d's reference to ancestor */
1330 /* d->refines->refiners isn't a reference. */
1331 }
1332 if (d->refiners!=NULL) {
1333 assert(gl_length(d->refiners)==0); /* non 0 => bad refcount */
1334 gl_destroy(d->refiners);
1335 }
1336 if (d->children!=NULL) {
1337 DestroyChildList(d->children);
1338 }
1339 DestroyStatementList(d->stats);
1340 DestroyProcedureList(d->init);
1341 d->t = ERROR_KIND; /* should be error_type. patch will do */
1342 d->parseid = -(d->parseid); /* flip the sign */
1343 ascfree(d);
1344 }
1345 }
1346
1347 unsigned GetByteSizeF(CONST struct TypeDescription *d)
1348 {
1349 AssertAllocatedMemory(d,sizeof(struct TypeDescription));
1350 assert((d->t&ERROR_KIND)==0);
1351 assert(d->ref_count > 0);
1352 return (unsigned)d->u.atom.byte_length;
1353 }
1354
1355 CONST struct ChildDesc *GetChildDescF(CONST struct TypeDescription *d)
1356 {
1357 AssertAllocatedMemory(d,sizeof(struct TypeDescription));
1358 assert((d->t&ERROR_KIND)==0);
1359 assert(d->ref_count > 0);
1360 return d->u.atom.childinfo;
1361 }
1362
1363 int GetUniversalFlagF(CONST struct TypeDescription *d)
1364 {
1365 AssertAllocatedMemory(d,sizeof(struct TypeDescription));
1366 assert((d->t&ERROR_KIND)==0);
1367 assert(d->ref_count > 0);
1368 return d->universal;
1369 }
1370
1371 unsigned short int GetTypeFlagsF(CONST struct TypeDescription *d)
1372 {
1373 AssertAllocatedMemory(d,sizeof(struct TypeDescription));
1374 assert((d->t&ERROR_KIND)==0);
1375 assert(d->ref_count > 0);
1376 return d->flags;
1377 }
1378
1379 unsigned int TypeHasDefaultStatementsF(CONST struct TypeDescription *d)
1380 {
1381 AssertAllocatedMemory(d,sizeof(struct TypeDescription));
1382 assert((d->t&ERROR_KIND)==0);
1383 assert(d->ref_count > 0);
1384 return (d->flags & TYPECONTAINSDEFAULTS);
1385 }
1386
1387 unsigned int TypeHasParameterizedInstsF(CONST struct TypeDescription *d)
1388 {
1389 AssertAllocatedMemory(d,sizeof(struct TypeDescription));
1390 assert((d->t&ERROR_KIND)==0);
1391 assert(d->ref_count > 0);
1392 return (d->flags & TYPECONTAINSPARINSTS);
1393 }
1394
1395
1396 double GetRealDefaultF(CONST struct TypeDescription *d,
1397 CONST char *file, CONST int line)
1398 {
1399 AssertAllocatedMemory(d,sizeof(struct TypeDescription));
1400 assert((d->t&ERROR_KIND)==0);
1401 assert(d->ref_count > 0);
1402 if (GetBaseType(d)==real_type) {
1403 return d->u.atom.u.defval;
1404 } else {
1405 error_reporter(ASC_PROG_ERROR,file,line,NULL,"GetRealDefault called without real_type");
1406 return 0.0;
1407 }
1408 }
1409
1410 unsigned GetBoolDefaultF(CONST struct TypeDescription *d,
1411 CONST char *file, CONST int line)
1412 {
1413 AssertAllocatedMemory(d,sizeof(struct TypeDescription));
1414 assert((d->t&ERROR_KIND)==0);
1415 assert(d->ref_count > 0);
1416 if (GetBaseType(d)==boolean_type) {
1417 return d->u.atom.u.defbool;
1418 } else {
1419 error_reporter(ASC_PROG_ERROR,file,line,NULL,"GetBoolDefault called without boolean_type");
1420 return 0;
1421 }
1422 }
1423
1424 CONST dim_type *GetRealDimensF(CONST struct TypeDescription *d,
1425 CONST char *file, CONST int line)
1426 {
1427 AssertAllocatedMemory(d,sizeof(struct TypeDescription));
1428 assert((d->t&ERROR_KIND)==0);
1429 assert(d->ref_count > 0);
1430 if (BaseTypeIsAtomic(d)) {
1431 return d->u.atom.dimp;
1432 } else {
1433 error_reporter(ASC_PROG_ERROR,file,line,NULL,"GetRealDimens called non-atom type");
1434 return WildDimension();
1435 }
1436 }
1437
1438 CONST dim_type *GetConstantDimensF(CONST struct TypeDescription *d,
1439 CONST char *file, CONST int line)
1440 {
1441 AssertAllocatedMemory(d,sizeof(struct TypeDescription));
1442 assert((d->t&ERROR_KIND)==0);
1443 assert(d->ref_count > 0);
1444 if (GetBaseType(d)==real_constant_type ||
1445 GetBaseType(d)==integer_constant_type ||
1446 GetBaseType(d)==boolean_constant_type ||
1447 GetBaseType(d)==symbol_constant_type) {
1448 return d->u.constant.dimp;
1449 } else {
1450 error_reporter(ASC_PROG_ERROR,file,line,NULL,"GetConstDimens called without constant type");
1451 return WildDimension();
1452 }
1453 }
1454
1455 symchar *GetNameF(CONST struct TypeDescription *d)
1456 {
1457 AssertAllocatedMemory(d,sizeof(struct TypeDescription));
1458 assert((d->t&ERROR_KIND)==0);
1459 assert(d->ref_count > 0);
1460 return d->name;
1461 }
1462
1463 int TypesAreEquivalent(CONST struct TypeDescription *d1,
1464 CONST struct TypeDescription *d2)
1465 {
1466 unsigned long n;
1467
1468 if (d1 == d2) {
1469 return 1;
1470 }
1471 if (d1->t != d2->t ||
1472 d1->name != d2->name ||
1473 d1->universal != d2->universal ||
1474 d1->refines != d2->refines) {
1475 return 0; /* basetype, univ, symtab name, ancestor must be == */
1476 }
1477 /*
1478 * check special things, then for all types, check stats, init.
1479 */
1480 switch (d1->t) {
1481 case real_type:
1482 if (d1->u.atom.defaulted != d2->u.atom.defaulted ||
1483 (d1->u.atom.defaulted &&
1484 d1->u.atom.u.defval != d2->u.atom.u.defval) ||
1485 d1->u.atom.dimp != d2->u.atom.dimp
1486 ) {
1487 return 0;
1488 }
1489 break;
1490 case boolean_type:
1491 if (d1->u.atom.defaulted != d2->u.atom.defaulted ||
1492 (d1->u.atom.defaulted &&
1493 d1->u.atom.u.defbool != d2->u.atom.u.defbool)
1494 ) {
1495 return 0;
1496 }
1497 break;
1498 case integer_type:
1499 if (d1->u.atom.defaulted != d2->u.atom.defaulted ||
1500 (d1->u.atom.defaulted &&
1501 d1->u.atom.u.defint != d2->u.atom.u.defint)
1502 ) {
1503 return 0;
1504 }
1505 break;
1506 case symbol_type:
1507 if (d1->u.atom.defaulted != d2->u.atom.defaulted ||
1508 (d1->u.atom.defaulted &&
1509 d1->u.atom.u.defsym != d2->u.atom.u.defsym)
1510 ) {
1511 return 0;
1512 }
1513 break;
1514 case real_constant_type:
1515 if (d1->u.constant.defaulted != d2->u.constant.defaulted ||
1516 (d1->u.constant.defaulted &&
1517 d1->u.constant.u.defreal != d2->u.constant.u.defreal) ||
1518 d1->u.constant.dimp != d2->u.constant.dimp
1519 ) {
1520 return 0;
1521 }
1522 break;
1523 case boolean_constant_type:
1524 if (d1->u.constant.defaulted != d2->u.constant.defaulted ||
1525 (d1->u.constant.defaulted &&
1526 d1->u.constant.u.defboolean != d2->u.constant.u.defboolean)
1527 ) {
1528 return 0;
1529 }
1530 break;
1531 case integer_constant_type:
1532 if (d1->u.constant.defaulted != d2->u.constant.defaulted ||
1533 (d1->u.constant.defaulted &&
1534 d1->u.constant.u.definteger != d2->u.constant.u.definteger)
1535 ) {
1536 return 0;
1537 }
1538 break;
1539 case symbol_constant_type:
1540 if (d1->u.constant.defaulted != d2->u.constant.defaulted ||
1541 (d1->u.constant.defaulted &&
1542 d1->u.constant.u.defsymbol != d2->u.constant.u.defsymbol)
1543 ) {
1544 return 0;
1545 }
1546 break;
1547 case set_type: /* odd! */
1548 case relation_type:
1549 /* fall through */
1550 case logrel_type:
1551 break;
1552 case array_type:
1553 return 0; /* array types are weird */
1554 case model_type:
1555 if (
1556 CompareStatementLists(
1557 d1->u.modarg.declarations,
1558 d2->u.modarg.declarations,&n) != 0 ||
1559 CompareStatementLists(
1560 d1->u.modarg.absorbed,
1561 d2->u.modarg.absorbed,&n) != 0 ||
1562 CompareStatementLists(
1563 d1->u.modarg.reductions,
1564 d2->u.modarg.reductions,&n) != 0 ||
1565 CompareStatementLists(
1566 d1->u.modarg.wheres,
1567 d2->u.modarg.wheres,&n) != 0 ||
1568 CompareChildLists( d1->children, d2->children,&n) != 0
1569 ) {
1570 return 0;
1571 }
1572 /* not in use. probably needs to be smarter if it was.
1573 * if (d->u.modarg.argdata!=NULL) {
1574 * }
1575 */
1576 break;
1577 case patch_type:
1578 return 0; /* patches are not to be checked in detail */
1579 case when_type:
1580 case dummy_type:
1581 return 0; /* not to be checked. and should never be sent. */
1582 default:
1583 return 0; /* say what? */
1584 }
1585 /*
1586 *if (d->refiners!=NULL) {
1587 * we don't care who REFINES us, we're only comparing these two.
1588 * presumably one is new and won't have refiners yet.
1589 *}
1590 */
1591 if (CompareStatementLists(d1->stats,d2->stats,&n) != 0 ||
1592 CompareProcedureLists(d1->init,d2->init,&n) != 0) {
1593 return 0;
1594 }
1595 return 1; /* if everything checks, return 1; */
1596 }
1597
1598 void DifferentVersionCheck(CONST struct TypeDescription *desc1,
1599 CONST struct TypeDescription *desc2)
1600 {
1601 register CONST struct TypeDescription *ptr;
1602 int erred;
1603 erred = 0;
1604 AssertAllocatedMemory(desc1,sizeof(struct TypeDescription));
1605 AssertAllocatedMemory(desc2,sizeof(struct TypeDescription));
1606
1607 if (desc1->t != desc2->t) return;
1608 ptr = desc1;
1609 while (ptr){
1610 if (!CmpSymchar(ptr->name,desc2->name)){
1611 erred = 1;
1612 FPRINTF(ASCERR,"%s and %s are conformable by name;",
1613 SCP(desc1->name), SCP(desc2->name));
1614 FPRINTF(ASCERR,"but they are unconformable because of different");
1615 FPRINTF(ASCERR,"different type versions.\n");
1616 }
1617 ptr = ptr->refines;
1618 }
1619 ptr = desc2;
1620 while (ptr){
1621 if (!CmpSymchar(ptr->name,desc1->name)) {
1622 erred = 1;
1623 FPRINTF(ASCERR,"%s and %s are conformable by name;",
1624 SCP(desc1->name), SCP(desc2->name));
1625 FPRINTF(ASCERR,"but they are unconformable because of different");
1626 FPRINTF(ASCERR,"type versions.\n");
1627 }
1628 ptr = ptr->refines;
1629 }
1630 if (erred) {
1631 FPRINTF(ASCERR,"Different versions caused by previous redefinition\n");
1632 FPRINTF(ASCERR,
1633 "Try writing values, deleting all types, and recompiling\n");
1634 }
1635 }
1636
1637 struct TypeDescription *GetStatTypeDesc(CONST struct Statement *s) {
1638 symchar *tn;
1639 if (s==NULL) return NULL;
1640 switch(StatementType(s)) {
1641 case ISA:
1642 case WILLBE:
1643 case IRT:
1644 tn = GetStatType(s);
1645 if (tn!=NULL && tn != GetBaseTypeName(set_type)) {
1646 return FindType(tn);
1647 }
1648 break;
1649 case ALIASES:
1650 case ARR:
1651 case ATS:
1652 case WBTS:
1653 case WNBTS:
1654 case AA:
1655 case FOR:
1656 case REL:
1657 case LOGREL:
1658 case ASGN:
1659 case CASGN:
1660 case WHEN:
1661 case FNAME:
1662 case SELECT:
1663 case EXT:
1664 case REF:
1665 case COND:
1666 case RUN:
1667 case CALL:
1668 case IF:
1669 break;
1670 default:
1671 FPRINTF(ASCERR,"GetStatTypeDesc called with unknown stat type\n");
1672 }
1673 return NULL;
1674 }
1675
1676 void WriteArrayTypeList(FILE *f) {
1677 struct ArrayDescList *ptr;
1678 unsigned long count = 0L;
1679
1680 FPRINTF(f,"Number of descriptions made: %lu\n",g_array_desc_count);
1681 ptr = g_array_desc_list;
1682 if (ptr!=NULL) {
1683 FPRINTF(f,"Descriptions:\n");
1684 }
1685 while (ptr!=NULL) {
1686 count++;
1687 if (ptr->desc!=NULL) {
1688 WriteDefinition(f,ptr->desc);
1689 } else {
1690 FPRINTF(f," *** NULL Description! ***\n");
1691 }
1692 ptr = ptr->next;
1693 }
1694 FPRINTF(f,"Number of descriptions current: %lu\n",count);
1695 }
1696
1697
1698 unsigned TypeShowF(CONST struct TypeDescription *d)
1699 {
1700 AssertAllocatedMemory(d,sizeof(struct TypeDescription));
1701 assert((d->t&ERROR_KIND)==0);
1702 return (d->flags & TYPESHOW);
1703 }
1704
1705
1706 void SetTypeShowBit(struct TypeDescription *d, int value)
1707 {
1708 AssertAllocatedMemory(d,sizeof(struct TypeDescription));
1709 assert((d->t&ERROR_KIND)==0);
1710 if (value) {
1711 d->flags |= TYPESHOW;
1712 } else {
1713 d->flags &= ~TYPESHOW;
1714 }
1715 }
1716

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