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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 613 - (show annotations) (download) (as text)
Wed May 17 05:09:17 2006 UTC (14 years, 6 months ago) by johnpye
File MIME type: text/x-csrc
File size: 50170 byte(s)
Fixing to use temporary filename instead of /tmp/atmlist
1 /* ASCEND modelling environment
2 Copyright 1997, Carnegie Mellon University
3 Copyright (C) 2006 Carnegie Mellon University
4
5 This program is free software; you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation; either version 2, or (at your option)
8 any later version.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
14
15 You should have received a copy of the GNU General Public License
16 along with this program; if not, write to the Free Software
17 Foundation, Inc., 59 Temple Place - Suite 330,
18 Boston, MA 02111-1307, USA.
19 *//**
20 @file
21 Anonymous ASCEND IV type classification functions.
22 *//*
23 By Benjamin Andrew Allan
24 Created August 30, 1997.
25 Copyright 1997, Carnegie Mellon University.
26 Version: $Revision: 1.9 $
27 Version control file: $RCSfile: anontype.c,v $
28 Date last modified: $Date: 2000/01/25 02:25:55 $
29 Last modified by: $Author: ballan $
30 */
31
32 #include <limits.h> /* for LONG_MAX */
33 #include <utilities/ascConfig.h>
34 #include <utilities/ascMalloc.h>
35 #include <utilities/ascPanic.h>
36 #include <utilities/ascPrint.h>
37 #include <general/list.h>
38 #include <general/dstring.h>
39 #include "compiler.h"
40 #if TIMECOMPILER
41 #include <time.h>
42 #include <general/tm_time.h>
43 #endif
44 #include "fractions.h"
45 #include "dimen.h"
46 #include "child.h"
47 #include "type_desc.h"
48 #include "instance_enum.h"
49 #include "types.h"
50 #include "instance_types.h"
51 #include "tmpnum.h"
52 #include "atomvalue.h"
53 #include "mathinst.h"
54 #include "parentchild.h"
55 #include "instquery.h"
56 #include "visitinst.h"
57 #include "instance_io.h"
58 #include "instance_name.h"
59 #include "anonmerg.h"
60 #include "anontype.h"
61
62 #ifndef lint
63 static CONST char AnonTypeModuleID[] = "$Id: anontype.c,v 1.9 2000/01/25 02:25:55 ballan Exp $";
64 #endif
65
66 /*
67 * Yo! Pinhead! Don't optimize anything until it has proved slow!
68 */
69
70 /* These two macros are defined again in the portion of this file
71 * dealing with MODEL/array classification. They should not be used
72 * elsewhere.
73 */
74 #define GAIN(inst) GetInstanceAnonIndex(inst)
75 #define GAP(atp) Asc_GetAnonPrototype(atp)
76
77 /* hash function for type name pointers.
78 * assumes 1024 table size.
79 */
80 #define TYPEHASHINDEX(p) (((((long) (p))*1103515245) >> 20) & 1023)
81
82 /*
83 * write merge list before returning.
84 */
85 #define AWAL 1
86 #if AWAL
87 # include <stdio.h>
88 #endif
89
90
91 /*
92 * enum for use in sorting compound types
93 */
94 enum search_status {
95 at_notdone, /* weirdness */
96 at_exact, /* duplicate instance */
97 at_previous, /* insert */
98 at_append /* new entry at list tail */
99 };
100
101 /*
102 * Each bucket in the hash table will correspond to one formal type.
103 * A doubly linked list of the formal type's anonymous refinements
104 * is kept in the bucket. It's a linked list because we may have
105 * lots of AT for constant or ATOM types, though usually there are
106 * not many for MODEL types.
107 *
108 * We may need to add another field to accomodate anonymous, but
109 * formal in the sense that the system maintains an internal type
110 * description of some kind, array types.
111 */
112 struct AnonBucket {
113 struct AnonBucket *next; /* next hash element */
114 struct TypeDescription *d; /* type for this bucket. */
115 struct AnonType *anonlist; /* ptr to an AnonType */
116 unsigned long indirected; /* subscript number for arrays */
117 int size; /* length of anonlist, the number of
118 * anonymous types based on formal type d.
119 */
120 };
121
122 /*
123 * A bundle of stuff to pass around with visit functions.
124 */
125 struct AnonVisitInfo {
126 struct AnonBucket **t;
127 struct gl_list_t *atl;
128 struct Instance *root;
129 int errors;
130 int nextfamily; /* counter for getting unique exactfamily numbers */
131 /* there is no direct sortability to nextfamily values */
132 };
133
134 static
135 struct AnonBucket **CreateAnonTable(size_t size)
136 {
137 struct AnonBucket **t;
138 size_t i;
139 t = (struct AnonBucket **)
140 ascmalloc(sizeof(struct AnonBucket *)*size);
141 if (t==NULL) {
142 return t;
143 }
144 for (i=0; i < size; i++) {
145 t[i] = NULL;
146 }
147 return t;
148 }
149
150 /*
151 * Destroys the table array and its buckets, but the AT's
152 * in the buckets are not destroyed as they are assumed to be
153 * kept in the gl_list, atl.
154 */
155 static
156 void DestroyAnonTable(struct AnonBucket **t)
157 {
158 int i;
159 struct AnonBucket *b;
160 for (i=0; i < ANONTABLESIZE; i++) {
161 while (t[i] !=NULL) {
162 b = t[i];
163 t[i] = t[i]->next;
164 b->size = -1;
165 /* AT data in b->anonlist is assumed to be kept elsewhere */
166 ascfree(b);
167 }
168 }
169 ascfree(t);
170 }
171
172 /*
173 * This is noisy and fatal if d or t is NULL and NDEBUG is not
174 * present. Otherwise it returns 0 if d & t != NULL or 1 if OTHERWISE.
175 */
176 static
177 int AssertBucketInfo(struct TypeDescription *d, struct AnonBucket **t)
178 {
179 if (d==NULL) {
180 #ifndef NDEBUG
181 Asc_Panic(2,"AssertBucketInfo","Called with NULL TypeDescription");
182 #else
183 return 1;
184 #endif
185 }
186 if (t==NULL) {
187 #ifndef NDEBUG
188 Asc_Panic(2,"AssertBucketInfo","Called with NULL Bucket table");
189 #else
190 return 1;
191 #endif
192 }
193 return 0;
194 }
195
196 /*
197 * Returns the bucket for the type given from the
198 * table, if there is such a bucket. The tabled is
199 * keyed by string, and then element is matched by type pointer.
200 * In the case of arrays, it is also necessary to key by level
201 * of indirection or we might try to match enums to ints which
202 * is really a bad thing.
203 */
204 static
205 struct AnonBucket *FindAnonBucket(struct TypeDescription *d,
206 unsigned long indirected,
207 struct AnonBucket **t)
208 {
209 struct AnonBucket *result;
210 int index;
211 if (AssertBucketInfo(d,t)) {
212 return NULL;
213 }
214 index = TYPEHASHINDEX(SCP(GetName(d)));
215 result = t[index];
216 while (result != NULL &&
217 (d != result->d || /* not type wanted */
218 (indirected != LONG_MAX && /* is array */
219 indirected != result->indirected /*wrong level*/
220 )
221 )
222 ) {
223 result = result->next;
224 }
225 return result;
226 }
227
228 /*
229 * Creates a table entry for the formal type d. Returns
230 * NULL if d was already in the table or out of memory.
231 * Returns the entry in normal circumstances.
232 * Initially there are no AT's associated with the table.
233 */
234 static
235 struct AnonBucket *AddAnonBucket(struct TypeDescription *d,
236 unsigned long indirected,
237 struct AnonBucket **t)
238 {
239 struct AnonBucket *b;
240 int index;
241 if (AssertBucketInfo(d,t)!=0 || FindAnonBucket(d,indirected,t) != NULL) {
242 return NULL;
243 }
244 b = (struct AnonBucket *)ascmalloc(sizeof(struct AnonBucket));
245 if (b == NULL) {
246 return NULL;
247 }
248 index = TYPEHASHINDEX(SCP(GetName(d)));
249 b->next = t[index];
250 t[index] = b;
251 b->d = d;
252 b->indirected = indirected;
253 b->anonlist = NULL;
254 b->size = 0;
255 return b;
256 }
257
258 /*
259 * Insert 'at' in anonlist of b after the AT 'after'.
260 * after == NULL --> insert at head of anonlist of b.
261 */
262 static
263 void InsertAnonType(struct AnonBucket *b, struct AnonType *at,
264 struct AnonType *after)
265 {
266 (b->size)++;
267 at->prev = after;
268 if (after == NULL) {
269 /* insert at head of anonlist */
270 at->next = b->anonlist;
271 if (b->anonlist != NULL) {
272 /* This check shouldn't be necessary, as b was created with 1st
273 * element of anonlist, yes? hmm.
274 */
275 b->anonlist->prev = at;
276 }
277 b->anonlist = at;
278 } else {
279 at->next = after->next;
280 if (at->next != NULL) {
281 /* are we appending the bucket list? */
282 at->next->prev = at;
283 }
284 after->next = at;
285 }
286 }
287
288 /* Create an AT and append to the user's ultimate result.
289 * also return the at for further configuration.
290 */
291 static
292 struct AnonType *ExpandAnonResult(struct gl_list_t *atl)
293 {
294 struct AnonType *at;
295 at = (struct AnonType *)ascmalloc(sizeof(struct AnonType));
296 if (at==NULL) {
297 Asc_Panic(2,"ExpandAnonResult","Insufficient memory");
298 return NULL; /* NOTREACHED */
299 }
300 gl_append_ptr(atl,(void *)at);
301 at->index = gl_length(atl);
302 at->next = at->prev = NULL;
303 at->visited = 0;
304 at->exactfamily = 0;
305 at->instances = gl_create(INSTANCES_PER_AT);
306 return at;
307 }
308
309 /*
310 * Returns the first element of the instance list associated with the
311 * AT given. Does not normally return unless there is such a creature.
312 */
313 struct Instance *Asc_GetAnonPrototype(struct AnonType *at)
314 {
315 struct Instance *i;
316 assert(at != NULL);
317 assert(at->instances != NULL);
318 assert(gl_length(at->instances));
319 i = (struct Instance *)gl_fetch(at->instances,1);
320 return i;
321 }
322
323 /* wrapper to simplify the logic for dealing with
324 * unassigned ATOM values and avoid RAV whine..
325 * cheating - we're just cheating. The biggest
326 * value specifiable in the parser by symbolic means
327 * is DBL_MAX/(1+1e-15), which varies from DBL_MAX
328 * in digits 13-16. Don't tell me there are any
329 * physically meaningful numbers near DBL_MAX - the
330 * floating point discretization error alone is
331 * 1e+291 at best.
332 */
333 static
334 double AnonRealAtomValue(struct Instance *i)
335 {
336 if (!AtomAssigned(i)) {
337 return DBL_MAX;
338 } else {
339 return RealAtomValue(i);
340 }
341 }
342
343 /* In the following atom/constant cases it is simply cheaper to
344 * check the value directly instead of checking first to see that
345 * the FT defines value or dimensionality.
346 * In all atom-like cases, we are ignoring subatomic structure,
347 * since all subatomic values are variable and their existence
348 * determined by the FT of the atom.
349 * The lists are ordered so insertion/search are faster.
350 *
351 * Anon type -> FT, dimens, value, unassigned comes before values
352 * in each dimensionally compatible subset of the list.
353 * Can we just redo this entirely? That whole wild/unassigned
354 * business make this thing just way too combinatorial.
355 */
356 static
357 struct AnonType *NearestAnonTypeRC(struct Instance *i, struct AnonType *after,
358 int *exact)
359 {
360 struct AnonType *testat;
361 CONST dim_type *dim;
362 struct Instance *testi = NULL; /* unnec init to avoid warning */
363 double val;
364
365 if (after==NULL) {
366 *exact = 0;
367 return after;
368 }
369 testat = after;
370 dim = RealAtomDims(i);
371 /* find same dimens. sorted by increasing dim address. */
372 while (testat != NULL &&
373 ((testi = GAP(testat)), dim > RealAtomDims(testi))) {
374 /* C comma syntax: testi = in the logic above does nothing to
375 * the logic, except make the second test possible.
376 */
377 after = testat;
378 testat = testat->next;
379 }
380 if (testat == after && dim != RealAtomDims(testi)) {
381 /* dimen to insert at head */
382 *exact = 0;
383 return NULL;
384 }
385 /* Now either testat == NULL, in which case done, or need to check
386 * value because dim(testi(testat)) == dim(i).
387 * We get rid of the NULL case so we can cope more easily with
388 * unassigned.
389 */
390 if (testat == NULL) {
391 /* off end */
392 *exact = 0;
393 return after;
394 }
395
396 val = AnonRealAtomValue(i);
397 /* Find same value. Sorted by decreasing value. */
398 while (testat != NULL &&
399 ((testi = GAP(testat)), dim == RealAtomDims(testi)) &&
400 val < AnonRealAtomValue(testi)) {
401 /* C comma syntax: testi = in the logic above does nothing to
402 * the logic, except make the second test possible.
403 */
404 after = testat;
405 testat = testat->next;
406 }
407 if (testat == NULL) {
408 /* off end */
409 *exact = 0;
410 return after;
411 }
412 if (val > AnonRealAtomValue(testi) ||
413 dim != RealAtomDims(testi)) {
414 /* insert at head or after */
415 *exact = 0;
416 if (testat != after) {
417 return after;
418 } else {
419 return NULL; /* insert @ head */
420 }
421 }
422 *exact = 1;
423 return testat;
424 }
425
426 /* Anon type -> FT, dimens, not subatomic dimens since they may be
427 * reassignable eventually, as in lagrange multipliers.
428 * In any case subatomic dimen cannot affect compiled structure.
429 * So, the only sort criteria is really just DIMENSION ptr,
430 * because we're all in the same FT type.
431 */
432 static
433 struct AnonType *NearestAnonTypeRA(struct Instance *i,
434 struct AnonType *after,
435 int *exact)
436 {
437 struct AnonType *testat;
438 CONST dim_type *dim;
439 struct Instance *testi = NULL;
440
441 if (after==NULL) {
442 *exact = 0;
443 return after;
444 }
445 dim = RealAtomDims(i);
446 /* check for add at front */
447 if (dim < RealAtomDims(GAP(after))) {
448 *exact = 0;
449 return NULL;
450 }
451 testat = after;
452 /* find same dimens. sorted by decreasing dim address. */
453 while (testat != NULL &&
454 ((testi = GAP(testat)), dim > RealAtomDims(testi))) {
455 /* C comma syntax: testi = in the logic above does nothing to
456 * the logic, except make the second test possible.
457 */
458 after = testat;
459 testat = testat->next;
460 }
461 /* ran off end of anonlist? */
462 if (testat == NULL) {
463 *exact = 0;
464 return after; /* Works if after NULL or not. */
465 }
466 if (dim == RealAtomDims(testi)) {
467 *exact = 1;
468 return testat;
469 } else {
470 *exact = 0;
471 return after; /* insert at head */
472 }
473 }
474
475 /*
476 * cheating, we're just cheating.
477 * the parser has been jiggered so that the max int
478 * symbolically defined is machine LONG_MAX-1.
479 */
480 static
481 long AnonIntegerAtomValue(CONST struct Instance *i)
482 {
483 if (AtomAssigned(i)) {
484 return GetIntegerAtomValue(i);
485 } else {
486 return LONG_MAX;
487 }
488 }
489
490 /* Anon type -> FT, value.
491 * buggy: need to handle unassigned as a special case at
492 * beginning of list.
493 * as it is, unassigned and long_max are lumped together
494 * in the hope that no one ever uses long_max.
495 * The parser has been adjusted in evil ways to make this
496 * less likely.
497 */
498 static
499 struct AnonType *NearestAnonTypeIC(struct Instance *i,
500 struct AnonType *after,
501 int *exact)
502 {
503 struct AnonType *testat;
504 CONST struct Instance *testi = NULL;
505 long val;
506
507 if (after==NULL) {
508 *exact = 0;
509 return after;
510 }
511 val = AnonIntegerAtomValue(i);
512 /* check for add at front */
513 if (val >AnonIntegerAtomValue(GAP(after))) {
514 *exact = 0;
515 return NULL;
516 }
517 /* Find same value. Sorted by decreasing integer value. */
518 testat = after;
519 while (testat != NULL &&
520 ((testi = GAP(testat)), val < AnonIntegerAtomValue(testi))) {
521 /* C comma syntax: testi = in the logic above does nothing to
522 * the logic, except make the second test possible.
523 */
524 after = testat;
525 testat = testat->next;
526 }
527 /* ran off end of anonlist? */
528 if (testat == NULL) {
529 *exact = 0;
530 return after; /* Works if after NULL or not. */
531 }
532 if ( val == AnonIntegerAtomValue(testi) ) {
533 /* stopped within list on a match */
534 *exact = 1;
535 return testat;
536 } else {
537 /* stopped on insertion point */
538 *exact = 0;
539 return after;
540 }
541 }
542
543 /*
544 * returns the symbol_atom value of i, or NULL if
545 * i is not assigned. This wrapper keeps us from
546 * hitting whine or assertions in atomvalue.c.
547 */
548 static
549 symchar *GetAnonInstSymbol(CONST struct Instance *i)
550 {
551 if (AtomAssigned(i)) {
552 return GetSymbolAtomValue(i);
553 } else {
554 return NULL;
555 }
556 }
557
558 /* Anon type -> FT, value.
559 * Unassigned constant detected merely by NULL symchar value,
560 * so just sorting by ptr will handle unassigned.
561 */
562 static
563 struct AnonType *NearestAnonTypeSC(struct Instance *i,
564 struct AnonType *after,
565 int *exact)
566 {
567 struct AnonType *testat;
568 CONST struct Instance *testi = NULL;
569 symchar *val;
570
571 if (after==NULL) {
572 *exact = 0;
573 return after;
574 }
575 val = GetAnonInstSymbol(i);
576 /* check for add at front */
577 if (val < GetAnonInstSymbol(GAP(after))) {
578 *exact = 0;
579 return NULL;
580 }
581 /* Find same value. Sorted by increasing ptr value.
582 * alpha no matter, and both must be from symbol table.
583 */
584 testat = after;
585 while (testat != NULL &&
586 ((testi = GAP(testat)), val > GetAnonInstSymbol(testi))) {
587 /* C comma syntax: testi = in the logic above does nothing to
588 * the logic, except make the second test possible.
589 */
590 after = testat;
591 testat = testat->next;
592 }
593 /* ran off end of anonlist? */
594 if (testat == NULL) {
595 *exact = 0;
596 return after; /* Works if after NULL or not. */
597 }
598 if ( val == GetAnonInstSymbol(testi) ) {
599 /* stopped within list on a match */
600 *exact = 1;
601 return testat;
602 } else {
603 /* stopped on insertion point */
604 *exact = 0;
605 return after;
606 }
607 }
608
609 /* Anon type -> FT, value.
610 */
611 static
612 struct AnonType *NearestAnonTypeBC(struct Instance *i,
613 struct AnonType *after,
614 int *exact)
615 {
616 struct AnonType *testat;
617 CONST struct Instance *testi = NULL;
618 int val;
619
620 if (after == NULL) {
621 *exact = 0;
622 return after;
623 }
624 testat = after;
625 testi = GAP(testat);
626 /* sort order is UNDEFINED,T,F or UNDEFINED,F,T */
627 if (!AtomAssigned(i)) {
628 if (!AtomAssigned(testi)) {
629 *exact = 1; /* there already */
630 return after;
631 } else {
632 *exact = 0; /* add undefined at head */
633 return NULL;
634 }
635 } else {
636 /* i is not unassigned */
637 val = GetBooleanAtomValue(i);
638 if (!AtomAssigned(testi)) {
639 /* unassigned first list element */
640 if (testat->next == NULL) {
641 *exact = 0; /* unassigned only */
642 return after;
643 } else {
644 testat = testat->next; /* move to first assigned AT and value */
645 testi = GAP(testat);
646 } /* else T/F first */
647 }
648 }
649 /* T/F first (possibly after undefined) */
650 if (val != GetBooleanAtomValue(testi)) {
651 if (testat->next != NULL) { /* return 2nd boolean */
652 *exact = 1;
653 return testat->next;
654 } else {
655 *exact = 0; /* add boolean */
656 return testat;
657 }
658 } else {
659 *exact = 1; /* return 1st boolean */
660 return testat;
661 }
662 }
663
664 /*
665 * compare two sets. want ordering undefint-undefsym-int-sym,
666 * but will settle for undefint-int-undefsym-sym.
667 * Wouldn't it be lovely if all the CmpAtomValues functions
668 * had semantics which gave us the undefined values first
669 * so that we could write one function for all the ATOM
670 * types?
671 */
672 static
673 struct AnonType *NearestAnonTypeSA(struct Instance *i,
674 struct AnonType *after,
675 int *exact)
676 {
677 struct AnonType *testat;
678 struct Instance *testi = NULL; /* initialize to satisfy dumb compilers */
679 int cmp;
680 if (after == NULL) {
681 *exact = 0;
682 return after;
683 }
684
685 /* check for add at front */
686 cmp = CmpAtomValues(i,GAP(after));
687 if (cmp < 0) {
688 *exact = 0;
689 return NULL;
690 }
691 /* Find same value. Sorted by decreasing integer value. */
692 testat = after;
693 while (testat != NULL &&
694 ((testi = GAP(testat)), CmpAtomValues(i,testi) > 0)) {
695 /* C comma syntax: testi = in the logic above does nothing to
696 * the logic, except make the second test possible.
697 */
698 after = testat;
699 testat = testat->next;
700 }
701 /* ran off end of anonlist? */
702 if (testat == NULL) {
703 *exact = 0;
704 return after; /* Works if after NULL or not. */
705 }
706 if ( CmpAtomValues(i,testi)==0 ) {
707 /* stopped within list on a match */
708 *exact = 1;
709 return testat;
710 } else {
711 /* stopped on insertion point */
712 *exact = 0;
713 return after;
714 }
715 }
716
717 /*
718 * anon type -> FT, parent FT, hollowness.
719 * We aren't doing a full treatment because parent ft is
720 * available only after a full pass with this partial treatment.
721 * Finished comes first, then hollow, in the very limited
722 * sort order. NULL is not to be here.
723 */
724 static
725 struct AnonType *NearestAnonTypeRelation(struct Instance *i,
726 struct AnonType *after,
727 int *exact)
728 {
729 CONST struct Instance *testi = NULL;
730
731 if (after != NULL) {
732 testi = GAP(after);
733 } else {
734 *exact = 0;
735 return after;
736 }
737 /* now testi != NULL */
738 if (GetInstanceRelationOnly(i) != NULL) {
739 /* i not hollow */
740 if (GetInstanceRelationOnly(testi) != NULL) {
741 /* filled already seen */
742 *exact = 1;
743 return after;
744 } else {
745 /* i is the first filled relation */
746 *exact = 0;
747 return NULL; /* add first non-hollow relation at head */
748 }
749 } else {
750 /* i hollow */
751 if (GetInstanceRelationOnly(testi) != NULL) {
752 /* filled already seen */
753 if (after->next != NULL) {
754 *exact = 1;
755 return after->next;
756 } else {
757 *exact = 0;
758 return after; /* add first hollow after head */
759 }
760 } else {
761 /* filled not seen, means only hollow left, since trapped NULL above. */
762 *exact = 1;
763 return after;
764 }
765 }
766 }
767
768 /*
769 * anon type -> FT, parent FT, hollowness.
770 * We aren't doing a full treatment because parent ft is
771 * available only after a full pass with this partial treatment.
772 * Finished comes first, then hollow, in the very limited
773 * sort order. NULL is not to be here.
774 */
775 static
776 struct AnonType *NearestAnonTypeLogRel(struct Instance *i,
777 struct AnonType *after,
778 int *exact)
779 {
780 CONST struct Instance *testi = NULL;
781
782 if (after != NULL) {
783 testi = GAP(after);
784 } else {
785 *exact = 0;
786 return after;
787 }
788 /* now testi != NULL */
789 if (GetInstanceLogRel(i) != NULL) {
790 /* i not hollow */
791 if (GetInstanceLogRel(testi) != NULL) {
792 /* filled already seen */
793 *exact = 1;
794 return after;
795 } else {
796 /* i is the first filled relation */
797 *exact = 0;
798 return NULL; /* add first non-hollow relation at head */
799 }
800 } else {
801 /* i hollow */
802 if (GetInstanceLogRel(testi) != NULL) {
803 /* filled already seen */
804 if (after->next != NULL) {
805 *exact = 1;
806 return after->next;
807 } else {
808 *exact = 0;
809 return after; /* add first hollow after head */
810 }
811 } else {
812 /* filled not seen, means only hollow left, since trapped NULL above. */
813 *exact = 1;
814 return after;
815 }
816 }
817 }
818
819 /*
820 * This function handles the special case where we want TmpNum
821 * of a NULL instance to be 0 instead of LONG_MAX as it is defined
822 * in the tmpnum header.
823 * Unclassified instances will cause an abort or be treated as
824 * if they were NULL instances. Either treatment is an error,
825 * but this should never be called on an unclassified instance.
826 */
827 static
828 unsigned long GetInstanceAnonIndex(struct Instance *i)
829 {
830 if (i != NULL) {
831 #if ATDEBUG
832 unsigned long n;
833 n = GetTmpNum(i);
834 assert(n); /* child must have been already classified! */
835 return n;
836 #else
837 return GetTmpNum(i);
838 #endif
839 } else {
840 return 0;
841 }
842 }
843
844 /*
845 * On entry, testat matches i except possibly in merges and after is either
846 * testat (and first of the FT list) or the AT before testat
847 * in the FT list.
848 */
849 static
850 enum search_status MatchATMerges(struct Instance *i,
851 struct AnonType **after_p,
852 struct AnonType **testat_p,
853 int *exactfamily)
854 {
855 struct AnonType *after;
856 struct AnonType *testat;
857 struct Instance *testi;
858 int cmp;
859 enum search_status s;
860
861 after = *after_p;
862 testat = *testat_p;
863 testi = GAP(testat);
864
865 *exactfamily = testat->exactfamily;
866 assert(*exactfamily != 0);
867 cmp = Asc_AnonMergeCmpInstances(i,testi);
868 assert(cmp != 2);
869 if (cmp == 0) {
870 s = at_exact;
871 } else {
872 if (cmp < 0) {
873 /* insert at beginning of family section of ATs */
874 s = at_previous;
875 } else {
876 /* move right until out of family, or NULL AT or found location. */
877 while (cmp > 0) {
878 if (testat->next == NULL) {
879 s = at_append; /* testat is end of at list, exact is 0 */
880 break; /* exit while early */
881 }
882 if (testat->next->exactfamily != *exactfamily) {
883 /* ok, so testat is the right edge of our exactfamily
884 * and we want to append the family.
885 */
886 s = at_append;
887 break;
888 } else {
889 /* move right */
890 after = testat;
891 testat = testat->next;
892 testi = GAP(testat);
893 cmp = Asc_AnonMergeCmpInstances(i,testi);
894 assert(cmp != 2);
895 }
896 }
897 /* cmp <= 0 but there is at least one family member i is > than. */
898 if (cmp == 0) {
899 /* found it */
900 s = at_exact;
901 } else {
902 /* passed it. insert after 'after'. */
903 s = at_previous;
904 }
905 }
906 }
907 *after_p = after;
908 *testat_p = testat;
909 return s;
910 }
911
912 /* i1, i2 assumed != and not NULL.
913 * The ArrayAnonCmp function assume that the arrays to be compared have the
914 * same array type description and level of indirection so that
915 * the basetype and set description
916 * of the subscripts are identical -- eliminates int vs enum problems.
917 */
918 static
919 int ArrayAnonCmpInt(CONST struct Instance *i1, CONST struct Instance *i2)
920 {
921 unsigned long len;
922 long n1,n2;
923 assert(i1!=NULL);
924 assert(i2!=NULL);
925 assert(i1!=i2);
926 len = NumberChildren(i1);
927 if (NumberChildren(i2)!=len) {
928 /* sort more children to later */
929 return ((len > NumberChildren(i2)) ? -1 : 1);
930 }
931 while (len > 0) {
932 n1 = InstanceIntIndex(ChildName(i1,len));
933 n2 = InstanceIntIndex(ChildName(i2,len));
934 if (n1 != n2) {
935 return ((n1 > n2) ? -1 : 1);
936 }
937 n1 = (long)GAIN(InstanceChild(i1,len));
938 n2 = (long)GAIN(InstanceChild(i2,len));
939 if (n1 != n2) {
940 return ((n1 > n2) ? -1 : 1);
941 }
942 len--;
943 }
944 return 0;
945 }
946
947 /*
948 * returns TRUE if # of children, their names, and their anon type
949 * indices are all the same.
950 */
951 static
952 int ArrayAnonCmpEnum(CONST struct Instance *i1, CONST struct Instance *i2)
953 {
954 unsigned long len;
955 long n1,n2;
956 symchar *s1, *s2;
957 assert(i1!=NULL);
958 assert(i2!=NULL);
959 assert(i1!=i2);
960 len = NumberChildren(i1);
961 if (NumberChildren(i2)!=len) {
962 /* sort more children to later */
963 return ((len > NumberChildren(i2)) ? -1 : 1);
964 }
965 while (len > 0) {
966 /* since it's internal, we sort on pointer rather than symbol content */
967 s1 = InstanceStrIndex(ChildName(i1,len));
968 s2 = InstanceStrIndex(ChildName(i2,len));
969 if (s1 != s2) {
970 return ((s1 > s2) ? -1 : 1);
971 }
972 n1 = (long)GAIN(InstanceChild(i1,len));
973 n2 = (long)GAIN(InstanceChild(i2,len));
974 if (n1 != n2) {
975 return ((n1 > n2) ? -1 : 1);
976 }
977 len--;
978 }
979 return 0;
980 }
981
982 static
983 struct AnonType *NearestAnonTypeArrayEnum(struct Instance *i,
984 struct AnonType *after,
985 int *exact,
986 int *exactfamily)
987 {
988 struct AnonType *testat;
989 struct Instance *testi;
990 enum search_status s;
991
992 if (after == NULL) {
993 *exact = 0;
994 return NULL;
995 }
996 if (ArrayAnonCmpEnum(i,GAP(after)) < 0) {
997 *exact = 0;
998 return NULL;
999 }
1000 testat = after;
1001 while (testat != NULL &&
1002 ((testi = GAP(testat)), ArrayAnonCmpEnum(i,testi) > 0)) {
1003 after = testat;
1004 testat = testat->next;
1005 }
1006 if (testat == NULL) {
1007 /* append */
1008 *exact = 0;
1009 return after;
1010 }
1011 if (testat == after) {
1012 /* didn't enter while, and < case ruled out before entry */
1013 /* check for mergedness same here. if not identical,
1014 * return 0 for *exact and cause append or insert(ret NULL) of new AT.
1015 * i and testi are in the same family.
1016 */
1017 s = MatchATMerges(i,&after,&testat,exactfamily);
1018 switch (s) {
1019 case at_exact:
1020 *exact = 1;
1021 return testat;
1022 case at_previous:
1023 *exact = 0;
1024 return NULL; /* new AT at head of list */
1025 case at_append:
1026 *exact = 0;
1027 return after;
1028 case at_notdone:
1029 /* we screwed up */
1030 default:
1031 Asc_Panic(2,"NearestAnonTypeArrayInt","Returning while not (1) done");
1032 exit(2); /* NOTREACHED, but quiets gcc */
1033 }
1034 }
1035 if (ArrayAnonCmpEnum(i,GAP(after)) < 0) {
1036 *exact = 0;
1037 return after;
1038 } else {
1039 s = MatchATMerges(i,&after,&testat,exactfamily);
1040 switch (s) {
1041 case at_exact:
1042 *exact = 1;
1043 return testat;
1044 case at_previous:
1045 *exact = 0;
1046 return after; /* new AT at head of family */
1047 case at_append:
1048 *exact = 0;
1049 return after;
1050 case at_notdone:
1051 /* we screwed up */
1052 default:
1053 Asc_Panic(2,"NearestAnonTypeArrayInt","Returning while not (2) done");
1054 exit(2); /* NOTREACHED, but quiets gcc */
1055 }
1056 }
1057 }
1058
1059 /*
1060 * The anonymous type of an array is really determined by its
1061 * formal type (statement+basetype) and it parent MODEL's anonymous
1062 * type. But since we work bottom up, we instead classify by
1063 * the system generated array typedescription, the # of children,
1064 * and the subscript name/AT of each child.
1065 * This classification function looks rather simple, mainly
1066 * because the real dirt goes on in the ArrayAnonCmpInt call.
1067 *
1068 * We also have to compare mergedness of arrays of models/vars.
1069 */
1070 static
1071 struct AnonType *NearestAnonTypeArrayInt(struct Instance *i,
1072 struct AnonType *after,
1073 int *exact,
1074 int *exactfamily)
1075 {
1076
1077 struct AnonType *testat;
1078 struct Instance *testi;
1079 enum search_status s;
1080
1081 if (after == NULL) {
1082 *exact = 0;
1083 return NULL;
1084 }
1085 if (ArrayAnonCmpInt(i,GAP(after)) < 0) {
1086 *exact = 0;
1087 return NULL;
1088 }
1089 testat = after;
1090 while (testat != NULL &&
1091 ((testi = GAP(testat)), ArrayAnonCmpInt(i,testi) > 0)) {
1092 after = testat;
1093 testat = testat->next;
1094 }
1095 /* at this point, testi is from after */
1096 if (testat == NULL) {
1097 /* append */
1098 *exact = 0;
1099 return after;
1100 }
1101 if (testat == after) {
1102 /* didn't enter while, and < case ruled out before entry */
1103 /* check for mergedness same here. if not identical,
1104 * return 0 for *exact and cause append or insert(ret NULL) of new AT.
1105 * i and testi are in the same family.
1106 */
1107 s = MatchATMerges(i,&after,&testat,exactfamily);
1108 switch (s) {
1109 case at_exact:
1110 *exact = 1;
1111 return testat;
1112 case at_previous:
1113 *exact = 0;
1114 return NULL; /* new AT at head of list */
1115 case at_append:
1116 *exact = 0;
1117 return after;
1118 case at_notdone:
1119 /* we screwed up */
1120 default:
1121 Asc_Panic(2,"NearestAnonTypeArrayInt","Returning while not (1) done");
1122 exit(2); /* NOTREACHED, but quiets gcc */
1123 }
1124 }
1125 if (ArrayAnonCmpInt(i,GAP(after)) < 0) {
1126 *exact = 0;
1127 return after;
1128 } else {
1129 s = MatchATMerges(i,&after,&testat,exactfamily);
1130 switch (s) {
1131 case at_exact:
1132 *exact = 1;
1133 return testat;
1134 case at_previous:
1135 *exact = 0;
1136 return after; /* new AT at head of family */
1137 case at_append:
1138 *exact = 0;
1139 return after;
1140 case at_notdone:
1141 /* we screwed up */
1142 default:
1143 Asc_Panic(2,"NearestAnonTypeArrayInt","Returning while not (2) done");
1144 exit(2); /* NOTREACHED, but quiets gcc */
1145 }
1146 }
1147 }
1148
1149 /*
1150 * anon type -> FT, child ATs
1151 * Now, this is an interesting function. The idea is that we want
1152 * as simple as data structure as can be reasonably had and still
1153 * find exact matches (or the need for a new AT) in linear time.
1154 * Presumably a sorted strucure is faster as it permits us to do
1155 * fewer than nAT comparisons of the instance being classified
1156 * against the anonlist.
1157 * The minimum time to diagnose an exact match of two instances,
1158 * assuming all children already classified or NULL, is linear
1159 * in the number of children.
1160 * So the sort order/search can be explained with the following
1161 * example assume for a formal type there are 5 existing ATs.
1162 * Represent each AT as a column of numbers where the numbers
1163 * are the AT->index of each child. Here nAT == 5.
1164 * example anonlist linked in order abcde instance to be classified:
1165 * AT: a b c d e CH f
1166 * CH:------------------------------------ -
1167 * 1'| 1* 1 1 1 1 1^ 1*
1168 * 2'| 2* 2* 3* 3 3 2^ 3*
1169 * 3'| 3 4 3* 4* 4 3^ 4*
1170 * 4'| 5 5 5 5*< 5 4^ 4*
1171 * 5'| 6 6 6 6 7 5^ 6
1172 *
1173 * The maximum cost is k*(nAT+nCH) integer comparisons.
1174 * We can search by doing integer comparisons with the *'d numbers.
1175 * When we reach the final point where 4' > 4^ (index 5 > 4)
1176 * we no we have a new at and it should go in before AT d.
1177 *
1178 * So, the logic required for this picture is given in the function body.
1179 * The obscuring boundary case (there's always one of those :-() is
1180 * what to do with NULL instances. They can be most conveniently dealt
1181 * with by assigning them all (regardless of eventual kind) the
1182 * AT index of 0 (convenient since real indices start at 1, as they
1183 * are stored in a gl_list). Unfortunately, this makes a special case
1184 * out of them for TmpNum purposes because GetTmpNum returns
1185 * LONG_MAX when it is called on a NULL instance. It would be nice
1186 * if TmpNum had originally been designed to return 0 on NULL,
1187 * but we can't mess with the TmpNum convention now.
1188 * We get rid of the special case with a TmpNum wrapper.
1189 * This function is really the pivot for the design of the
1190 * rest of the file.
1191 *
1192 * The above tells most of the story. In addition to comparing
1193 * anonymous types of children, we must then also compare the
1194 * merges listed on the instance being classified. Things are
1195 * going to be down-right twisty, but the basic idea of the
1196 * picture above still holds. The comparison of merges in
1197 * effect adds an extra row (think of the merges, in toto, as
1198 * a really weird child). Very seldom in practical models will
1199 * a merge comparison turn up anything other than equal, but
1200 * we must do it to have a correct compiler.
1201 *
1202 * Note that we could do the rightward search in the grid above
1203 * on the children by looking at the child's at index. Merge
1204 * information isn't typed, however, so we can't use it as a
1205 * criteria for moving (and stopping) rightward. So we invent
1206 * the exact family identifier in an AT. A set of AT's which
1207 * are identical up to (but not including) the merge information
1208 * will all have the same family identifier. Within a family
1209 * identifier group, a comparison search (initially linear until
1210 * we prove it needs speedup) for the proper place to add an
1211 * instance is necessary.
1212 *
1213 * exactfamily is assumed to hold 0 on entry. If an instance matches
1214 * an existing AT up to but not including the merged descendant
1215 * information, then exactfamily will be set to the family id of
1216 * the group the instance belongs to.
1217 */
1218 static
1219 struct AnonType *NearestAnonTypeModel(struct Instance *i,
1220 struct AnonBucket *b,
1221 int *exact,
1222 int *exactfamily)
1223 {
1224 /* make the code more compact but not too obscure with GAIN,GAP */
1225
1226 struct AnonType *testat, *after;
1227 CONST struct Instance *testi = NULL;
1228 unsigned long index, testindex; /* 0 = NULL child */
1229 unsigned long c,len;
1230 enum search_status s;
1231
1232 assert(b!=NULL);
1233 after = b->anonlist;
1234 #if ATDEBUG
1235 FPRINTF(ASCERR,"NearestAnonTypeModel: checking children\n",c);
1236 #endif
1237 if (after == NULL) {
1238 *exact = 0;
1239 return after;
1240 }
1241 len = ChildListLen(GetChildList(b->d));
1242 if (!len) {
1243 /* childless --> AT == FT */
1244 *exact = 1;
1245 return after;
1246 }
1247 s = at_notdone;
1248 #if ATDEBUG
1249 FPRINTF(ASCERR,"NearestAnonTypeModel: at_notdone set starting len = %lu\n",len);
1250 #endif
1251 testat = after;
1252 /* for loop will be entered */
1253 for (c = 1; c <= len && s == at_notdone; c++) {
1254 index = GAIN(InstanceChild(i,c));
1255 testi = GAP(testat); /* if at never changes, this is redundant,
1256 * but redundant is cheaper than the logic
1257 * to avoid redundancy.
1258 */
1259 testindex = GAIN(InstanceChild(testi,c));
1260 while (testindex < index) {
1261 if (testat->next == NULL) {
1262 s = at_append; /* testat is end of at list, exact is 0 */
1263 #if ATDEBUG
1264 FPRINTF(ASCERR,"NearestAnonTypeModel: at_append set (index=%lu, testindex=%lu)\n",index, testindex);
1265 #endif
1266 break; /* exit while early */
1267 } else {
1268 /* move right */
1269 #if ATDEBUG
1270 FPRINTF(ASCERR,"NearestAnonTypeModel: moving right(index=%lu, testindex=%lu)\n",index, testindex);
1271 #endif
1272 after = testat;
1273 testat = testat->next;
1274 testi = GAP(testat);
1275 testindex = GAIN(InstanceChild(testi,c));
1276 }
1277 }
1278 /* append, or testindex >= index. = -> on to next child, > -> insert. */
1279 if (s == at_notdone && testindex > index) {
1280 s = at_previous; /* insert new at between after, testat */
1281 #if ATDEBUG
1282 FPRINTF(ASCERR,"NearestAnonTypeModel: at_previous set at c = %lu (index=%lu, testindex=%lu)\n",c, index, testindex);
1283 #endif
1284 break; /* exit for early */
1285 }
1286 /* index == test index */
1287 }
1288
1289 #if ATDEBUG
1290 FPRINTF(ASCERR,"NearestAnonTypeModel: after loop c = %lu, s = %d\n",c,s);
1291 #endif
1292 if (c > len && s == at_notdone) {
1293 /* now we have to compare the merge lists, sigh. The for loop
1294 * leaves us with the first AT in our exact family.
1295 */
1296 s = MatchATMerges(i,&after,&testat,exactfamily);
1297 }
1298 #if ATDEBUG
1299 FPRINTF(ASCERR,"NearestAnonTypeModel: after merge check c = %lu, s = %d\n",c,s);
1300 #endif
1301
1302 switch (s) {
1303 case at_exact:
1304 *exact = 1;
1305 return testat;
1306 case at_previous:
1307 *exact = 0;
1308 if (after == testat) {
1309 /* very first at in formal type list */
1310 return NULL;
1311 } else {
1312 /* we moved 1 past the place after which i belongs */
1313 return after;
1314 }
1315 case at_append:
1316 /* we are at the place after which i belongs */
1317 *exact = 0;
1318 return testat;
1319 case at_notdone:
1320 /* we screwed up */
1321 default:
1322 Asc_Panic(2,"NearestAnonTypeModel","Returning while not done");
1323 exit(2); /* NOTREACHED, but quiets gcc */
1324 }
1325 }
1326
1327 /*
1328 * This is where the evil comparisons and linked list traversal are
1329 * all distributed. Particularly complex cases are arrays/models.
1330 * We're searching for the AT nearest to the yet undetermined
1331 * AT of i. All the children of compound i are assumed already
1332 * classified or NULL. b is the bucket for the formal type of
1333 * i. *exact is returned 1 if match is found, or 0 if not.
1334 * If not, then the AT returned is the AT in b after which the
1335 * new AT that i implies should be inserted.
1336 * In the comments of this function, CT -> context, FT -> formal type.
1337 * By the time we reach this function, there isn't a question of
1338 * competing types with the same name, so anything determined entirely
1339 * by the formal type of the bucket, b, will have a bucket with length
1340 * 0 or 1. Every existing AT encountered is assumed to have at least
1341 * 1 instance associated with it.
1342 *
1343 * exactfamily will be 0 and meaningless if the match is exact.
1344 * it will be 0 if the match is inexact and a new family is
1345 * needed (only arrays and models need families at all, but it
1346 * doesn't hurt to give all ATs a family so we do. If exactfamily
1347 * is nonzero, then the AT to be created (because exact will be 0)
1348 * should have as its family id the value of *exactfamily.
1349 */
1350 static
1351 struct AnonType *NearestAnonType(struct Instance *i,
1352 struct AnonBucket *b,
1353 int *exact,
1354 int *exactfamily)
1355 {
1356
1357 *exactfamily = 0;
1358 switch(InstanceKind(i)) {
1359 case REAL_CONSTANT_INST:
1360 return NearestAnonTypeRC(i,b->anonlist,exact); /* done? */
1361 case REAL_ATOM_INST:
1362 return NearestAnonTypeRA(i,b->anonlist,exact); /* done */
1363 case INTEGER_CONSTANT_INST:
1364 return NearestAnonTypeIC(i,b->anonlist,exact); /* done */
1365 case SYMBOL_CONSTANT_INST:
1366 return NearestAnonTypeSC(i,b->anonlist,exact); /* done */
1367 case BOOLEAN_CONSTANT_INST:
1368 return NearestAnonTypeBC(i,b->anonlist,exact); /* done */
1369 case SET_ATOM_INST:
1370 return NearestAnonTypeSA(i,b->anonlist,exact); /* done */
1371
1372 case ARRAY_ENUM_INST:
1373 return NearestAnonTypeArrayEnum(i,b->anonlist,exact,exactfamily);
1374 case ARRAY_INT_INST:
1375 return NearestAnonTypeArrayInt(i,b->anonlist,exact,exactfamily);
1376
1377 case MODEL_INST:
1378 return NearestAnonTypeModel(i,b, /* need the whole bucket */
1379 exact, exactfamily);
1380
1381 /* For all the following anon type -> FT.
1382 * either there's already an AT or there isn't.
1383 * Strictly speaking, the wheninst is determined by parent AT,
1384 * but this is not available.
1385 */
1386 case INTEGER_ATOM_INST: /* FALL THROUGH */
1387 case SYMBOL_ATOM_INST: /* FALL THROUGH */
1388 case BOOLEAN_ATOM_INST: /* FALL THROUGH */
1389 case WHEN_INST: /* FALL THROUGH */
1390 case DUMMY_INST:
1391 *exact = (b->anonlist != NULL);
1392 return b->anonlist; /* done */
1393
1394 /* log/rels can be one of: (NULL not seen), created hollow, or done. */
1395 case REL_INST: /* done? */
1396 return NearestAnonTypeRelation(i,b->anonlist,exact);
1397 case LREL_INST: /* done? */
1398 return NearestAnonTypeLogRel(i,b->anonlist,exact);
1399
1400 /* For these anon type -> FT, but who cares? we don't classify these. */
1401 case REAL_INST: /* FALL THROUGH */
1402 case INTEGER_INST: /* FALL THROUGH */
1403 case SYMBOL_INST: /* FALL THROUGH */
1404 case BOOLEAN_INST: /* FALL THROUGH */
1405 case SET_INST:
1406 Asc_Panic(2,"NearestAnonType","Called with subatomic instance");
1407 return NULL; /* NOT REACHED, but shuts up gcc */
1408
1409 case SIM_INST:
1410 Asc_Panic(2,"NearestAnonType","Called with SIM_INST kind");
1411 return NULL; /* NOT REACHED, but shuts up gcc */
1412
1413 default:
1414 Asc_Panic(2,"NearestAnonType","Called with unknown instance kind");
1415 return NULL; /* NOT REACHED, but shuts up gcc */
1416 }
1417 }
1418
1419 /*
1420 * Classifies each instance it visits, based on data in info
1421 * and instance tmpnums. Do not visit children of atoms with this
1422 * function because it will crash as intended.
1423 * This assumes all the children of the visited models/arrays have
1424 * already been classified, so it will need a bottom-up visit.
1425 */
1426 static
1427 void DeriveAnonType(struct Instance *i, struct AnonVisitInfo *info)
1428 {
1429 struct AnonType *at, *after;
1430 struct AnonBucket *b;
1431 int exact =0, exactfamily;
1432
1433 if (i==NULL) {
1434 info->errors++;
1435 Asc_Panic(2,"DeriveAnonType","Function called with NULL instance");
1436 return;
1437 }
1438 if (GetTmpNum(i) != 0L) {
1439 FPRINTF(ASCERR,"Deriving already visited instance!\n");
1440 WriteInstanceName(ASCERR,i,info->root);
1441 FPRINTF(ASCERR,"\n");
1442 return;
1443 }
1444 b = FindAnonBucket(InstanceTypeDesc(i),InstanceIndirected(i),info->t);
1445 if (b == NULL) {
1446 b = AddAnonBucket(InstanceTypeDesc(i),InstanceIndirected(i),info->t);
1447 if (b == NULL) {
1448 Asc_Panic(2,"DeriveAnonType","AddAnonBucket returned NULL");
1449 }
1450 }
1451 exactfamily = 0;
1452 after = NearestAnonType(i,b,&exact,&exactfamily);
1453
1454 #if ATDEBUG
1455 WriteInstanceName(ASCERR,i,info->root);
1456 FPRINTF(ASCERR,"\nexact = %d. after = 0x%p\n",exact,(void *)after);
1457 #endif
1458
1459 if (!exact) {
1460 at = ExpandAnonResult(info->atl); /* create, add to atl , set index */
1461 if (exactfamily != 0) {
1462 at->exactfamily = exactfamily;
1463 } else {
1464 at->exactfamily = ++(info->nextfamily);
1465 }
1466 InsertAnonType(b,at,after);
1467
1468 #if ATDEBUG
1469 FPRINTF(ASCERR,"\tnew-at = 0x%p\n",(void *)at);
1470 #endif
1471
1472 } else {
1473 at = after;
1474 }
1475 gl_append_ptr(at->instances,(void *)i);
1476 /* make damn sure this doesn't give us a big list of universal instances
1477 * all identical. If it does, visit needs fixing.
1478 */
1479 SetTmpNum(i,at->index);
1480 }
1481
1482 static
1483 void DestroyAnonType(struct AnonType *at)
1484 {
1485 if (at == NULL) {
1486 return;
1487 }
1488 gl_destroy(at->instances);
1489 ascfree(at);
1490 }
1491
1492 void Asc_DestroyAnonList(struct gl_list_t *l)
1493 {
1494 unsigned long c,len;
1495 if (l==NULL) {
1496 return;
1497 }
1498 len = gl_length(l);
1499 for (c = 1 ; c <= len ; c++) {
1500 DestroyAnonType((struct AnonType *)gl_fetch(l,c));
1501 }
1502 gl_destroy(l);
1503 }
1504
1505
1506 /**
1507 This function classifies an instance tree from the
1508 bottom up and returns the list described above.
1509 The list should be destroyed with Asc_DestroyAnonList.
1510 */
1511 struct gl_list_t *Asc_DeriveAnonList(struct Instance *i)
1512 {
1513 struct AnonBucket **t;
1514 struct gl_list_t *atl;
1515 struct AnonVisitInfo info;
1516 VOIDPTR vp;
1517 #if (TIMECOMPILER && AMSTAT)
1518 clock_t start,classt;
1519 #endif
1520
1521 #if AWAL
1522 char *WAL_file;
1523
1524 # ifdef __WIN32__
1525 char WAL_filename[] = "atmlist.txt";
1526 char WAL_file[PATH_MAX + 12];
1527 char *temp_path;
1528 # endif
1529
1530 #endif
1531
1532 ZeroTmpNums(i,0);
1533 t = CreateAnonTable(ANONTABLESIZE);
1534 if (t == NULL) {
1535 return NULL;
1536 }
1537 atl = gl_create(ANONEXPECTED);
1538 if (atl == NULL) {
1539 DestroyAnonTable(t);
1540 return NULL;
1541 }
1542 info.t = t;
1543 info.root = i;
1544 info.atl = atl;
1545 info.nextfamily = 1;
1546 info.errors = 0;
1547 /*
1548 * Apply function in a bottom up fashion, so that children
1549 * will all be classified before the parent is classified.
1550 */
1551 #if (TIMECOMPILER && AMSTAT)
1552 start = clock();
1553 #endif
1554 vp = Asc_AnonMergeMarkIPs(i);
1555 #if (TIMECOMPILER && AMSTAT)
1556 classt = clock();
1557 FPRINTF(ASCERR,
1558 "Mergedetect\t\t%lu\n",(unsigned long)(classt-start));
1559 #endif
1560 SilentVisitInstanceTreeTwo(i,(VisitTwoProc)DeriveAnonType,1,0,(void *)&info);
1561
1562
1563 #if AWAL
1564 {
1565 FILE *fp;
1566
1567 #if TIMECOMPILER
1568 FPRINTF(ASCERR, "start atmlist: %lu\n",(unsigned long)clock());
1569 #endif
1570
1571 #ifdef __WIN32__
1572 temp_path = getenv("TEMP"); /* put file in TEMP, if defined */
1573 if (temp_path && (PATH_MAX > strlen(temp_path))) {
1574 strcpy(WAL_file, temp_path);
1575 strcat(WAL_file, "\\");
1576 }
1577 strcat(WAL_file, WAL_filename);
1578 fp = fopen(WAL_file,"w+");
1579 #else /* !__WIN32__ */
1580 WAL_file = tmpnam(NULL);
1581 fp = fopen(WAL_file,"w+");
1582 #endif /* __WIN32__ */
1583
1584 if (fp == NULL) {
1585 FPRINTF(ASCERR, "Error opening output file '%s'in Asc_DeriveAnonList().\n",WAL_file);
1586 }else{
1587 Asc_WriteAnonList(fp, atl, i, 1);
1588 fclose(fp);
1589 }
1590
1591 #if TIMECOMPILER
1592 FPRINTF(ASCERR, "done atmlist: %lu\n",(unsigned long)clock());
1593 #endif
1594
1595 }
1596
1597 #endif /* AWAL */
1598
1599
1600 Asc_AnonMergeUnmarkIPs(vp);
1601 DestroyAnonTable(t);
1602 /* ZeroTmpNums(i,0); */
1603 /* not necessary, really, as any tn user should assume they are dirty */
1604 return atl;
1605 }
1606
1607
1608
1609
1610 static
1611 void WriteAnonType(FILE *fp, struct AnonType *at,
1612 struct Instance *root, char *simple, int mlists)
1613 {
1614 unsigned long c,len;
1615 struct Instance *i;
1616 len = gl_length(at->instances);
1617 i = GAP(at);
1618 FPRINTF(fp,"\nAT: k=%d index=%lu, count=%lu %s\n",
1619 InstanceKind(i), at->index, len,simple);
1620 if (mlists && IsCompoundInstance(i)!=0) {
1621 FPRINTF(fp," MERGES:\n");
1622 Asc_AnonMergeWriteList(fp,i);
1623 }
1624 FPRINTF(fp," ALIKE NAMES:\n");
1625 for (c=1; c <= len; c++) {
1626 i = (struct Instance *)gl_fetch(at->instances,c);
1627 FPRINTF(fp," ");
1628 WriteInstanceName(fp,i,root);
1629 FPRINTF(fp,"\n");
1630 }
1631 i = GAP(at);
1632 #if ATDEBUG
1633 WriteInstance(fp,i);
1634 #endif
1635 }
1636
1637 static
1638 void WriteAnonEpilog(FILE *fp)
1639 {
1640 FPRINTF(fp,"AT: name %d %s\n",MODEL_INST,"MODEL_INST");
1641 FPRINTF(fp,"AT: name %d %s\n",REL_INST,"REL_INST");
1642 FPRINTF(fp,"AT: name %d %s\n",LREL_INST,"LREL_INST");
1643 FPRINTF(fp,"AT: name %d %s\n",WHEN_INST,"WHEN_INST");
1644 FPRINTF(fp,"AT: name %d %s\n",ARRAY_INT_INST,"ARRAY_INT_INST");
1645 FPRINTF(fp,"AT: name %d %s\n",ARRAY_ENUM_INST,"ARRAY_ENUM_INST");
1646 FPRINTF(fp,"AT: name %d %s\n",REAL_ATOM_INST,"REAL_ATOM_INST");
1647 FPRINTF(fp,"AT: name %d %s\n",INTEGER_ATOM_INST,"INTEGER_ATOM_INST");
1648 FPRINTF(fp,"AT: name %d %s\n",BOOLEAN_ATOM_INST,"BOOLEAN_ATOM_INST");
1649 FPRINTF(fp,"AT: name %d %s\n",SYMBOL_ATOM_INST,"SYMBOL_ATOM_INST");
1650 FPRINTF(fp,"AT: name %d %s\n",SET_ATOM_INST,"SET_ATOM_INST");
1651 FPRINTF(fp,"AT: name %d %s\n",REAL_CONSTANT_INST,"REAL_CONSTANT_INST");
1652 FPRINTF(fp,"AT: name %d %s\n",BOOLEAN_CONSTANT_INST,"BOOLEAN_CONSTANT_INST");
1653 FPRINTF(fp,"AT: name %d %s\n",INTEGER_CONSTANT_INST,"INTEGER_CONSTANT_INST");
1654 FPRINTF(fp,"AT: name %d %s\n",SYMBOL_CONSTANT_INST,"SYMBOL_CONSTANT_INST");
1655 FPRINTF(fp,"AT: name %d %s\n",DUMMY_INST,"DUMMY_INST");
1656 }
1657
1658 void Asc_WriteAnonList(FILE *fp, struct gl_list_t *atl,
1659 struct Instance *root, int mlists)
1660 {
1661 unsigned long c,len;
1662 long sum;
1663 struct AnonType *at,*tat;
1664 struct Instance *i;
1665 CONST struct TypeDescription *d, *base;
1666 int tot;
1667 char *reln, *simple;
1668
1669 if (atl==NULL) {
1670 return;
1671 }
1672 for (c = 1, len = gl_length(atl); c <= len; c++) {
1673 at = (struct AnonType *)gl_fetch(atl,c);
1674 at->visited = 0;
1675 }
1676 for (c = 1, len = gl_length(atl); c <= len; c++) {
1677 at = (struct AnonType *)gl_fetch(atl,c);
1678 if (!at->visited) {
1679 /* find head of formal type group */
1680 while (at->prev != NULL) {
1681 at = at->prev;
1682 }
1683 tat = at;
1684 tot = 0;
1685 sum = 0;
1686 while (tat!=NULL) {
1687 tot++;
1688 sum += (long)gl_length(tat->instances);
1689 tat = tat->next;
1690 }
1691 i = GAP(at);
1692 d = InstanceTypeDesc(i);
1693 simple = reln = "";
1694 base = NULL;
1695 if (InstanceIndirected(i) != LONG_MAX) {
1696 base = GetArrayBaseType(d);
1697 if (GetArrayBaseIsRelation(d) || GetArrayBaseIsLogRel(d)) {
1698 reln="relarray";
1699 }
1700 }
1701 if ((ICOMP & InstanceKind(i)) == 0 ||
1702 (base != NULL &&
1703 GetBaseType(base) != model_type &&
1704 GetBaseType(base) != array_type )) {
1705 simple = "SiMpLe";
1706 }
1707 if (sum==tot) {
1708 sum = -1;
1709 }
1710 #define ABP 1 /* ATOMic bypass in writing anontypes */
1711 #if ABP
1712 if (simple[0]!='S' /* && InstanceKind(i) != MODEL_INST */) {
1713 /* bypass details of ATOmlike things and models. */
1714 #endif
1715 FPRINTF(fp,
1716 "\n\nFT: %d %s (indirected = %lu) (tot=%d, sum=%ld) %s %s %s\n",
1717 InstanceKind(i), SCP(GetName(d)),InstanceIndirected(i),
1718 tot,sum,reln,((base != NULL)?SCP(GetName(base)):""),simple);
1719 while (at!=NULL) {
1720 WriteAnonType(fp,at,root,simple,mlists);
1721 at->visited = 1;
1722 at = at->next;
1723 }
1724 #if ABP
1725 }
1726 #endif
1727 }
1728 }
1729 WriteAnonEpilog(fp);
1730 }

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