?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Initial revision
[official-gcc.git] / gcc / f / bld.c
blob3a95727adc1f69c87b999ab55af5fca6e0290d0f
1 /* bld.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996 Free Software Foundation, Inc.
3 Contributed by James Craig Burley (burley@gnu.ai.mit.edu).
4
5 This file is part of GNU Fortran.
6
7 GNU Fortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
10 any later version.
11
12 GNU Fortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GNU Fortran; see the file COPYING. If not, write to
19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
20 02111-1307, USA.
21
22 Related Modules:
23 None
24
25 Description:
26 The primary "output" of the FFE includes ffebld objects, which
27 connect expressions, operators, and operands together, along with
28 connecting lists of expressions together for argument or dimension
29 lists.
30
31 Modifications:
32 30-Aug-92 JCB 1.1
33 Change names of some things for consistency.
34 */
35
36 /* Include files. */
37
38 #include "proj.h"
39 #include <ctype.h>
40 #include "bld.h"
41 #include "bit.h"
42 #include "info.h"
43 #include "lex.h"
44 #include "malloc.h"
45 #include "target.h"
46 #include "where.h"
47
48 /* Externals defined here. */
49
50 ffebldArity ffebld_arity_op_[]
51 =
52 {
53 #define FFEBLD_OP(KWD,NAME,ARITY) ARITY,
54 #include "bld-op.def"
55 #undef FFEBLD_OP
56 };
57 struct _ffebld_pool_stack_ ffebld_pool_stack_;
58
59 /* Simple definitions and enumerations. */
60
61
62 /* Internal typedefs. */
63
64
65 /* Private include files. */
66
67
68 /* Internal structure definitions. */
69
70
71 /* Static objects accessed by functions in this module. */
72
73 #if FFEBLD_BLANK_
74 static struct _ffebld_ ffebld_blank_
75 =
76 {
77 0,
78 {FFEINFO_basictypeNONE, FFEINFO_kindtypeNONE, 0, FFEINFO_kindNONE,
79 FFEINFO_whereNONE, FFETARGET_charactersizeNONE},
80 {NULL, NULL}
81 };
82 #endif
83 #if FFETARGET_okCHARACTER1
84 static ffebldConstant ffebld_constant_character1_;
85 #endif
86 #if FFETARGET_okCHARACTER2
87 static ffebldConstant ffebld_constant_character2_;
88 #endif
89 #if FFETARGET_okCHARACTER3
90 static ffebldConstant ffebld_constant_character3_;
91 #endif
92 #if FFETARGET_okCHARACTER4
93 static ffebldConstant ffebld_constant_character4_;
94 #endif
95 #if FFETARGET_okCHARACTER5
96 static ffebldConstant ffebld_constant_character5_;
97 #endif
98 #if FFETARGET_okCHARACTER6
99 static ffebldConstant ffebld_constant_character6_;
100 #endif
101 #if FFETARGET_okCHARACTER7
102 static ffebldConstant ffebld_constant_character7_;
103 #endif
104 #if FFETARGET_okCHARACTER8
105 static ffebldConstant ffebld_constant_character8_;
106 #endif
107 #if FFETARGET_okCOMPLEX1
108 static ffebldConstant ffebld_constant_complex1_;
109 #endif
110 #if FFETARGET_okCOMPLEX2
111 static ffebldConstant ffebld_constant_complex2_;
112 #endif
113 #if FFETARGET_okCOMPLEX3
114 static ffebldConstant ffebld_constant_complex3_;
115 #endif
116 #if FFETARGET_okCOMPLEX4
117 static ffebldConstant ffebld_constant_complex4_;
118 #endif
119 #if FFETARGET_okCOMPLEX5
120 static ffebldConstant ffebld_constant_complex5_;
121 #endif
122 #if FFETARGET_okCOMPLEX6
123 static ffebldConstant ffebld_constant_complex6_;
124 #endif
125 #if FFETARGET_okCOMPLEX7
126 static ffebldConstant ffebld_constant_complex7_;
127 #endif
128 #if FFETARGET_okCOMPLEX8
129 static ffebldConstant ffebld_constant_complex8_;
130 #endif
131 #if FFETARGET_okINTEGER1
132 static ffebldConstant ffebld_constant_integer1_;
133 #endif
134 #if FFETARGET_okINTEGER2
135 static ffebldConstant ffebld_constant_integer2_;
136 #endif
137 #if FFETARGET_okINTEGER3
138 static ffebldConstant ffebld_constant_integer3_;
139 #endif
140 #if FFETARGET_okINTEGER4
141 static ffebldConstant ffebld_constant_integer4_;
142 #endif
143 #if FFETARGET_okINTEGER5
144 static ffebldConstant ffebld_constant_integer5_;
145 #endif
146 #if FFETARGET_okINTEGER6
147 static ffebldConstant ffebld_constant_integer6_;
148 #endif
149 #if FFETARGET_okINTEGER7
150 static ffebldConstant ffebld_constant_integer7_;
151 #endif
152 #if FFETARGET_okINTEGER8
153 static ffebldConstant ffebld_constant_integer8_;
154 #endif
155 #if FFETARGET_okLOGICAL1
156 static ffebldConstant ffebld_constant_logical1_;
157 #endif
158 #if FFETARGET_okLOGICAL2
159 static ffebldConstant ffebld_constant_logical2_;
160 #endif
161 #if FFETARGET_okLOGICAL3
162 static ffebldConstant ffebld_constant_logical3_;
163 #endif
164 #if FFETARGET_okLOGICAL4
165 static ffebldConstant ffebld_constant_logical4_;
166 #endif
167 #if FFETARGET_okLOGICAL5
168 static ffebldConstant ffebld_constant_logical5_;
169 #endif
170 #if FFETARGET_okLOGICAL6
171 static ffebldConstant ffebld_constant_logical6_;
172 #endif
173 #if FFETARGET_okLOGICAL7
174 static ffebldConstant ffebld_constant_logical7_;
175 #endif
176 #if FFETARGET_okLOGICAL8
177 static ffebldConstant ffebld_constant_logical8_;
178 #endif
179 #if FFETARGET_okREAL1
180 static ffebldConstant ffebld_constant_real1_;
181 #endif
182 #if FFETARGET_okREAL2
183 static ffebldConstant ffebld_constant_real2_;
184 #endif
185 #if FFETARGET_okREAL3
186 static ffebldConstant ffebld_constant_real3_;
187 #endif
188 #if FFETARGET_okREAL4
189 static ffebldConstant ffebld_constant_real4_;
190 #endif
191 #if FFETARGET_okREAL5
192 static ffebldConstant ffebld_constant_real5_;
193 #endif
194 #if FFETARGET_okREAL6
195 static ffebldConstant ffebld_constant_real6_;
196 #endif
197 #if FFETARGET_okREAL7
198 static ffebldConstant ffebld_constant_real7_;
199 #endif
200 #if FFETARGET_okREAL8
201 static ffebldConstant ffebld_constant_real8_;
202 #endif
203 static ffebldConstant ffebld_constant_hollerith_;
204 static ffebldConstant ffebld_constant_typeless_[FFEBLD_constTYPELESS_LAST
205 - FFEBLD_constTYPELESS_FIRST + 1];
206
207 static char *ffebld_op_string_[]
208 =
209 {
210 #define FFEBLD_OP(KWD,NAME,ARITY) NAME,
211 #include "bld-op.def"
212 #undef FFEBLD_OP
213 };
214
215 /* Static functions (internal). */
216
217
218 /* Internal macros. */
219
220 #define integerdefault_ CATX(integer,FFETARGET_ktINTEGERDEFAULT)
221 #define logicaldefault_ CATX(logical,FFETARGET_ktLOGICALDEFAULT)
222 #define realdefault_ CATX(real,FFETARGET_ktREALDEFAULT)
223 #define realdouble_ CATX(real,FFETARGET_ktREALDOUBLE)
224 #define realquad_ CATX(real,FFETARGET_ktREALQUAD)
225 \f
226 /* ffebld_constant_cmp -- Compare two constants a la strcmp
227
228 ffebldConstant c1, c2;
229 if (ffebld_constant_cmp(c1,c2) == 0)
230 // they're equal, else they're not.
231
232 Returns -1 if c1 < c2, 0 if c1 == c2, +1 if c1 == c2. */
233
234 int
235 ffebld_constant_cmp (ffebldConstant c1, ffebldConstant c2)
236 {
237 if (c1 == c2)
238 return 0;
239
240 assert (ffebld_constant_type (c1) == ffebld_constant_type (c2));
241
242 switch (ffebld_constant_type (c1))
243 {
244 #if FFETARGET_okINTEGER1
245 case FFEBLD_constINTEGER1:
246 return ffetarget_cmp_integer1 (ffebld_constant_integer1 (c1),
247 ffebld_constant_integer1 (c2));
248 #endif
249
250 #if FFETARGET_okINTEGER2
251 case FFEBLD_constINTEGER2:
252 return ffetarget_cmp_integer2 (ffebld_constant_integer2 (c1),
253 ffebld_constant_integer2 (c2));
254 #endif
255
256 #if FFETARGET_okINTEGER3
257 case FFEBLD_constINTEGER3:
258 return ffetarget_cmp_integer3 (ffebld_constant_integer3 (c1),
259 ffebld_constant_integer3 (c2));
260 #endif
261
262 #if FFETARGET_okINTEGER4
263 case FFEBLD_constINTEGER4:
264 return ffetarget_cmp_integer4 (ffebld_constant_integer4 (c1),
265 ffebld_constant_integer4 (c2));
266 #endif
267
268 #if FFETARGET_okINTEGER5
269 case FFEBLD_constINTEGER5:
270 return ffetarget_cmp_integer5 (ffebld_constant_integer5 (c1),
271 ffebld_constant_integer5 (c2));
272 #endif
273
274 #if FFETARGET_okINTEGER6
275 case FFEBLD_constINTEGER6:
276 return ffetarget_cmp_integer6 (ffebld_constant_integer6 (c1),
277 ffebld_constant_integer6 (c2));
278 #endif
279
280 #if FFETARGET_okINTEGER7
281 case FFEBLD_constINTEGER7:
282 return ffetarget_cmp_integer7 (ffebld_constant_integer7 (c1),
283 ffebld_constant_integer7 (c2));
284 #endif
285
286 #if FFETARGET_okINTEGER8
287 case FFEBLD_constINTEGER8:
288 return ffetarget_cmp_integer8 (ffebld_constant_integer8 (c1),
289 ffebld_constant_integer8 (c2));
290 #endif
291
292 #if FFETARGET_okLOGICAL1
293 case FFEBLD_constLOGICAL1:
294 return ffetarget_cmp_logical1 (ffebld_constant_logical1 (c1),
295 ffebld_constant_logical1 (c2));
296 #endif
297
298 #if FFETARGET_okLOGICAL2
299 case FFEBLD_constLOGICAL2:
300 return ffetarget_cmp_logical2 (ffebld_constant_logical2 (c1),
301 ffebld_constant_logical2 (c2));
302 #endif
303
304 #if FFETARGET_okLOGICAL3
305 case FFEBLD_constLOGICAL3:
306 return ffetarget_cmp_logical3 (ffebld_constant_logical3 (c1),
307 ffebld_constant_logical3 (c2));
308 #endif
309
310 #if FFETARGET_okLOGICAL4
311 case FFEBLD_constLOGICAL4:
312 return ffetarget_cmp_logical4 (ffebld_constant_logical4 (c1),
313 ffebld_constant_logical4 (c2));
314 #endif
315
316 #if FFETARGET_okLOGICAL5
317 case FFEBLD_constLOGICAL5:
318 return ffetarget_cmp_logical5 (ffebld_constant_logical5 (c1),
319 ffebld_constant_logical5 (c2));
320 #endif
321
322 #if FFETARGET_okLOGICAL6
323 case FFEBLD_constLOGICAL6:
324 return ffetarget_cmp_logical6 (ffebld_constant_logical6 (c1),
325 ffebld_constant_logical6 (c2));
326 #endif
327
328 #if FFETARGET_okLOGICAL7
329 case FFEBLD_constLOGICAL7:
330 return ffetarget_cmp_logical7 (ffebld_constant_logical7 (c1),
331 ffebld_constant_logical7 (c2));
332 #endif
333
334 #if FFETARGET_okLOGICAL8
335 case FFEBLD_constLOGICAL8:
336 return ffetarget_cmp_logical8 (ffebld_constant_logical8 (c1),
337 ffebld_constant_logical8 (c2));
338 #endif
339
340 #if FFETARGET_okREAL1
341 case FFEBLD_constREAL1:
342 return ffetarget_cmp_real1 (ffebld_constant_real1 (c1),
343 ffebld_constant_real1 (c2));
344 #endif
345
346 #if FFETARGET_okREAL2
347 case FFEBLD_constREAL2:
348 return ffetarget_cmp_real2 (ffebld_constant_real2 (c1),
349 ffebld_constant_real2 (c2));
350 #endif
351
352 #if FFETARGET_okREAL3
353 case FFEBLD_constREAL3:
354 return ffetarget_cmp_real3 (ffebld_constant_real3 (c1),
355 ffebld_constant_real3 (c2));
356 #endif
357
358 #if FFETARGET_okREAL4
359 case FFEBLD_constREAL4:
360 return ffetarget_cmp_real4 (ffebld_constant_real4 (c1),
361 ffebld_constant_real4 (c2));
362 #endif
363
364 #if FFETARGET_okREAL5
365 case FFEBLD_constREAL5:
366 return ffetarget_cmp_real5 (ffebld_constant_real5 (c1),
367 ffebld_constant_real5 (c2));
368 #endif
369
370 #if FFETARGET_okREAL6
371 case FFEBLD_constREAL6:
372 return ffetarget_cmp_real6 (ffebld_constant_real6 (c1),
373 ffebld_constant_real6 (c2));
374 #endif
375
376 #if FFETARGET_okREAL7
377 case FFEBLD_constREAL7:
378 return ffetarget_cmp_real7 (ffebld_constant_real7 (c1),
379 ffebld_constant_real7 (c2));
380 #endif
381
382 #if FFETARGET_okREAL8
383 case FFEBLD_constREAL8:
384 return ffetarget_cmp_real8 (ffebld_constant_real8 (c1),
385 ffebld_constant_real8 (c2));
386 #endif
387
388 #if FFETARGET_okCHARACTER1
389 case FFEBLD_constCHARACTER1:
390 return ffetarget_cmp_character1 (ffebld_constant_character1 (c1),
391 ffebld_constant_character1 (c2));
392 #endif
393
394 #if FFETARGET_okCHARACTER2
395 case FFEBLD_constCHARACTER2:
396 return ffetarget_cmp_character2 (ffebld_constant_character2 (c1),
397 ffebld_constant_character2 (c2));
398 #endif
399
400 #if FFETARGET_okCHARACTER3
401 case FFEBLD_constCHARACTER3:
402 return ffetarget_cmp_character3 (ffebld_constant_character3 (c1),
403 ffebld_constant_character3 (c2));
404 #endif
405
406 #if FFETARGET_okCHARACTER4
407 case FFEBLD_constCHARACTER4:
408 return ffetarget_cmp_character4 (ffebld_constant_character4 (c1),
409 ffebld_constant_character4 (c2));
410 #endif
411
412 #if FFETARGET_okCHARACTER5
413 case FFEBLD_constCHARACTER5:
414 return ffetarget_cmp_character5 (ffebld_constant_character5 (c1),
415 ffebld_constant_character5 (c2));
416 #endif
417
418 #if FFETARGET_okCHARACTER6
419 case FFEBLD_constCHARACTER6:
420 return ffetarget_cmp_character6 (ffebld_constant_character6 (c1),
421 ffebld_constant_character6 (c2));
422 #endif
423
424 #if FFETARGET_okCHARACTER7
425 case FFEBLD_constCHARACTER7:
426 return ffetarget_cmp_character7 (ffebld_constant_character7 (c1),
427 ffebld_constant_character7 (c2));
428 #endif
429
430 #if FFETARGET_okCHARACTER8
431 case FFEBLD_constCHARACTER8:
432 return ffetarget_cmp_character8 (ffebld_constant_character8 (c1),
433 ffebld_constant_character8 (c2));
434 #endif
435
436 default:
437 assert ("bad constant type" == NULL);
438 return 0;
439 }
440 }
441
442 /* ffebld_constant_dump -- Display summary of constant's contents
443
444 ffebldConstant c;
445 ffebld_constant_dump(c);
446
447 Displays the constant in summary form. */
448
449 void
450 ffebld_constant_dump (ffebldConstant c)
451 {
452 switch (ffebld_constant_type (c))
453 {
454 #if FFETARGET_okINTEGER1
455 case FFEBLD_constINTEGER1:
456 ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
457 FFEINFO_kindtypeINTEGER1);
458 ffebld_constantunion_dump (ffebld_constant_union (c),
459 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1);
460 break;
461 #endif
462
463 #if FFETARGET_okINTEGER2
464 case FFEBLD_constINTEGER2:
465 ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
466 FFEINFO_kindtypeINTEGER2);
467 ffebld_constantunion_dump (ffebld_constant_union (c),
468 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2);
469 break;
470 #endif
471
472 #if FFETARGET_okINTEGER3
473 case FFEBLD_constINTEGER3:
474 ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
475 FFEINFO_kindtypeINTEGER3);
476 ffebld_constantunion_dump (ffebld_constant_union (c),
477 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3);
478 break;
479 #endif
480
481 #if FFETARGET_okINTEGER4
482 case FFEBLD_constINTEGER4:
483 ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
484 FFEINFO_kindtypeINTEGER4);
485 ffebld_constantunion_dump (ffebld_constant_union (c),
486 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4);
487 break;
488 #endif
489
490 #if FFETARGET_okINTEGER5
491 case FFEBLD_constINTEGER5:
492 ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
493 FFEINFO_kindtypeINTEGER5);
494 ffebld_constantunion_dump (ffebld_constant_union (c),
495 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER5);
496 break;
497 #endif
498
499 #if FFETARGET_okINTEGER6
500 case FFEBLD_constINTEGER6:
501 ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
502 FFEINFO_kindtypeINTEGER6);
503 ffebld_constantunion_dump (ffebld_constant_union (c),
504 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER6);
505 break;
506 #endif
507
508 #if FFETARGET_okINTEGER7
509 case FFEBLD_constINTEGER7:
510 ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
511 FFEINFO_kindtypeINTEGER7);
512 ffebld_constantunion_dump (ffebld_constant_union (c),
513 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER7);
514 break;
515 #endif
516
517 #if FFETARGET_okINTEGER8
518 case FFEBLD_constINTEGER8:
519 ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
520 FFEINFO_kindtypeINTEGER8);
521 ffebld_constantunion_dump (ffebld_constant_union (c),
522 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER8);
523 break;
524 #endif
525
526 #if FFETARGET_okLOGICAL1
527 case FFEBLD_constLOGICAL1:
528 ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
529 FFEINFO_kindtypeLOGICAL1);
530 ffebld_constantunion_dump (ffebld_constant_union (c),
531 FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1);
532 break;
533 #endif
534
535 #if FFETARGET_okLOGICAL2
536 case FFEBLD_constLOGICAL2:
537 ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
538 FFEINFO_kindtypeLOGICAL2);
539 ffebld_constantunion_dump (ffebld_constant_union (c),
540 FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2);
541 break;
542 #endif
543
544 #if FFETARGET_okLOGICAL3
545 case FFEBLD_constLOGICAL3:
546 ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
547 FFEINFO_kindtypeLOGICAL3);
548 ffebld_constantunion_dump (ffebld_constant_union (c),
549 FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3);
550 break;
551 #endif
552
553 #if FFETARGET_okLOGICAL4
554 case FFEBLD_constLOGICAL4:
555 ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
556 FFEINFO_kindtypeLOGICAL4);
557 ffebld_constantunion_dump (ffebld_constant_union (c),
558 FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4);
559 break;
560 #endif
561
562 #if FFETARGET_okLOGICAL5
563 case FFEBLD_constLOGICAL5:
564 ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
565 FFEINFO_kindtypeLOGICAL5);
566 ffebld_constantunion_dump (ffebld_constant_union (c),
567 FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL5);
568 break;
569 #endif
570
571 #if FFETARGET_okLOGICAL6
572 case FFEBLD_constLOGICAL6:
573 ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
574 FFEINFO_kindtypeLOGICAL6);
575 ffebld_constantunion_dump (ffebld_constant_union (c),
576 FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL6);
577 break;
578 #endif
579
580 #if FFETARGET_okLOGICAL7
581 case FFEBLD_constLOGICAL7:
582 ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
583 FFEINFO_kindtypeLOGICAL7);
584 ffebld_constantunion_dump (ffebld_constant_union (c),
585 FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL7);
586 break;
587 #endif
588
589 #if FFETARGET_okLOGICAL8
590 case FFEBLD_constLOGICAL8:
591 ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
592 FFEINFO_kindtypeLOGICAL8);
593 ffebld_constantunion_dump (ffebld_constant_union (c),
594 FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL8);
595 break;
596 #endif
597
598 #if FFETARGET_okREAL1
599 case FFEBLD_constREAL1:
600 ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
601 FFEINFO_kindtypeREAL1);
602 ffebld_constantunion_dump (ffebld_constant_union (c),
603 FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1);
604 break;
605 #endif
606
607 #if FFETARGET_okREAL2
608 case FFEBLD_constREAL2:
609 ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
610 FFEINFO_kindtypeREAL2);
611 ffebld_constantunion_dump (ffebld_constant_union (c),
612 FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL2);
613 break;
614 #endif
615
616 #if FFETARGET_okREAL3
617 case FFEBLD_constREAL3:
618 ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
619 FFEINFO_kindtypeREAL3);
620 ffebld_constantunion_dump (ffebld_constant_union (c),
621 FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL3);
622 break;
623 #endif
624
625 #if FFETARGET_okREAL4
626 case FFEBLD_constREAL4:
627 ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
628 FFEINFO_kindtypeREAL4);
629 ffebld_constantunion_dump (ffebld_constant_union (c),
630 FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL4);
631 break;
632 #endif
633
634 #if FFETARGET_okREAL5
635 case FFEBLD_constREAL5:
636 ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
637 FFEINFO_kindtypeREAL5);
638 ffebld_constantunion_dump (ffebld_constant_union (c),
639 FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL5);
640 break;
641 #endif
642
643 #if FFETARGET_okREAL6
644 case FFEBLD_constREAL6:
645 ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
646 FFEINFO_kindtypeREAL6);
647 ffebld_constantunion_dump (ffebld_constant_union (c),
648 FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL6);
649 break;
650 #endif
651
652 #if FFETARGET_okREAL7
653 case FFEBLD_constREAL7:
654 ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
655 FFEINFO_kindtypeREAL7);
656 ffebld_constantunion_dump (ffebld_constant_union (c),
657 FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL7);
658 break;
659 #endif
660
661 #if FFETARGET_okREAL8
662 case FFEBLD_constREAL8:
663 ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
664 FFEINFO_kindtypeREAL8);
665 ffebld_constantunion_dump (ffebld_constant_union (c),
666 FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL8);
667 break;
668 #endif
669
670 #if FFETARGET_okCOMPLEX1
671 case FFEBLD_constCOMPLEX1:
672 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
673 FFEINFO_kindtypeREAL1);
674 ffebld_constantunion_dump (ffebld_constant_union (c),
675 FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1);
676 break;
677 #endif
678
679 #if FFETARGET_okCOMPLEX2
680 case FFEBLD_constCOMPLEX2:
681 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
682 FFEINFO_kindtypeREAL2);
683 ffebld_constantunion_dump (ffebld_constant_union (c),
684 FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL2);
685 break;
686 #endif
687
688 #if FFETARGET_okCOMPLEX3
689 case FFEBLD_constCOMPLEX3:
690 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
691 FFEINFO_kindtypeREAL3);
692 ffebld_constantunion_dump (ffebld_constant_union (c),
693 FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL3);
694 break;
695 #endif
696
697 #if FFETARGET_okCOMPLEX4
698 case FFEBLD_constCOMPLEX4:
699 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
700 FFEINFO_kindtypeREAL4);
701 ffebld_constantunion_dump (ffebld_constant_union (c),
702 FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL4);
703 break;
704 #endif
705
706 #if FFETARGET_okCOMPLEX5
707 case FFEBLD_constCOMPLEX5:
708 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
709 FFEINFO_kindtypeREAL5);
710 ffebld_constantunion_dump (ffebld_constant_union (c),
711 FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL5);
712 break;
713 #endif
714
715 #if FFETARGET_okCOMPLEX6
716 case FFEBLD_constCOMPLEX6:
717 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
718 FFEINFO_kindtypeREAL6);
719 ffebld_constantunion_dump (ffebld_constant_union (c),
720 FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL6);
721 break;
722 #endif
723
724 #if FFETARGET_okCOMPLEX7
725 case FFEBLD_constCOMPLEX7:
726 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
727 FFEINFO_kindtypeREAL7);
728 ffebld_constantunion_dump (ffebld_constant_union (c),
729 FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL7);
730 break;
731 #endif
732
733 #if FFETARGET_okCOMPLEX8
734 case FFEBLD_constCOMPLEX8:
735 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
736 FFEINFO_kindtypeREAL8);
737 ffebld_constantunion_dump (ffebld_constant_union (c),
738 FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL8);
739 break;
740 #endif
741
742 #if FFETARGET_okCHARACTER1
743 case FFEBLD_constCHARACTER1:
744 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
745 FFEINFO_kindtypeCHARACTER1);
746 ffebld_constantunion_dump (ffebld_constant_union (c),
747 FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER1);
748 break;
749 #endif
750
751 #if FFETARGET_okCHARACTER2
752 case FFEBLD_constCHARACTER2:
753 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
754 FFEINFO_kindtypeCHARACTER2);
755 ffebld_constantunion_dump (ffebld_constant_union (c),
756 FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER2);
757 break;
758 #endif
759
760 #if FFETARGET_okCHARACTER3
761 case FFEBLD_constCHARACTER3:
762 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
763 FFEINFO_kindtypeCHARACTER3);
764 ffebld_constantunion_dump (ffebld_constant_union (c),
765 FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER3);
766 break;
767 #endif
768
769 #if FFETARGET_okCHARACTER4
770 case FFEBLD_constCHARACTER4:
771 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
772 FFEINFO_kindtypeCHARACTER4);
773 ffebld_constantunion_dump (ffebld_constant_union (c),
774 FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER4);
775 break;
776 #endif
777
778 #if FFETARGET_okCHARACTER5
779 case FFEBLD_constCHARACTER5:
780 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
781 FFEINFO_kindtypeCHARACTER5);
782 ffebld_constantunion_dump (ffebld_constant_union (c),
783 FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER5);
784 break;
785 #endif
786
787 #if FFETARGET_okCHARACTER6
788 case FFEBLD_constCHARACTER6:
789 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
790 FFEINFO_kindtypeCHARACTER6);
791 ffebld_constantunion_dump (ffebld_constant_union (c),
792 FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER6);
793 break;
794 #endif
795
796 #if FFETARGET_okCHARACTER7
797 case FFEBLD_constCHARACTER7:
798 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
799 FFEINFO_kindtypeCHARACTER7);
800 ffebld_constantunion_dump (ffebld_constant_union (c),
801 FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER7);
802 break;
803 #endif
804
805 #if FFETARGET_okCHARACTER8
806 case FFEBLD_constCHARACTER8:
807 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
808 FFEINFO_kindtypeCHARACTER8);
809 ffebld_constantunion_dump (ffebld_constant_union (c),
810 FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER8);
811 break;
812 #endif
813
814 case FFEBLD_constHOLLERITH:
815 fprintf (dmpout, "H%" ffetargetHollerithSize_f "u/",
816 ffebld_constant_hollerith (c).length);
817 ffetarget_print_hollerith (dmpout, ffebld_constant_hollerith (c));
818 break;
819
820 case FFEBLD_constBINARY_MIL:
821 fprintf (dmpout, "BM/");
822 ffetarget_print_binarymil (dmpout, ffebld_constant_typeless (c));
823 break;
824
825 case FFEBLD_constBINARY_VXT:
826 fprintf (dmpout, "BV/");
827 ffetarget_print_binaryvxt (dmpout, ffebld_constant_typeless (c));
828 break;
829
830 case FFEBLD_constOCTAL_MIL:
831 fprintf (dmpout, "OM/");
832 ffetarget_print_octalmil (dmpout, ffebld_constant_typeless (c));
833 break;
834
835 case FFEBLD_constOCTAL_VXT:
836 fprintf (dmpout, "OV/");
837 ffetarget_print_octalvxt (dmpout, ffebld_constant_typeless (c));
838 break;
839
840 case FFEBLD_constHEX_X_MIL:
841 fprintf (dmpout, "XM/");
842 ffetarget_print_hexxmil (dmpout, ffebld_constant_typeless (c));
843 break;
844
845 case FFEBLD_constHEX_X_VXT:
846 fprintf (dmpout, "XV/");
847 ffetarget_print_hexxvxt (dmpout, ffebld_constant_typeless (c));
848 break;
849
850 case FFEBLD_constHEX_Z_MIL:
851 fprintf (dmpout, "ZM/");
852 ffetarget_print_hexzmil (dmpout, ffebld_constant_typeless (c));
853 break;
854
855 case FFEBLD_constHEX_Z_VXT:
856 fprintf (dmpout, "ZV/");
857 ffetarget_print_hexzvxt (dmpout, ffebld_constant_typeless (c));
858 break;
859
860 default:
861 assert ("bad constant type" == NULL);
862 fprintf (dmpout, "?/?");
863 break;
864 }
865 }
866
867 /* ffebld_constant_is_magical -- Determine if integer is "magical"
868
869 ffebldConstant c;
870 if (ffebld_constant_is_magical(c))
871 // it is 2**(n-1), where n is # bits in ffetargetIntegerDefault type
872 // (this test is important for 2's-complement machines only). */
873
874 bool
875 ffebld_constant_is_magical (ffebldConstant c)
876 {
877 switch (ffebld_constant_type (c))
878 {
879 case FFEBLD_constINTEGERDEFAULT:
880 return ffetarget_integerdefault_is_magical (ffebld_constant_integer1 (c));
881
882 default:
883 return FALSE;
884 }
885 }
886
887 /* Determine if constant is zero. Used to ensure step count
888 for DO loops isn't zero, also to determine if values will
889 be binary zeros, so not entirely portable at this point. */
890
891 bool
892 ffebld_constant_is_zero (ffebldConstant c)
893 {
894 switch (ffebld_constant_type (c))
895 {
896 #if FFETARGET_okINTEGER1
897 case FFEBLD_constINTEGER1:
898 return ffebld_constant_integer1 (c) == 0;
899 #endif
900
901 #if FFETARGET_okINTEGER2
902 case FFEBLD_constINTEGER2:
903 return ffebld_constant_integer2 (c) == 0;
904 #endif
905
906 #if FFETARGET_okINTEGER3
907 case FFEBLD_constINTEGER3:
908 return ffebld_constant_integer3 (c) == 0;
909 #endif
910
911 #if FFETARGET_okINTEGER4
912 case FFEBLD_constINTEGER4:
913 return ffebld_constant_integer4 (c) == 0;
914 #endif
915
916 #if FFETARGET_okINTEGER5
917 case FFEBLD_constINTEGER5:
918 return ffebld_constant_integer5 (c) == 0;
919 #endif
920
921 #if FFETARGET_okINTEGER6
922 case FFEBLD_constINTEGER6:
923 return ffebld_constant_integer6 (c) == 0;
924 #endif
925
926 #if FFETARGET_okINTEGER7
927 case FFEBLD_constINTEGER7:
928 return ffebld_constant_integer7 (c) == 0;
929 #endif
930
931 #if FFETARGET_okINTEGER8
932 case FFEBLD_constINTEGER8:
933 return ffebld_constant_integer8 (c) == 0;
934 #endif
935
936 #if FFETARGET_okLOGICAL1
937 case FFEBLD_constLOGICAL1:
938 return ffebld_constant_logical1 (c) == 0;
939 #endif
940
941 #if FFETARGET_okLOGICAL2
942 case FFEBLD_constLOGICAL2:
943 return ffebld_constant_logical2 (c) == 0;
944 #endif
945
946 #if FFETARGET_okLOGICAL3
947 case FFEBLD_constLOGICAL3:
948 return ffebld_constant_logical3 (c) == 0;
949 #endif
950
951 #if FFETARGET_okLOGICAL4
952 case FFEBLD_constLOGICAL4:
953 return ffebld_constant_logical4 (c) == 0;
954 #endif
955
956 #if FFETARGET_okLOGICAL5
957 case FFEBLD_constLOGICAL5:
958 return ffebld_constant_logical5 (c) == 0;
959 #endif
960
961 #if FFETARGET_okLOGICAL6
962 case FFEBLD_constLOGICAL6:
963 return ffebld_constant_logical6 (c) == 0;
964 #endif
965
966 #if FFETARGET_okLOGICAL7
967 case FFEBLD_constLOGICAL7:
968 return ffebld_constant_logical7 (c) == 0;
969 #endif
970
971 #if FFETARGET_okLOGICAL8
972 case FFEBLD_constLOGICAL8:
973 return ffebld_constant_logical8 (c) == 0;
974 #endif
975
976 #if FFETARGET_okREAL1
977 case FFEBLD_constREAL1:
978 return ffetarget_iszero_real1 (ffebld_constant_real1 (c));
979 #endif
980
981 #if FFETARGET_okREAL2
982 case FFEBLD_constREAL2:
983 return ffetarget_iszero_real2 (ffebld_constant_real2 (c));
984 #endif
985
986 #if FFETARGET_okREAL3
987 case FFEBLD_constREAL3:
988 return ffetarget_iszero_real3 (ffebld_constant_real3 (c));
989 #endif
990
991 #if FFETARGET_okREAL4
992 case FFEBLD_constREAL4:
993 return ffetarget_iszero_real4 (ffebld_constant_real4 (c));
994 #endif
995
996 #if FFETARGET_okREAL5
997 case FFEBLD_constREAL5:
998 return ffetarget_iszero_real5 (ffebld_constant_real5 (c));
999 #endif
1000
1001 #if FFETARGET_okREAL6
1002 case FFEBLD_constREAL6:
1003 return ffetarget_iszero_real6 (ffebld_constant_real6 (c));
1004 #endif
1005
1006 #if FFETARGET_okREAL7
1007 case FFEBLD_constREAL7:
1008 return ffetarget_iszero_real7 (ffebld_constant_real7 (c));
1009 #endif
1010
1011 #if FFETARGET_okREAL8
1012 case FFEBLD_constREAL8:
1013 return ffetarget_iszero_real8 (ffebld_constant_real8 (c));
1014 #endif
1015
1016 #if FFETARGET_okCOMPLEX1
1017 case FFEBLD_constCOMPLEX1:
1018 return ffetarget_iszero_real1 (ffebld_constant_complex1 (c).real)
1019 && ffetarget_iszero_real1 (ffebld_constant_complex1 (c).imaginary);
1020 #endif
1021
1022 #if FFETARGET_okCOMPLEX2
1023 case FFEBLD_constCOMPLEX2:
1024 return ffetarget_iszero_real2 (ffebld_constant_complex2 (c).real)
1025 && ffetarget_iszero_real2 (ffebld_constant_complex2 (c).imaginary);
1026 #endif
1027
1028 #if FFETARGET_okCOMPLEX3
1029 case FFEBLD_constCOMPLEX3:
1030 return ffetarget_iszero_real3 (ffebld_constant_complex3 (c).real)
1031 && ffetarget_iszero_real3 (ffebld_constant_complex3 (c).imaginary);
1032 #endif
1033
1034 #if FFETARGET_okCOMPLEX4
1035 case FFEBLD_constCOMPLEX4:
1036 return ffetarget_iszero_real4 (ffebld_constant_complex4 (c).real)
1037 && ffetarget_iszero_real4 (ffebld_constant_complex4 (c).imaginary);
1038 #endif
1039
1040 #if FFETARGET_okCOMPLEX5
1041 case FFEBLD_constCOMPLEX5:
1042 return ffetarget_iszero_real5 (ffebld_constant_complex5 (c).real)
1043 && ffetarget_iszero_real5 (ffebld_constant_complex5 (c).imaginary);
1044 #endif
1045
1046 #if FFETARGET_okCOMPLEX6
1047 case FFEBLD_constCOMPLEX6:
1048 return ffetarget_iszero_real6 (ffebld_constant_complex6 (c).real)
1049 && ffetarget_iszero_real6 (ffebld_constant_complex6 (c).imaginary);
1050 #endif
1051
1052 #if FFETARGET_okCOMPLEX7
1053 case FFEBLD_constCOMPLEX7:
1054 return ffetarget_iszero_real7 (ffebld_constant_complex7 (c).real)
1055 && ffetarget_iszero_real7 (ffebld_constant_complex7 (c).imaginary);
1056 #endif
1057
1058 #if FFETARGET_okCOMPLEX8
1059 case FFEBLD_constCOMPLEX8:
1060 return ffetarget_iszero_real8 (ffebld_constant_complex8 (c).real)
1061 && ffetarget_iszero_real8 (ffebld_constant_complex8 (c).imaginary);
1062 #endif
1063
1064 #if FFETARGET_okCHARACTER1
1065 case FFEBLD_constCHARACTER1:
1066 return ffetarget_iszero_character1 (ffebld_constant_character1 (c));
1067 #endif
1068
1069 #if FFETARGET_okCHARACTER2 || FFETARGET_okCHARACTER3 /* ... */
1070 #error "no support for these!!"
1071 #endif
1072
1073 case FFEBLD_constHOLLERITH:
1074 return ffetarget_iszero_hollerith (ffebld_constant_hollerith (c));
1075
1076 case FFEBLD_constBINARY_MIL:
1077 case FFEBLD_constBINARY_VXT:
1078 case FFEBLD_constOCTAL_MIL:
1079 case FFEBLD_constOCTAL_VXT:
1080 case FFEBLD_constHEX_X_MIL:
1081 case FFEBLD_constHEX_X_VXT:
1082 case FFEBLD_constHEX_Z_MIL:
1083 case FFEBLD_constHEX_Z_VXT:
1084 return ffetarget_iszero_typeless (ffebld_constant_typeless (c));
1085
1086 default:
1087 return FALSE;
1088 }
1089 }
1090
1091 /* ffebld_constant_new_character1 -- Return character1 constant object from token
1092
1093 See prototype. */
1094
1095 #if FFETARGET_okCHARACTER1
1096 ffebldConstant
1097 ffebld_constant_new_character1 (ffelexToken t)
1098 {
1099 ffetargetCharacter1 val;
1100
1101 ffetarget_character1 (&val, t, ffebld_constant_pool());
1102 return ffebld_constant_new_character1_val (val);
1103 }
1104
1105 #endif
1106 /* ffebld_constant_new_character1_val -- Return an character1 constant object
1107
1108 See prototype. */
1109
1110 #if FFETARGET_okCHARACTER1
1111 ffebldConstant
1112 ffebld_constant_new_character1_val (ffetargetCharacter1 val)
1113 {
1114 ffebldConstant c;
1115 ffebldConstant nc;
1116 int cmp;
1117
1118 ffetarget_verify_character1 (ffebld_constant_pool(), val);
1119
1120 for (c = (ffebldConstant) &ffebld_constant_character1_;
1121 c->next != NULL;
1122 c = c->next)
1123 {
1124 malloc_verify_kp (ffebld_constant_pool(),
1125 c->next,
1126 sizeof (*(c->next)));
1127 ffetarget_verify_character1 (ffebld_constant_pool(),
1128 ffebld_constant_character1 (c->next));
1129 cmp = ffetarget_cmp_character1 (val,
1130 ffebld_constant_character1 (c->next));
1131 if (cmp == 0)
1132 return c->next;
1133 if (cmp > 0)
1134 break;
1135 }
1136
1137 nc = malloc_new_kp (ffebld_constant_pool(),
1138 "FFEBLD_constCHARACTER1",
1139 sizeof (*nc));
1140 nc->next = c->next;
1141 nc->consttype = FFEBLD_constCHARACTER1;
1142 nc->u.character1 = val;
1143 #ifdef FFECOM_constantHOOK
1144 nc->hook = FFECOM_constantNULL;
1145 #endif
1146 c->next = nc;
1147
1148 return nc;
1149 }
1150
1151 #endif
1152 /* ffebld_constant_new_complex1 -- Return complex1 constant object from token
1153
1154 See prototype. */
1155
1156 #if FFETARGET_okCOMPLEX1
1157 ffebldConstant
1158 ffebld_constant_new_complex1 (ffebldConstant real,
1159 ffebldConstant imaginary)
1160 {
1161 ffetargetComplex1 val;
1162
1163 val.real = ffebld_constant_real1 (real);
1164 val.imaginary = ffebld_constant_real1 (imaginary);
1165 return ffebld_constant_new_complex1_val (val);
1166 }
1167
1168 #endif
1169 /* ffebld_constant_new_complex1_val -- Return a complex1 constant object
1170
1171 See prototype. */
1172
1173 #if FFETARGET_okCOMPLEX1
1174 ffebldConstant
1175 ffebld_constant_new_complex1_val (ffetargetComplex1 val)
1176 {
1177 ffebldConstant c;
1178 ffebldConstant nc;
1179 int cmp;
1180
1181 for (c = (ffebldConstant) &ffebld_constant_complex1_;
1182 c->next != NULL;
1183 c = c->next)
1184 {
1185 cmp = ffetarget_cmp_real1 (val.real, ffebld_constant_complex1 (c->next).real);
1186 if (cmp == 0)
1187 cmp = ffetarget_cmp_real1 (val.imaginary,
1188 ffebld_constant_complex1 (c->next).imaginary);
1189 if (cmp == 0)
1190 return c->next;
1191 if (cmp > 0)
1192 break;
1193 }
1194
1195 nc = malloc_new_kp (ffebld_constant_pool(),
1196 "FFEBLD_constCOMPLEX1",
1197 sizeof (*nc));
1198 nc->next = c->next;
1199 nc->consttype = FFEBLD_constCOMPLEX1;
1200 nc->u.complex1 = val;
1201 #ifdef FFECOM_constantHOOK
1202 nc->hook = FFECOM_constantNULL;
1203 #endif
1204 c->next = nc;
1205
1206 return nc;
1207 }
1208
1209 #endif
1210 /* ffebld_constant_new_complex2 -- Return complex2 constant object from token
1211
1212 See prototype. */
1213
1214 #if FFETARGET_okCOMPLEX2
1215 ffebldConstant
1216 ffebld_constant_new_complex2 (ffebldConstant real,
1217 ffebldConstant imaginary)
1218 {
1219 ffetargetComplex2 val;
1220
1221 val.real = ffebld_constant_real2 (real);
1222 val.imaginary = ffebld_constant_real2 (imaginary);
1223 return ffebld_constant_new_complex2_val (val);
1224 }
1225
1226 #endif
1227 /* ffebld_constant_new_complex2_val -- Return a complex2 constant object
1228
1229 See prototype. */
1230
1231 #if FFETARGET_okCOMPLEX2
1232 ffebldConstant
1233 ffebld_constant_new_complex2_val (ffetargetComplex2 val)
1234 {
1235 ffebldConstant c;
1236 ffebldConstant nc;
1237 int cmp;
1238
1239 for (c = (ffebldConstant) &ffebld_constant_complex2_;
1240 c->next != NULL;
1241 c = c->next)
1242 {
1243 cmp = ffetarget_cmp_real2 (val.real, ffebld_constant_complex2 (c->next).real);
1244 if (cmp == 0)
1245 cmp = ffetarget_cmp_real2 (val.imaginary,
1246 ffebld_constant_complex2 (c->next).imaginary);
1247 if (cmp == 0)
1248 return c->next;
1249 if (cmp > 0)
1250 break;
1251 }
1252
1253 nc = malloc_new_kp (ffebld_constant_pool(),
1254 "FFEBLD_constCOMPLEX2",
1255 sizeof (*nc));
1256 nc->next = c->next;
1257 nc->consttype = FFEBLD_constCOMPLEX2;
1258 nc->u.complex2 = val;
1259 #ifdef FFECOM_constantHOOK
1260 nc->hook = FFECOM_constantNULL;
1261 #endif
1262 c->next = nc;
1263
1264 return nc;
1265 }
1266
1267 #endif
1268 /* ffebld_constant_new_hollerith -- Return hollerith constant object from token
1269
1270 See prototype. */
1271
1272 ffebldConstant
1273 ffebld_constant_new_hollerith (ffelexToken t)
1274 {
1275 ffetargetHollerith val;
1276
1277 ffetarget_hollerith (&val, t, ffebld_constant_pool());
1278 return ffebld_constant_new_hollerith_val (val);
1279 }
1280
1281 /* ffebld_constant_new_hollerith_val -- Return an hollerith constant object
1282
1283 See prototype. */
1284
1285 ffebldConstant
1286 ffebld_constant_new_hollerith_val (ffetargetHollerith val)
1287 {
1288 ffebldConstant c;
1289 ffebldConstant nc;
1290 int cmp;
1291
1292 for (c = (ffebldConstant) &ffebld_constant_hollerith_;
1293 c->next != NULL;
1294 c = c->next)
1295 {
1296 cmp = ffetarget_cmp_hollerith (val, ffebld_constant_hollerith (c->next));
1297 if (cmp == 0)
1298 return c->next;
1299 if (cmp > 0)
1300 break;
1301 }
1302
1303 nc = malloc_new_kp (ffebld_constant_pool(),
1304 "FFEBLD_constHOLLERITH",
1305 sizeof (*nc));
1306 nc->next = c->next;
1307 nc->consttype = FFEBLD_constHOLLERITH;
1308 nc->u.hollerith = val;
1309 #ifdef FFECOM_constantHOOK
1310 nc->hook = FFECOM_constantNULL;
1311 #endif
1312 c->next = nc;
1313
1314 return nc;
1315 }
1316
1317 /* ffebld_constant_new_integer1 -- Return integer1 constant object from token
1318
1319 See prototype.
1320
1321 Parses the token as a decimal integer constant, thus it must be an
1322 FFELEX_typeNUMBER. */
1323
1324 #if FFETARGET_okINTEGER1
1325 ffebldConstant
1326 ffebld_constant_new_integer1 (ffelexToken t)
1327 {
1328 ffetargetInteger1 val;
1329
1330 assert (ffelex_token_type (t) == FFELEX_typeNUMBER);
1331
1332 ffetarget_integer1 (&val, t);
1333 return ffebld_constant_new_integer1_val (val);
1334 }
1335
1336 #endif
1337 /* ffebld_constant_new_integer1_val -- Return an integer1 constant object
1338
1339 See prototype. */
1340
1341 #if FFETARGET_okINTEGER1
1342 ffebldConstant
1343 ffebld_constant_new_integer1_val (ffetargetInteger1 val)
1344 {
1345 ffebldConstant c;
1346 ffebldConstant nc;
1347 int cmp;
1348
1349 for (c = (ffebldConstant) &ffebld_constant_integer1_;
1350 c->next != NULL;
1351 c = c->next)
1352 {
1353 cmp = ffetarget_cmp_integer1 (val, ffebld_constant_integer1 (c->next));
1354 if (cmp == 0)
1355 return c->next;
1356 if (cmp > 0)
1357 break;
1358 }
1359
1360 nc = malloc_new_kp (ffebld_constant_pool(),
1361 "FFEBLD_constINTEGER1",
1362 sizeof (*nc));
1363 nc->next = c->next;
1364 nc->consttype = FFEBLD_constINTEGER1;
1365 nc->u.integer1 = val;
1366 #ifdef FFECOM_constantHOOK
1367 nc->hook = FFECOM_constantNULL;
1368 #endif
1369 c->next = nc;
1370
1371 return nc;
1372 }
1373
1374 #endif
1375 /* ffebld_constant_new_integer2_val -- Return an integer2 constant object
1376
1377 See prototype. */
1378
1379 #if FFETARGET_okINTEGER2
1380 ffebldConstant
1381 ffebld_constant_new_integer2_val (ffetargetInteger2 val)
1382 {
1383 ffebldConstant c;
1384 ffebldConstant nc;
1385 int cmp;
1386
1387 for (c = (ffebldConstant) &ffebld_constant_integer2_;
1388 c->next != NULL;
1389 c = c->next)
1390 {
1391 cmp = ffetarget_cmp_integer2 (val, ffebld_constant_integer2 (c->next));
1392 if (cmp == 0)
1393 return c->next;
1394 if (cmp > 0)
1395 break;
1396 }
1397
1398 nc = malloc_new_kp (ffebld_constant_pool(),
1399 "FFEBLD_constINTEGER2",
1400 sizeof (*nc));
1401 nc->next = c->next;
1402 nc->consttype = FFEBLD_constINTEGER2;
1403 nc->u.integer2 = val;
1404 #ifdef FFECOM_constantHOOK
1405 nc->hook = FFECOM_constantNULL;
1406 #endif
1407 c->next = nc;
1408
1409 return nc;
1410 }
1411
1412 #endif
1413 /* ffebld_constant_new_integer3_val -- Return an integer3 constant object
1414
1415 See prototype. */
1416
1417 #if FFETARGET_okINTEGER3
1418 ffebldConstant
1419 ffebld_constant_new_integer3_val (ffetargetInteger3 val)
1420 {
1421 ffebldConstant c;
1422 ffebldConstant nc;
1423 int cmp;
1424
1425 for (c = (ffebldConstant) &ffebld_constant_integer3_;
1426 c->next != NULL;
1427 c = c->next)
1428 {
1429 cmp = ffetarget_cmp_integer3 (val, ffebld_constant_integer3 (c->next));
1430 if (cmp == 0)
1431 return c->next;
1432 if (cmp > 0)
1433 break;
1434 }
1435
1436 nc = malloc_new_kp (ffebld_constant_pool(),
1437 "FFEBLD_constINTEGER3",
1438 sizeof (*nc));
1439 nc->next = c->next;
1440 nc->consttype = FFEBLD_constINTEGER3;
1441 nc->u.integer3 = val;
1442 #ifdef FFECOM_constantHOOK
1443 nc->hook = FFECOM_constantNULL;
1444 #endif
1445 c->next = nc;
1446
1447 return nc;
1448 }
1449
1450 #endif
1451 /* ffebld_constant_new_integer4_val -- Return an integer4 constant object
1452
1453 See prototype. */
1454
1455 #if FFETARGET_okINTEGER4
1456 ffebldConstant
1457 ffebld_constant_new_integer4_val (ffetargetInteger4 val)
1458 {
1459 ffebldConstant c;
1460 ffebldConstant nc;
1461 int cmp;
1462
1463 for (c = (ffebldConstant) &ffebld_constant_integer4_;
1464 c->next != NULL;
1465 c = c->next)
1466 {
1467 cmp = ffetarget_cmp_integer4 (val, ffebld_constant_integer4 (c->next));
1468 if (cmp == 0)
1469 return c->next;
1470 if (cmp > 0)
1471 break;
1472 }
1473
1474 nc = malloc_new_kp (ffebld_constant_pool(),
1475 "FFEBLD_constINTEGER4",
1476 sizeof (*nc));
1477 nc->next = c->next;
1478 nc->consttype = FFEBLD_constINTEGER4;
1479 nc->u.integer4 = val;
1480 #ifdef FFECOM_constantHOOK
1481 nc->hook = FFECOM_constantNULL;
1482 #endif
1483 c->next = nc;
1484
1485 return nc;
1486 }
1487
1488 #endif
1489 /* ffebld_constant_new_integerbinary -- Return binary constant object from token
1490
1491 See prototype.
1492
1493 Parses the token as a binary integer constant, thus it must be an
1494 FFELEX_typeNUMBER. */
1495
1496 ffebldConstant
1497 ffebld_constant_new_integerbinary (ffelexToken t)
1498 {
1499 ffetargetIntegerDefault val;
1500
1501 assert ((ffelex_token_type (t) == FFELEX_typeNAME)
1502 || (ffelex_token_type (t) == FFELEX_typeNUMBER));
1503
1504 ffetarget_integerbinary (&val, t);
1505 return ffebld_constant_new_integerdefault_val (val);
1506 }
1507
1508 /* ffebld_constant_new_integerhex -- Return hex constant object from token
1509
1510 See prototype.
1511
1512 Parses the token as a hex integer constant, thus it must be an
1513 FFELEX_typeNUMBER. */
1514
1515 ffebldConstant
1516 ffebld_constant_new_integerhex (ffelexToken t)
1517 {
1518 ffetargetIntegerDefault val;
1519
1520 assert ((ffelex_token_type (t) == FFELEX_typeNAME)
1521 || (ffelex_token_type (t) == FFELEX_typeNUMBER));
1522
1523 ffetarget_integerhex (&val, t);
1524 return ffebld_constant_new_integerdefault_val (val);
1525 }
1526
1527 /* ffebld_constant_new_integeroctal -- Return octal constant object from token
1528
1529 See prototype.
1530
1531 Parses the token as a octal integer constant, thus it must be an
1532 FFELEX_typeNUMBER. */
1533
1534 ffebldConstant
1535 ffebld_constant_new_integeroctal (ffelexToken t)
1536 {
1537 ffetargetIntegerDefault val;
1538
1539 assert ((ffelex_token_type (t) == FFELEX_typeNAME)
1540 || (ffelex_token_type (t) == FFELEX_typeNUMBER));
1541
1542 ffetarget_integeroctal (&val, t);
1543 return ffebld_constant_new_integerdefault_val (val);
1544 }
1545
1546 /* ffebld_constant_new_logical1 -- Return logical1 constant object from token
1547
1548 See prototype.
1549
1550 Parses the token as a decimal logical constant, thus it must be an
1551 FFELEX_typeNUMBER. */
1552
1553 #if FFETARGET_okLOGICAL1
1554 ffebldConstant
1555 ffebld_constant_new_logical1 (bool truth)
1556 {
1557 ffetargetLogical1 val;
1558
1559 ffetarget_logical1 (&val, truth);
1560 return ffebld_constant_new_logical1_val (val);
1561 }
1562
1563 #endif
1564 /* ffebld_constant_new_logical1_val -- Return a logical1 constant object
1565
1566 See prototype. */
1567
1568 #if FFETARGET_okLOGICAL1
1569 ffebldConstant
1570 ffebld_constant_new_logical1_val (ffetargetLogical1 val)
1571 {
1572 ffebldConstant c;
1573 ffebldConstant nc;
1574 int cmp;
1575
1576 for (c = (ffebldConstant) &ffebld_constant_logical1_;
1577 c->next != NULL;
1578 c = c->next)
1579 {
1580 cmp = ffetarget_cmp_logical1 (val, ffebld_constant_logical1 (c->next));
1581 if (cmp == 0)
1582 return c->next;
1583 if (cmp > 0)
1584 break;
1585 }
1586
1587 nc = malloc_new_kp (ffebld_constant_pool(),
1588 "FFEBLD_constLOGICAL1",
1589 sizeof (*nc));
1590 nc->next = c->next;
1591 nc->consttype = FFEBLD_constLOGICAL1;
1592 nc->u.logical1 = val;
1593 #ifdef FFECOM_constantHOOK
1594 nc->hook = FFECOM_constantNULL;
1595 #endif
1596 c->next = nc;
1597
1598 return nc;
1599 }
1600
1601 #endif
1602 /* ffebld_constant_new_logical2_val -- Return a logical2 constant object
1603
1604 See prototype. */
1605
1606 #if FFETARGET_okLOGICAL2
1607 ffebldConstant
1608 ffebld_constant_new_logical2_val (ffetargetLogical2 val)
1609 {
1610 ffebldConstant c;
1611 ffebldConstant nc;
1612 int cmp;
1613
1614 for (c = (ffebldConstant) &ffebld_constant_logical2_;
1615 c->next != NULL;
1616 c = c->next)
1617 {
1618 cmp = ffetarget_cmp_logical2 (val, ffebld_constant_logical2 (c->next));
1619 if (cmp == 0)
1620 return c->next;
1621 if (cmp > 0)
1622 break;
1623 }
1624
1625 nc = malloc_new_kp (ffebld_constant_pool(),
1626 "FFEBLD_constLOGICAL2",
1627 sizeof (*nc));
1628 nc->next = c->next;
1629 nc->consttype = FFEBLD_constLOGICAL2;
1630 nc->u.logical2 = val;
1631 #ifdef FFECOM_constantHOOK
1632 nc->hook = FFECOM_constantNULL;
1633 #endif
1634 c->next = nc;
1635
1636 return nc;
1637 }
1638
1639 #endif
1640 /* ffebld_constant_new_logical3_val -- Return a logical3 constant object
1641
1642 See prototype. */
1643
1644 #if FFETARGET_okLOGICAL3
1645 ffebldConstant
1646 ffebld_constant_new_logical3_val (ffetargetLogical3 val)
1647 {
1648 ffebldConstant c;
1649 ffebldConstant nc;
1650 int cmp;
1651
1652 for (c = (ffebldConstant) &ffebld_constant_logical3_;
1653 c->next != NULL;
1654 c = c->next)
1655 {
1656 cmp = ffetarget_cmp_logical3 (val, ffebld_constant_logical3 (c->next));
1657 if (cmp == 0)
1658 return c->next;
1659 if (cmp > 0)
1660 break;
1661 }
1662
1663 nc = malloc_new_kp (ffebld_constant_pool(),
1664 "FFEBLD_constLOGICAL3",
1665 sizeof (*nc));
1666 nc->next = c->next;
1667 nc->consttype = FFEBLD_constLOGICAL3;
1668 nc->u.logical3 = val;
1669 #ifdef FFECOM_constantHOOK
1670 nc->hook = FFECOM_constantNULL;
1671 #endif
1672 c->next = nc;
1673
1674 return nc;
1675 }
1676
1677 #endif
1678 /* ffebld_constant_new_logical4_val -- Return a logical4 constant object
1679
1680 See prototype. */
1681
1682 #if FFETARGET_okLOGICAL4
1683 ffebldConstant
1684 ffebld_constant_new_logical4_val (ffetargetLogical4 val)
1685 {
1686 ffebldConstant c;
1687 ffebldConstant nc;
1688 int cmp;
1689
1690 for (c = (ffebldConstant) &ffebld_constant_logical4_;
1691 c->next != NULL;
1692 c = c->next)
1693 {
1694 cmp = ffetarget_cmp_logical4 (val, ffebld_constant_logical4 (c->next));
1695 if (cmp == 0)
1696 return c->next;
1697 if (cmp > 0)
1698 break;
1699 }
1700
1701 nc = malloc_new_kp (ffebld_constant_pool(),
1702 "FFEBLD_constLOGICAL4",
1703 sizeof (*nc));
1704 nc->next = c->next;
1705 nc->consttype = FFEBLD_constLOGICAL4;
1706 nc->u.logical4 = val;
1707 #ifdef FFECOM_constantHOOK
1708 nc->hook = FFECOM_constantNULL;
1709 #endif
1710 c->next = nc;
1711
1712 return nc;
1713 }
1714
1715 #endif
1716 /* ffebld_constant_new_real1 -- Return real1 constant object from token
1717
1718 See prototype. */
1719
1720 #if FFETARGET_okREAL1
1721 ffebldConstant
1722 ffebld_constant_new_real1 (ffelexToken integer, ffelexToken decimal,
1723 ffelexToken fraction, ffelexToken exponent, ffelexToken exponent_sign,
1724 ffelexToken exponent_digits)
1725 {
1726 ffetargetReal1 val;
1727
1728 ffetarget_real1 (&val,
1729 integer, decimal, fraction, exponent, exponent_sign, exponent_digits);
1730 return ffebld_constant_new_real1_val (val);
1731 }
1732
1733 #endif
1734 /* ffebld_constant_new_real1_val -- Return an real1 constant object
1735
1736 See prototype. */
1737
1738 #if FFETARGET_okREAL1
1739 ffebldConstant
1740 ffebld_constant_new_real1_val (ffetargetReal1 val)
1741 {
1742 ffebldConstant c;
1743 ffebldConstant nc;
1744 int cmp;
1745
1746 for (c = (ffebldConstant) &ffebld_constant_real1_;
1747 c->next != NULL;
1748 c = c->next)
1749 {
1750 cmp = ffetarget_cmp_real1 (val, ffebld_constant_real1 (c->next));
1751 if (cmp == 0)
1752 return c->next;
1753 if (cmp > 0)
1754 break;
1755 }
1756
1757 nc = malloc_new_kp (ffebld_constant_pool(),
1758 "FFEBLD_constREAL1",
1759 sizeof (*nc));
1760 nc->next = c->next;
1761 nc->consttype = FFEBLD_constREAL1;
1762 nc->u.real1 = val;
1763 #ifdef FFECOM_constantHOOK
1764 nc->hook = FFECOM_constantNULL;
1765 #endif
1766 c->next = nc;
1767
1768 return nc;
1769 }
1770
1771 #endif
1772 /* ffebld_constant_new_real2 -- Return real2 constant object from token
1773
1774 See prototype. */
1775
1776 #if FFETARGET_okREAL2
1777 ffebldConstant
1778 ffebld_constant_new_real2 (ffelexToken integer, ffelexToken decimal,
1779 ffelexToken fraction, ffelexToken exponent, ffelexToken exponent_sign,
1780 ffelexToken exponent_digits)
1781 {
1782 ffetargetReal2 val;
1783
1784 ffetarget_real2 (&val,
1785 integer, decimal, fraction, exponent, exponent_sign, exponent_digits);
1786 return ffebld_constant_new_real2_val (val);
1787 }
1788
1789 #endif
1790 /* ffebld_constant_new_real2_val -- Return an real2 constant object
1791
1792 See prototype. */
1793
1794 #if FFETARGET_okREAL2
1795 ffebldConstant
1796 ffebld_constant_new_real2_val (ffetargetReal2 val)
1797 {
1798 ffebldConstant c;
1799 ffebldConstant nc;
1800 int cmp;
1801
1802 for (c = (ffebldConstant) &ffebld_constant_real2_;
1803 c->next != NULL;
1804 c = c->next)
1805 {
1806 cmp = ffetarget_cmp_real2 (val, ffebld_constant_real2 (c->next));
1807 if (cmp == 0)
1808 return c->next;
1809 if (cmp > 0)
1810 break;
1811 }
1812
1813 nc = malloc_new_kp (ffebld_constant_pool(),
1814 "FFEBLD_constREAL2",
1815 sizeof (*nc));
1816 nc->next = c->next;
1817 nc->consttype = FFEBLD_constREAL2;
1818 nc->u.real2 = val;
1819 #ifdef FFECOM_constantHOOK
1820 nc->hook = FFECOM_constantNULL;
1821 #endif
1822 c->next = nc;
1823
1824 return nc;
1825 }
1826
1827 #endif
1828 /* ffebld_constant_new_typeless_bm -- Return typeless constant object from token
1829
1830 See prototype.
1831
1832 Parses the token as a decimal integer constant, thus it must be an
1833 FFELEX_typeNUMBER. */
1834
1835 ffebldConstant
1836 ffebld_constant_new_typeless_bm (ffelexToken t)
1837 {
1838 ffetargetTypeless val;
1839
1840 ffetarget_binarymil (&val, t);
1841 return ffebld_constant_new_typeless_val (FFEBLD_constBINARY_MIL, val);
1842 }
1843
1844 /* ffebld_constant_new_typeless_bv -- Return typeless constant object from token
1845
1846 See prototype.
1847
1848 Parses the token as a decimal integer constant, thus it must be an
1849 FFELEX_typeNUMBER. */
1850
1851 ffebldConstant
1852 ffebld_constant_new_typeless_bv (ffelexToken t)
1853 {
1854 ffetargetTypeless val;
1855
1856 ffetarget_binaryvxt (&val, t);
1857 return ffebld_constant_new_typeless_val (FFEBLD_constBINARY_VXT, val);
1858 }
1859
1860 /* ffebld_constant_new_typeless_hxm -- Return typeless constant object from token
1861
1862 See prototype.
1863
1864 Parses the token as a decimal integer constant, thus it must be an
1865 FFELEX_typeNUMBER. */
1866
1867 ffebldConstant
1868 ffebld_constant_new_typeless_hxm (ffelexToken t)
1869 {
1870 ffetargetTypeless val;
1871
1872 ffetarget_hexxmil (&val, t);
1873 return ffebld_constant_new_typeless_val (FFEBLD_constHEX_X_MIL, val);
1874 }
1875
1876 /* ffebld_constant_new_typeless_hxv -- Return typeless constant object from token
1877
1878 See prototype.
1879
1880 Parses the token as a decimal integer constant, thus it must be an
1881 FFELEX_typeNUMBER. */
1882
1883 ffebldConstant
1884 ffebld_constant_new_typeless_hxv (ffelexToken t)
1885 {
1886 ffetargetTypeless val;
1887
1888 ffetarget_hexxvxt (&val, t);
1889 return ffebld_constant_new_typeless_val (FFEBLD_constHEX_X_VXT, val);
1890 }
1891
1892 /* ffebld_constant_new_typeless_hzm -- Return typeless constant object from token
1893
1894 See prototype.
1895
1896 Parses the token as a decimal integer constant, thus it must be an
1897 FFELEX_typeNUMBER. */
1898
1899 ffebldConstant
1900 ffebld_constant_new_typeless_hzm (ffelexToken t)
1901 {
1902 ffetargetTypeless val;
1903
1904 ffetarget_hexzmil (&val, t);
1905 return ffebld_constant_new_typeless_val (FFEBLD_constHEX_Z_MIL, val);
1906 }
1907
1908 /* ffebld_constant_new_typeless_hzv -- Return typeless constant object from token
1909
1910 See prototype.
1911
1912 Parses the token as a decimal integer constant, thus it must be an
1913 FFELEX_typeNUMBER. */
1914
1915 ffebldConstant
1916 ffebld_constant_new_typeless_hzv (ffelexToken t)
1917 {
1918 ffetargetTypeless val;
1919
1920 ffetarget_hexzvxt (&val, t);
1921 return ffebld_constant_new_typeless_val (FFEBLD_constHEX_Z_VXT, val);
1922 }
1923
1924 /* ffebld_constant_new_typeless_om -- Return typeless constant object from token
1925
1926 See prototype.
1927
1928 Parses the token as a decimal integer constant, thus it must be an
1929 FFELEX_typeNUMBER. */
1930
1931 ffebldConstant
1932 ffebld_constant_new_typeless_om (ffelexToken t)
1933 {
1934 ffetargetTypeless val;
1935
1936 ffetarget_octalmil (&val, t);
1937 return ffebld_constant_new_typeless_val (FFEBLD_constOCTAL_MIL, val);
1938 }
1939
1940 /* ffebld_constant_new_typeless_ov -- Return typeless constant object from token
1941
1942 See prototype.
1943
1944 Parses the token as a decimal integer constant, thus it must be an
1945 FFELEX_typeNUMBER. */
1946
1947 ffebldConstant
1948 ffebld_constant_new_typeless_ov (ffelexToken t)
1949 {
1950 ffetargetTypeless val;
1951
1952 ffetarget_octalvxt (&val, t);
1953 return ffebld_constant_new_typeless_val (FFEBLD_constOCTAL_VXT, val);
1954 }
1955
1956 /* ffebld_constant_new_typeless_val -- Return a typeless constant object
1957
1958 See prototype. */
1959
1960 ffebldConstant
1961 ffebld_constant_new_typeless_val (ffebldConst type, ffetargetTypeless val)
1962 {
1963 ffebldConstant c;
1964 ffebldConstant nc;
1965 int cmp;
1966
1967 for (c = (ffebldConstant) &ffebld_constant_typeless_[type
1968 - FFEBLD_constTYPELESS_FIRST];
1969 c->next != NULL;
1970 c = c->next)
1971 {
1972 cmp = ffetarget_cmp_typeless (val, ffebld_constant_typeless (c->next));
1973 if (cmp == 0)
1974 return c->next;
1975 if (cmp > 0)
1976 break;
1977 }
1978
1979 nc = malloc_new_kp (ffebld_constant_pool(),
1980 "FFEBLD_constTYPELESS",
1981 sizeof (*nc));
1982 nc->next = c->next;
1983 nc->consttype = type;
1984 nc->u.typeless = val;
1985 #ifdef FFECOM_constantHOOK
1986 nc->hook = FFECOM_constantNULL;
1987 #endif
1988 c->next = nc;
1989
1990 return nc;
1991 }
1992
1993 /* ffebld_constantarray_dump -- Display summary of array's contents
1994
1995 ffebldConstantArray a;
1996 ffeinfoBasictype bt;
1997 ffeinfoKindtype kt;
1998 ffetargetOffset size;
1999 ffebld_constant_dump(a,bt,kt,size,NULL);
2000
2001 Displays the constant array in summary form. The fifth argument, if
2002 supplied, is an ffebit object that is consulted as to whether the
2003 constant at a particular offset is valid. */
2004
2005 void
2006 ffebld_constantarray_dump (ffebldConstantArray array, ffeinfoBasictype bt,
2007 ffeinfoKindtype kt, ffetargetOffset size, ffebit bits)
2008 {
2009 ffetargetOffset i;
2010 ffebitCount j;
2011
2012 ffebld_dump_prefix (dmpout, bt, kt);
2013
2014 fprintf (dmpout, "\\(");
2015
2016 if (bits == NULL)
2017 {
2018 for (i = 0; i < size; ++i)
2019 {
2020 ffebld_constantunion_dump (ffebld_constantarray_get (array, bt, kt, i), bt,
2021 kt);
2022 if (i != size - 1)
2023 fputc (',', dmpout);
2024 }
2025 }
2026 else
2027 {
2028 bool value;
2029 ffebitCount length;
2030 ffetargetOffset offset = 0;
2031
2032 do
2033 {
2034 ffebit_test (bits, offset, &value, &length);
2035 if (value && (length != 0))
2036 {
2037 if (length == 1)
2038 fprintf (dmpout, "[%" ffetargetOffset_f "d]:", offset);
2039 else
2040 fprintf (dmpout,
2041 "[%" ffetargetOffset_f "u..%" ffetargetOffset_f "d]:",
2042 offset, offset + (ffetargetOffset) length - 1);
2043 for (j = 0; j < length; ++j, ++offset)
2044 {
2045 ffebld_constantunion_dump (ffebld_constantarray_get (array, bt, kt,
2046 offset), bt, kt);
2047 if (j != length - 1)
2048 fputc (',', dmpout);
2049 }
2050 fprintf (dmpout, ";");
2051 }
2052 else
2053 offset += length;
2054 }
2055 while (length != 0);
2056 }
2057 fprintf (dmpout, "\\)");
2058
2059 }
2060
2061 /* ffebld_constantarray_get -- Get a value from an array of constants
2062
2063 See prototype. */
2064
2065 ffebldConstantUnion
2066 ffebld_constantarray_get (ffebldConstantArray array, ffeinfoBasictype bt,
2067 ffeinfoKindtype kt, ffetargetOffset offset)
2068 {
2069 ffebldConstantUnion u;
2070
2071 switch (bt)
2072 {
2073 case FFEINFO_basictypeINTEGER:
2074 switch (kt)
2075 {
2076 #if FFETARGET_okINTEGER1
2077 case FFEINFO_kindtypeINTEGER1:
2078 u.integer1 = *(array.integer1 + offset);
2079 break;
2080 #endif
2081
2082 #if FFETARGET_okINTEGER2
2083 case FFEINFO_kindtypeINTEGER2:
2084 u.integer2 = *(array.integer2 + offset);
2085 break;
2086 #endif
2087
2088 #if FFETARGET_okINTEGER3
2089 case FFEINFO_kindtypeINTEGER3:
2090 u.integer3 = *(array.integer3 + offset);
2091 break;
2092 #endif
2093
2094 #if FFETARGET_okINTEGER4
2095 case FFEINFO_kindtypeINTEGER4:
2096 u.integer4 = *(array.integer4 + offset);
2097 break;
2098 #endif
2099
2100 #if FFETARGET_okINTEGER5
2101 case FFEINFO_kindtypeINTEGER5:
2102 u.integer5 = *(array.integer5 + offset);
2103 break;
2104 #endif
2105
2106 #if FFETARGET_okINTEGER6
2107 case FFEINFO_kindtypeINTEGER6:
2108 u.integer6 = *(array.integer6 + offset);
2109 break;
2110 #endif
2111
2112 #if FFETARGET_okINTEGER7
2113 case FFEINFO_kindtypeINTEGER7:
2114 u.integer7 = *(array.integer7 + offset);
2115 break;
2116 #endif
2117
2118 #if FFETARGET_okINTEGER8
2119 case FFEINFO_kindtypeINTEGER8:
2120 u.integer8 = *(array.integer8 + offset);
2121 break;
2122 #endif
2123
2124 default:
2125 assert ("bad INTEGER kindtype" == NULL);
2126 break;
2127 }
2128 break;
2129
2130 case FFEINFO_basictypeLOGICAL:
2131 switch (kt)
2132 {
2133 #if FFETARGET_okLOGICAL1
2134 case FFEINFO_kindtypeLOGICAL1:
2135 u.logical1 = *(array.logical1 + offset);
2136 break;
2137 #endif
2138
2139 #if FFETARGET_okLOGICAL2
2140 case FFEINFO_kindtypeLOGICAL2:
2141 u.logical2 = *(array.logical2 + offset);
2142 break;
2143 #endif
2144
2145 #if FFETARGET_okLOGICAL3
2146 case FFEINFO_kindtypeLOGICAL3:
2147 u.logical3 = *(array.logical3 + offset);
2148 break;
2149 #endif
2150
2151 #if FFETARGET_okLOGICAL4
2152 case FFEINFO_kindtypeLOGICAL4:
2153 u.logical4 = *(array.logical4 + offset);
2154 break;
2155 #endif
2156
2157 #if FFETARGET_okLOGICAL5
2158 case FFEINFO_kindtypeLOGICAL5:
2159 u.logical5 = *(array.logical5 + offset);
2160 break;
2161 #endif
2162
2163 #if FFETARGET_okLOGICAL6
2164 case FFEINFO_kindtypeLOGICAL6:
2165 u.logical6 = *(array.logical6 + offset);
2166 break;
2167 #endif
2168
2169 #if FFETARGET_okLOGICAL7
2170 case FFEINFO_kindtypeLOGICAL7:
2171 u.logical7 = *(array.logical7 + offset);
2172 break;
2173 #endif
2174
2175 #if FFETARGET_okLOGICAL8
2176 case FFEINFO_kindtypeLOGICAL8:
2177 u.logical8 = *(array.logical8 + offset);
2178 break;
2179 #endif
2180
2181 default:
2182 assert ("bad LOGICAL kindtype" == NULL);
2183 break;
2184 }
2185 break;
2186
2187 case FFEINFO_basictypeREAL:
2188 switch (kt)
2189 {
2190 #if FFETARGET_okREAL1
2191 case FFEINFO_kindtypeREAL1:
2192 u.real1 = *(array.real1 + offset);
2193 break;
2194 #endif
2195
2196 #if FFETARGET_okREAL2
2197 case FFEINFO_kindtypeREAL2:
2198 u.real2 = *(array.real2 + offset);
2199 break;
2200 #endif
2201
2202 #if FFETARGET_okREAL3
2203 case FFEINFO_kindtypeREAL3:
2204 u.real3 = *(array.real3 + offset);
2205 break;
2206 #endif
2207
2208 #if FFETARGET_okREAL4
2209 case FFEINFO_kindtypeREAL4:
2210 u.real4 = *(array.real4 + offset);
2211 break;
2212 #endif
2213
2214 #if FFETARGET_okREAL5
2215 case FFEINFO_kindtypeREAL5:
2216 u.real5 = *(array.real5 + offset);
2217 break;
2218 #endif
2219
2220 #if FFETARGET_okREAL6
2221 case FFEINFO_kindtypeREAL6:
2222 u.real6 = *(array.real6 + offset);
2223 break;
2224 #endif
2225
2226 #if FFETARGET_okREAL7
2227 case FFEINFO_kindtypeREAL7:
2228 u.real7 = *(array.real7 + offset);
2229 break;
2230 #endif
2231
2232 #if FFETARGET_okREAL8
2233 case FFEINFO_kindtypeREAL8:
2234 u.real8 = *(array.real8 + offset);
2235 break;
2236 #endif
2237
2238 default:
2239 assert ("bad REAL kindtype" == NULL);
2240 break;
2241 }
2242 break;
2243
2244 case FFEINFO_basictypeCOMPLEX:
2245 switch (kt)
2246 {
2247 #if FFETARGET_okCOMPLEX1
2248 case FFEINFO_kindtypeREAL1:
2249 u.complex1 = *(array.complex1 + offset);
2250 break;
2251 #endif
2252
2253 #if FFETARGET_okCOMPLEX2
2254 case FFEINFO_kindtypeREAL2:
2255 u.complex2 = *(array.complex2 + offset);
2256 break;
2257 #endif
2258
2259 #if FFETARGET_okCOMPLEX3
2260 case FFEINFO_kindtypeREAL3:
2261 u.complex3 = *(array.complex3 + offset);
2262 break;
2263 #endif
2264
2265 #if FFETARGET_okCOMPLEX4
2266 case FFEINFO_kindtypeREAL4:
2267 u.complex4 = *(array.complex4 + offset);
2268 break;
2269 #endif
2270
2271 #if FFETARGET_okCOMPLEX5
2272 case FFEINFO_kindtypeREAL5:
2273 u.complex5 = *(array.complex5 + offset);
2274 break;
2275 #endif
2276
2277 #if FFETARGET_okCOMPLEX6
2278 case FFEINFO_kindtypeREAL6:
2279 u.complex6 = *(array.complex6 + offset);
2280 break;
2281 #endif
2282
2283 #if FFETARGET_okCOMPLEX7
2284 case FFEINFO_kindtypeREAL7:
2285 u.complex7 = *(array.complex7 + offset);
2286 break;
2287 #endif
2288
2289 #if FFETARGET_okCOMPLEX8
2290 case FFEINFO_kindtypeREAL8:
2291 u.complex8 = *(array.complex8 + offset);
2292 break;
2293 #endif
2294
2295 default:
2296 assert ("bad COMPLEX kindtype" == NULL);
2297 break;
2298 }
2299 break;
2300
2301 case FFEINFO_basictypeCHARACTER:
2302 switch (kt)
2303 {
2304 #if FFETARGET_okCHARACTER1
2305 case FFEINFO_kindtypeCHARACTER1:
2306 u.character1.length = 1;
2307 u.character1.text = array.character1 + offset;
2308 break;
2309 #endif
2310
2311 #if FFETARGET_okCHARACTER2
2312 case FFEINFO_kindtypeCHARACTER2:
2313 u.character2.length = 1;
2314 u.character2.text = array.character2 + offset;
2315 break;
2316 #endif
2317
2318 #if FFETARGET_okCHARACTER3
2319 case FFEINFO_kindtypeCHARACTER3:
2320 u.character3.length = 1;
2321 u.character3.text = array.character3 + offset;
2322 break;
2323 #endif
2324
2325 #if FFETARGET_okCHARACTER4
2326 case FFEINFO_kindtypeCHARACTER4:
2327 u.character4.length = 1;
2328 u.character4.text = array.character4 + offset;
2329 break;
2330 #endif
2331
2332 #if FFETARGET_okCHARACTER5
2333 case FFEINFO_kindtypeCHARACTER5:
2334 u.character5.length = 1;
2335 u.character5.text = array.character5 + offset;
2336 break;
2337 #endif
2338
2339 #if FFETARGET_okCHARACTER6
2340 case FFEINFO_kindtypeCHARACTER6:
2341 u.character6.length = 1;
2342 u.character6.text = array.character6 + offset;
2343 break;
2344 #endif
2345
2346 #if FFETARGET_okCHARACTER7
2347 case FFEINFO_kindtypeCHARACTER7:
2348 u.character7.length = 1;
2349 u.character7.text = array.character7 + offset;
2350 break;
2351 #endif
2352
2353 #if FFETARGET_okCHARACTER8
2354 case FFEINFO_kindtypeCHARACTER8:
2355 u.character8.length = 1;
2356 u.character8.text = array.character8 + offset;
2357 break;
2358 #endif
2359
2360 default:
2361 assert ("bad CHARACTER kindtype" == NULL);
2362 break;
2363 }
2364 break;
2365
2366 default:
2367 assert ("bad basictype" == NULL);
2368 break;
2369 }
2370
2371 return u;
2372 }
2373
2374 /* ffebld_constantarray_new -- Make an array of constants
2375
2376 See prototype. */
2377
2378 ffebldConstantArray
2379 ffebld_constantarray_new (ffeinfoBasictype bt,
2380 ffeinfoKindtype kt, ffetargetOffset size)
2381 {
2382 ffebldConstantArray ptr;
2383
2384 switch (bt)
2385 {
2386 case FFEINFO_basictypeINTEGER:
2387 switch (kt)
2388 {
2389 #if FFETARGET_okINTEGER1
2390 case FFEINFO_kindtypeINTEGER1:
2391 ptr.integer1 = malloc_new_zkp (ffebld_constant_pool(),
2392 "ffebldConstantArray",
2393 size *= sizeof (ffetargetInteger1),
2394 0);
2395 break;
2396 #endif
2397
2398 #if FFETARGET_okINTEGER2
2399 case FFEINFO_kindtypeINTEGER2:
2400 ptr.integer2 = malloc_new_zkp (ffebld_constant_pool(),
2401 "ffebldConstantArray",
2402 size *= sizeof (ffetargetInteger2),
2403 0);
2404 break;
2405 #endif
2406
2407 #if FFETARGET_okINTEGER3
2408 case FFEINFO_kindtypeINTEGER3:
2409 ptr.integer3 = malloc_new_zkp (ffebld_constant_pool(),
2410 "ffebldConstantArray",
2411 size *= sizeof (ffetargetInteger3),
2412 0);
2413 break;
2414 #endif
2415
2416 #if FFETARGET_okINTEGER4
2417 case FFEINFO_kindtypeINTEGER4:
2418 ptr.integer4 = malloc_new_zkp (ffebld_constant_pool(),
2419 "ffebldConstantArray",
2420 size *= sizeof (ffetargetInteger4),
2421 0);
2422 break;
2423 #endif
2424
2425 #if FFETARGET_okINTEGER5
2426 case FFEINFO_kindtypeINTEGER5:
2427 ptr.integer5 = malloc_new_zkp (ffebld_constant_pool(),
2428 "ffebldConstantArray",
2429 size *= sizeof (ffetargetInteger5),
2430 0);
2431 break;
2432 #endif
2433
2434 #if FFETARGET_okINTEGER6
2435 case FFEINFO_kindtypeINTEGER6:
2436 ptr.integer6 = malloc_new_zkp (ffebld_constant_pool(),
2437 "ffebldConstantArray",
2438 size *= sizeof (ffetargetInteger6),
2439 0);
2440 break;
2441 #endif
2442
2443 #if FFETARGET_okINTEGER7
2444 case FFEINFO_kindtypeINTEGER7:
2445 ptr.integer7 = malloc_new_zkp (ffebld_constant_pool(),
2446 "ffebldConstantArray",
2447 size *= sizeof (ffetargetInteger7),
2448 0);
2449 break;
2450 #endif
2451
2452 #if FFETARGET_okINTEGER8
2453 case FFEINFO_kindtypeINTEGER8:
2454 ptr.integer8 = malloc_new_zkp (ffebld_constant_pool(),
2455 "ffebldConstantArray",
2456 size *= sizeof (ffetargetInteger8),
2457 0);
2458 break;
2459 #endif
2460
2461 default:
2462 assert ("bad INTEGER kindtype" == NULL);
2463 break;
2464 }
2465 break;
2466
2467 case FFEINFO_basictypeLOGICAL:
2468 switch (kt)
2469 {
2470 #if FFETARGET_okLOGICAL1
2471 case FFEINFO_kindtypeLOGICAL1:
2472 ptr.logical1 = malloc_new_zkp (ffebld_constant_pool(),
2473 "ffebldConstantArray",
2474 size *= sizeof (ffetargetLogical1),
2475 0);
2476 break;
2477 #endif
2478
2479 #if FFETARGET_okLOGICAL2
2480 case FFEINFO_kindtypeLOGICAL2:
2481 ptr.logical2 = malloc_new_zkp (ffebld_constant_pool(),
2482 "ffebldConstantArray",
2483 size *= sizeof (ffetargetLogical2),
2484 0);
2485 break;
2486 #endif
2487
2488 #if FFETARGET_okLOGICAL3
2489 case FFEINFO_kindtypeLOGICAL3:
2490 ptr.logical3 = malloc_new_zkp (ffebld_constant_pool(),
2491 "ffebldConstantArray",
2492 size *= sizeof (ffetargetLogical3),
2493 0);
2494 break;
2495 #endif
2496
2497 #if FFETARGET_okLOGICAL4
2498 case FFEINFO_kindtypeLOGICAL4:
2499 ptr.logical4 = malloc_new_zkp (ffebld_constant_pool(),
2500 "ffebldConstantArray",
2501 size *= sizeof (ffetargetLogical4),
2502 0);
2503 break;
2504 #endif
2505
2506 #if FFETARGET_okLOGICAL5
2507 case FFEINFO_kindtypeLOGICAL5:
2508 ptr.logical5 = malloc_new_zkp (ffebld_constant_pool(),
2509 "ffebldConstantArray",
2510 size *= sizeof (ffetargetLogical5),
2511 0);
2512 break;
2513 #endif
2514
2515 #if FFETARGET_okLOGICAL6
2516 case FFEINFO_kindtypeLOGICAL6:
2517 ptr.logical6 = malloc_new_zkp (ffebld_constant_pool(),
2518 "ffebldConstantArray",
2519 size *= sizeof (ffetargetLogical6),
2520 0);
2521 break;
2522 #endif
2523
2524 #if FFETARGET_okLOGICAL7
2525 case FFEINFO_kindtypeLOGICAL7:
2526 ptr.logical7 = malloc_new_zkp (ffebld_constant_pool(),
2527 "ffebldConstantArray",
2528 size *= sizeof (ffetargetLogical7),
2529 0);
2530 break;
2531 #endif
2532
2533 #if FFETARGET_okLOGICAL8
2534 case FFEINFO_kindtypeLOGICAL8:
2535 ptr.logical8 = malloc_new_zkp (ffebld_constant_pool(),
2536 "ffebldConstantArray",
2537 size *= sizeof (ffetargetLogical8),
2538 0);
2539 break;
2540 #endif
2541
2542 default:
2543 assert ("bad LOGICAL kindtype" == NULL);
2544 break;
2545 }
2546 break;
2547
2548 case FFEINFO_basictypeREAL:
2549 switch (kt)
2550 {
2551 #if FFETARGET_okREAL1
2552 case FFEINFO_kindtypeREAL1:
2553 ptr.real1 = malloc_new_zkp (ffebld_constant_pool(),
2554 "ffebldConstantArray",
2555 size *= sizeof (ffetargetReal1),
2556 0);
2557 break;
2558 #endif
2559
2560 #if FFETARGET_okREAL2
2561 case FFEINFO_kindtypeREAL2:
2562 ptr.real2 = malloc_new_zkp (ffebld_constant_pool(),
2563 "ffebldConstantArray",
2564 size *= sizeof (ffetargetReal2),
2565 0);
2566 break;
2567 #endif
2568
2569 #if FFETARGET_okREAL3
2570 case FFEINFO_kindtypeREAL3:
2571 ptr.real3 = malloc_new_zkp (ffebld_constant_pool(),
2572 "ffebldConstantArray",
2573 size *= sizeof (ffetargetReal3),
2574 0);
2575 break;
2576 #endif
2577
2578 #if FFETARGET_okREAL4
2579 case FFEINFO_kindtypeREAL4:
2580 ptr.real4 = malloc_new_zkp (ffebld_constant_pool(),
2581 "ffebldConstantArray",
2582 size *= sizeof (ffetargetReal4),
2583 0);
2584 break;
2585 #endif
2586
2587 #if FFETARGET_okREAL5
2588 case FFEINFO_kindtypeREAL5:
2589 ptr.real5 = malloc_new_zkp (ffebld_constant_pool(),
2590 "ffebldConstantArray",
2591 size *= sizeof (ffetargetReal5),
2592 0);
2593 break;
2594 #endif
2595
2596 #if FFETARGET_okREAL6
2597 case FFEINFO_kindtypeREAL6:
2598 ptr.real6 = malloc_new_zkp (ffebld_constant_pool(),
2599 "ffebldConstantArray",
2600 size *= sizeof (ffetargetReal6),
2601 0);
2602 break;
2603 #endif
2604
2605 #if FFETARGET_okREAL7
2606 case FFEINFO_kindtypeREAL7:
2607 ptr.real7 = malloc_new_zkp (ffebld_constant_pool(),
2608 "ffebldConstantArray",
2609 size *= sizeof (ffetargetReal7),
2610 0);
2611 break;
2612 #endif
2613
2614 #if FFETARGET_okREAL8
2615 case FFEINFO_kindtypeREAL8:
2616 ptr.real8 = malloc_new_zkp (ffebld_constant_pool(),
2617 "ffebldConstantArray",
2618 size *= sizeof (ffetargetReal8),
2619 0);
2620 break;
2621 #endif
2622
2623 default:
2624 assert ("bad REAL kindtype" == NULL);
2625 break;
2626 }
2627 break;
2628
2629 case FFEINFO_basictypeCOMPLEX:
2630 switch (kt)
2631 {
2632 #if FFETARGET_okCOMPLEX1
2633 case FFEINFO_kindtypeREAL1:
2634 ptr.complex1 = malloc_new_zkp (ffebld_constant_pool(),
2635 "ffebldConstantArray",
2636 size *= sizeof (ffetargetComplex1),
2637 0);
2638 break;
2639 #endif
2640
2641 #if FFETARGET_okCOMPLEX2
2642 case FFEINFO_kindtypeREAL2:
2643 ptr.complex2 = malloc_new_zkp (ffebld_constant_pool(),
2644 "ffebldConstantArray",
2645 size *= sizeof (ffetargetComplex2),
2646 0);
2647 break;
2648 #endif
2649
2650 #if FFETARGET_okCOMPLEX3
2651 case FFEINFO_kindtypeREAL3:
2652 ptr.complex3 = malloc_new_zkp (ffebld_constant_pool(),
2653 "ffebldConstantArray",
2654 size *= sizeof (ffetargetComplex3),
2655 0);
2656 break;
2657 #endif
2658
2659 #if FFETARGET_okCOMPLEX4
2660 case FFEINFO_kindtypeREAL4:
2661 ptr.complex4 = malloc_new_zkp (ffebld_constant_pool(),
2662 "ffebldConstantArray",
2663 size *= sizeof (ffetargetComplex4),
2664 0);
2665 break;
2666 #endif
2667
2668 #if FFETARGET_okCOMPLEX5
2669 case FFEINFO_kindtypeREAL5:
2670 ptr.complex5 = malloc_new_zkp (ffebld_constant_pool(),
2671 "ffebldConstantArray",
2672 size *= sizeof (ffetargetComplex5),
2673 0);
2674 break;
2675 #endif
2676
2677 #if FFETARGET_okCOMPLEX6
2678 case FFEINFO_kindtypeREAL6:
2679 ptr.complex6 = malloc_new_zkp (ffebld_constant_pool(),
2680 "ffebldConstantArray",
2681 size *= sizeof (ffetargetComplex6),
2682 0);
2683 break;
2684 #endif
2685
2686 #if FFETARGET_okCOMPLEX7
2687 case FFEINFO_kindtypeREAL7:
2688 ptr.complex7 = malloc_new_zkp (ffebld_constant_pool(),
2689 "ffebldConstantArray",
2690 size *= sizeof (ffetargetComplex7),
2691 0);
2692 break;
2693 #endif
2694
2695 #if FFETARGET_okCOMPLEX8
2696 case FFEINFO_kindtypeREAL8:
2697 ptr.complex8 = malloc_new_zkp (ffebld_constant_pool(),
2698 "ffebldConstantArray",
2699 size *= sizeof (ffetargetComplex8),
2700 0);
2701 break;
2702 #endif
2703
2704 default:
2705 assert ("bad COMPLEX kindtype" == NULL);
2706 break;
2707 }
2708 break;
2709
2710 case FFEINFO_basictypeCHARACTER:
2711 switch (kt)
2712 {
2713 #if FFETARGET_okCHARACTER1
2714 case FFEINFO_kindtypeCHARACTER1:
2715 ptr.character1 = malloc_new_zkp (ffebld_constant_pool(),
2716 "ffebldConstantArray",
2717 size
2718 *= sizeof (ffetargetCharacterUnit1),
2719 0);
2720 break;
2721 #endif
2722
2723 #if FFETARGET_okCHARACTER2
2724 case FFEINFO_kindtypeCHARACTER2:
2725 ptr.character2 = malloc_new_zkp (ffebld_constant_pool(),
2726 "ffebldConstantArray",
2727 size
2728 *= sizeof (ffetargetCharacterUnit2),
2729 0);
2730 break;
2731 #endif
2732
2733 #if FFETARGET_okCHARACTER3
2734 case FFEINFO_kindtypeCHARACTER3:
2735 ptr.character3 = malloc_new_zkp (ffebld_constant_pool(),
2736 "ffebldConstantArray",
2737 size
2738 *= sizeof (ffetargetCharacterUnit3),
2739 0);
2740 break;
2741 #endif
2742
2743 #if FFETARGET_okCHARACTER4
2744 case FFEINFO_kindtypeCHARACTER4:
2745 ptr.character4 = malloc_new_zkp (ffebld_constant_pool(),
2746 "ffebldConstantArray",
2747 size
2748 *= sizeof (ffetargetCharacterUnit4),
2749 0);
2750 break;
2751 #endif
2752
2753 #if FFETARGET_okCHARACTER5
2754 case FFEINFO_kindtypeCHARACTER5:
2755 ptr.character5 = malloc_new_zkp (ffebld_constant_pool(),
2756 "ffebldConstantArray",
2757 size
2758 *= sizeof (ffetargetCharacterUnit5),
2759 0);
2760 break;
2761 #endif
2762
2763 #if FFETARGET_okCHARACTER6
2764 case FFEINFO_kindtypeCHARACTER6:
2765 ptr.character6 = malloc_new_zkp (ffebld_constant_pool(),
2766 "ffebldConstantArray",
2767 size
2768 *= sizeof (ffetargetCharacterUnit6),
2769 0);
2770 break;
2771 #endif
2772
2773 #if FFETARGET_okCHARACTER7
2774 case FFEINFO_kindtypeCHARACTER7:
2775 ptr.character7 = malloc_new_zkp (ffebld_constant_pool(),
2776 "ffebldConstantArray",
2777 size
2778 *= sizeof (ffetargetCharacterUnit7),
2779 0);
2780 break;
2781 #endif
2782
2783 #if FFETARGET_okCHARACTER8
2784 case FFEINFO_kindtypeCHARACTER8:
2785 ptr.character8 = malloc_new_zkp (ffebld_constant_pool(),
2786 "ffebldConstantArray",
2787 size
2788 *= sizeof (ffetargetCharacterUnit8),
2789 0);
2790 break;
2791 #endif
2792
2793 default:
2794 assert ("bad CHARACTER kindtype" == NULL);
2795 break;
2796 }
2797 break;
2798
2799 default:
2800 assert ("bad basictype" == NULL);
2801 break;
2802 }
2803
2804 return ptr;
2805 }
2806
2807 /* ffebld_constantarray_preparray -- Prepare for copy between arrays
2808
2809 See prototype.
2810
2811 Like _prepare, but the source is an array instead of a single-value
2812 constant. */
2813
2814 void
2815 ffebld_constantarray_preparray (void **aptr, void **cptr, size_t *size,
2816 ffebldConstantArray array, ffeinfoBasictype abt, ffeinfoKindtype akt,
2817 ffetargetOffset offset, ffebldConstantArray source_array,
2818 ffeinfoBasictype cbt, ffeinfoKindtype ckt)
2819 {
2820 switch (abt)
2821 {
2822 case FFEINFO_basictypeINTEGER:
2823 switch (akt)
2824 {
2825 #if FFETARGET_okINTEGER1
2826 case FFEINFO_kindtypeINTEGER1:
2827 *aptr = array.integer1 + offset;
2828 break;
2829 #endif
2830
2831 #if FFETARGET_okINTEGER2
2832 case FFEINFO_kindtypeINTEGER2:
2833 *aptr = array.integer2 + offset;
2834 break;
2835 #endif
2836
2837 #if FFETARGET_okINTEGER3
2838 case FFEINFO_kindtypeINTEGER3:
2839 *aptr = array.integer3 + offset;
2840 break;
2841 #endif
2842
2843 #if FFETARGET_okINTEGER4
2844 case FFEINFO_kindtypeINTEGER4:
2845 *aptr = array.integer4 + offset;
2846 break;
2847 #endif
2848
2849 #if FFETARGET_okINTEGER5
2850 case FFEINFO_kindtypeINTEGER5:
2851 *aptr = array.integer5 + offset;
2852 break;
2853 #endif
2854
2855 #if FFETARGET_okINTEGER6
2856 case FFEINFO_kindtypeINTEGER6:
2857 *aptr = array.integer6 + offset;
2858 break;
2859 #endif
2860
2861 #if FFETARGET_okINTEGER7
2862 case FFEINFO_kindtypeINTEGER7:
2863 *aptr = array.integer7 + offset;
2864 break;
2865 #endif
2866
2867 #if FFETARGET_okINTEGER8
2868 case FFEINFO_kindtypeINTEGER8:
2869 *aptr = array.integer8 + offset;
2870 break;
2871 #endif
2872
2873 default:
2874 assert ("bad INTEGER akindtype" == NULL);
2875 break;
2876 }
2877 break;
2878
2879 case FFEINFO_basictypeLOGICAL:
2880 switch (akt)
2881 {
2882 #if FFETARGET_okLOGICAL1
2883 case FFEINFO_kindtypeLOGICAL1:
2884 *aptr = array.logical1 + offset;
2885 break;
2886 #endif
2887
2888 #if FFETARGET_okLOGICAL2
2889 case FFEINFO_kindtypeLOGICAL2:
2890 *aptr = array.logical2 + offset;
2891 break;
2892 #endif
2893
2894 #if FFETARGET_okLOGICAL3
2895 case FFEINFO_kindtypeLOGICAL3:
2896 *aptr = array.logical3 + offset;
2897 break;
2898 #endif
2899
2900 #if FFETARGET_okLOGICAL4
2901 case FFEINFO_kindtypeLOGICAL4:
2902 *aptr = array.logical4 + offset;
2903 break;
2904 #endif
2905
2906 #if FFETARGET_okLOGICAL5
2907 case FFEINFO_kindtypeLOGICAL5:
2908 *aptr = array.logical5 + offset;
2909 break;
2910 #endif
2911
2912 #if FFETARGET_okLOGICAL6
2913 case FFEINFO_kindtypeLOGICAL6:
2914 *aptr = array.logical6 + offset;
2915 break;
2916 #endif
2917
2918 #if FFETARGET_okLOGICAL7
2919 case FFEINFO_kindtypeLOGICAL7:
2920 *aptr = array.logical7 + offset;
2921 break;
2922 #endif
2923
2924 #if FFETARGET_okLOGICAL8
2925 case FFEINFO_kindtypeLOGICAL8:
2926 *aptr = array.logical8 + offset;
2927 break;
2928 #endif
2929
2930 default:
2931 assert ("bad LOGICAL akindtype" == NULL);
2932 break;
2933 }
2934 break;
2935
2936 case FFEINFO_basictypeREAL:
2937 switch (akt)
2938 {
2939 #if FFETARGET_okREAL1
2940 case FFEINFO_kindtypeREAL1:
2941 *aptr = array.real1 + offset;
2942 break;
2943 #endif
2944
2945 #if FFETARGET_okREAL2
2946 case FFEINFO_kindtypeREAL2:
2947 *aptr = array.real2 + offset;
2948 break;
2949 #endif
2950
2951 #if FFETARGET_okREAL3
2952 case FFEINFO_kindtypeREAL3:
2953 *aptr = array.real3 + offset;
2954 break;
2955 #endif
2956
2957 #if FFETARGET_okREAL4
2958 case FFEINFO_kindtypeREAL4:
2959 *aptr = array.real4 + offset;
2960 break;
2961 #endif
2962
2963 #if FFETARGET_okREAL5
2964 case FFEINFO_kindtypeREAL5:
2965 *aptr = array.real5 + offset;
2966 break;
2967 #endif
2968
2969 #if FFETARGET_okREAL6
2970 case FFEINFO_kindtypeREAL6:
2971 *aptr = array.real6 + offset;
2972 break;
2973 #endif
2974
2975 #if FFETARGET_okREAL7
2976 case FFEINFO_kindtypeREAL7:
2977 *aptr = array.real7 + offset;
2978 break;
2979 #endif
2980
2981 #if FFETARGET_okREAL8
2982 case FFEINFO_kindtypeREAL8:
2983 *aptr = array.real8 + offset;
2984 break;
2985 #endif
2986
2987 default:
2988 assert ("bad REAL akindtype" == NULL);
2989 break;
2990 }
2991 break;
2992
2993 case FFEINFO_basictypeCOMPLEX:
2994 switch (akt)
2995 {
2996 #if FFETARGET_okCOMPLEX1
2997 case FFEINFO_kindtypeREAL1:
2998 *aptr = array.complex1 + offset;
2999 break;
3000 #endif
3001
3002 #if FFETARGET_okCOMPLEX2
3003 case FFEINFO_kindtypeREAL2:
3004 *aptr = array.complex2 + offset;
3005 break;
3006 #endif
3007
3008 #if FFETARGET_okCOMPLEX3
3009 case FFEINFO_kindtypeREAL3:
3010 *aptr = array.complex3 + offset;
3011 break;
3012 #endif
3013
3014 #if FFETARGET_okCOMPLEX4
3015 case FFEINFO_kindtypeREAL4:
3016 *aptr = array.complex4 + offset;
3017 break;
3018 #endif
3019
3020 #if FFETARGET_okCOMPLEX5
3021 case FFEINFO_kindtypeREAL5:
3022 *aptr = array.complex5 + offset;
3023 break;
3024 #endif
3025
3026 #if FFETARGET_okCOMPLEX6
3027 case FFEINFO_kindtypeREAL6:
3028 *aptr = array.complex6 + offset;
3029 break;
3030 #endif
3031
3032 #if FFETARGET_okCOMPLEX7
3033 case FFEINFO_kindtypeREAL7:
3034 *aptr = array.complex7 + offset;
3035 break;
3036 #endif
3037
3038 #if FFETARGET_okCOMPLEX8
3039 case FFEINFO_kindtypeREAL8:
3040 *aptr = array.complex8 + offset;
3041 break;
3042 #endif
3043
3044 default:
3045 assert ("bad COMPLEX akindtype" == NULL);
3046 break;
3047 }
3048 break;
3049
3050 case FFEINFO_basictypeCHARACTER:
3051 switch (akt)
3052 {
3053 #if FFETARGET_okCHARACTER1
3054 case FFEINFO_kindtypeCHARACTER1:
3055 *aptr = array.character1 + offset;
3056 break;
3057 #endif
3058
3059 #if FFETARGET_okCHARACTER2
3060 case FFEINFO_kindtypeCHARACTER2:
3061 *aptr = array.character2 + offset;
3062 break;
3063 #endif
3064
3065 #if FFETARGET_okCHARACTER3
3066 case FFEINFO_kindtypeCHARACTER3:
3067 *aptr = array.character3 + offset;
3068 break;
3069 #endif
3070
3071 #if FFETARGET_okCHARACTER4
3072 case FFEINFO_kindtypeCHARACTER4:
3073 *aptr = array.character4 + offset;
3074 break;
3075 #endif
3076
3077 #if FFETARGET_okCHARACTER5
3078 case FFEINFO_kindtypeCHARACTER5:
3079 *aptr = array.character5 + offset;
3080 break;
3081 #endif
3082
3083 #if FFETARGET_okCHARACTER6
3084 case FFEINFO_kindtypeCHARACTER6:
3085 *aptr = array.character6 + offset;
3086 break;
3087 #endif
3088
3089 #if FFETARGET_okCHARACTER7
3090 case FFEINFO_kindtypeCHARACTER7:
3091 *aptr = array.character7 + offset;
3092 break;
3093 #endif
3094
3095 #if FFETARGET_okCHARACTER8
3096 case FFEINFO_kindtypeCHARACTER8:
3097 *aptr = array.character8 + offset;
3098 break;
3099 #endif
3100
3101 default:
3102 assert ("bad CHARACTER akindtype" == NULL);
3103 break;
3104 }
3105 break;
3106
3107 default:
3108 assert ("bad abasictype" == NULL);
3109 break;
3110 }
3111
3112 switch (cbt)
3113 {
3114 case FFEINFO_basictypeINTEGER:
3115 switch (ckt)
3116 {
3117 #if FFETARGET_okINTEGER1
3118 case FFEINFO_kindtypeINTEGER1:
3119 *cptr = source_array.integer1;
3120 *size = sizeof (*source_array.integer1);
3121 break;
3122 #endif
3123
3124 #if FFETARGET_okINTEGER2
3125 case FFEINFO_kindtypeINTEGER2:
3126 *cptr = source_array.integer2;
3127 *size = sizeof (*source_array.integer2);
3128 break;
3129 #endif
3130
3131 #if FFETARGET_okINTEGER3
3132 case FFEINFO_kindtypeINTEGER3:
3133 *cptr = source_array.integer3;
3134 *size = sizeof (*source_array.integer3);
3135 break;
3136 #endif
3137
3138 #if FFETARGET_okINTEGER4
3139 case FFEINFO_kindtypeINTEGER4:
3140 *cptr = source_array.integer4;
3141 *size = sizeof (*source_array.integer4);
3142 break;
3143 #endif
3144
3145 #if FFETARGET_okINTEGER5
3146 case FFEINFO_kindtypeINTEGER5:
3147 *cptr = source_array.integer5;
3148 *size = sizeof (*source_array.integer5);
3149 break;
3150 #endif
3151
3152 #if FFETARGET_okINTEGER6
3153 case FFEINFO_kindtypeINTEGER6:
3154 *cptr = source_array.integer6;
3155 *size = sizeof (*source_array.integer6);
3156 break;
3157 #endif
3158
3159 #if FFETARGET_okINTEGER7
3160 case FFEINFO_kindtypeINTEGER7:
3161 *cptr = source_array.integer7;
3162 *size = sizeof (*source_array.integer7);
3163 break;
3164 #endif
3165
3166 #if FFETARGET_okINTEGER8
3167 case FFEINFO_kindtypeINTEGER8:
3168 *cptr = source_array.integer8;
3169 *size = sizeof (*source_array.integer8);
3170 break;
3171 #endif
3172
3173 default:
3174 assert ("bad INTEGER ckindtype" == NULL);
3175 break;
3176 }
3177 break;
3178
3179 case FFEINFO_basictypeLOGICAL:
3180 switch (ckt)
3181 {
3182 #if FFETARGET_okLOGICAL1
3183 case FFEINFO_kindtypeLOGICAL1:
3184 *cptr = source_array.logical1;
3185 *size = sizeof (*source_array.logical1);
3186 break;
3187 #endif
3188
3189 #if FFETARGET_okLOGICAL2
3190 case FFEINFO_kindtypeLOGICAL2:
3191 *cptr = source_array.logical2;
3192 *size = sizeof (*source_array.logical2);
3193 break;
3194 #endif
3195
3196 #if FFETARGET_okLOGICAL3
3197 case FFEINFO_kindtypeLOGICAL3:
3198 *cptr = source_array.logical3;
3199 *size = sizeof (*source_array.logical3);
3200 break;
3201 #endif
3202
3203 #if FFETARGET_okLOGICAL4
3204 case FFEINFO_kindtypeLOGICAL4:
3205 *cptr = source_array.logical4;
3206 *size = sizeof (*source_array.logical4);
3207 break;
3208 #endif
3209
3210 #if FFETARGET_okLOGICAL5
3211 case FFEINFO_kindtypeLOGICAL5:
3212 *cptr = source_array.logical5;
3213 *size = sizeof (*source_array.logical5);
3214 break;
3215 #endif
3216
3217 #if FFETARGET_okLOGICAL6
3218 case FFEINFO_kindtypeLOGICAL6:
3219 *cptr = source_array.logical6;
3220 *size = sizeof (*source_array.logical6);
3221 break;
3222 #endif
3223
3224 #if FFETARGET_okLOGICAL7
3225 case FFEINFO_kindtypeLOGICAL7:
3226 *cptr = source_array.logical7;
3227 *size = sizeof (*source_array.logical7);
3228 break;
3229 #endif
3230
3231 #if FFETARGET_okLOGICAL8
3232 case FFEINFO_kindtypeLOGICAL8:
3233 *cptr = source_array.logical8;
3234 *size = sizeof (*source_array.logical8);
3235 break;
3236 #endif
3237
3238 default:
3239 assert ("bad LOGICAL ckindtype" == NULL);
3240 break;
3241 }
3242 break;
3243
3244 case FFEINFO_basictypeREAL:
3245 switch (ckt)
3246 {
3247 #if FFETARGET_okREAL1
3248 case FFEINFO_kindtypeREAL1:
3249 *cptr = source_array.real1;
3250 *size = sizeof (*source_array.real1);
3251 break;
3252 #endif
3253
3254 #if FFETARGET_okREAL2
3255 case FFEINFO_kindtypeREAL2:
3256 *cptr = source_array.real2;
3257 *size = sizeof (*source_array.real2);
3258 break;
3259 #endif
3260
3261 #if FFETARGET_okREAL3
3262 case FFEINFO_kindtypeREAL3:
3263 *cptr = source_array.real3;
3264 *size = sizeof (*source_array.real3);
3265 break;
3266 #endif
3267
3268 #if FFETARGET_okREAL4
3269 case FFEINFO_kindtypeREAL4:
3270 *cptr = source_array.real4;
3271 *size = sizeof (*source_array.real4);
3272 break;
3273 #endif
3274
3275 #if FFETARGET_okREAL5
3276 case FFEINFO_kindtypeREAL5:
3277 *cptr = source_array.real5;
3278 *size = sizeof (*source_array.real5);
3279 break;
3280 #endif
3281
3282 #if FFETARGET_okREAL6
3283 case FFEINFO_kindtypeREAL6:
3284 *cptr = source_array.real6;
3285 *size = sizeof (*source_array.real6);
3286 break;
3287 #endif
3288
3289 #if FFETARGET_okREAL7
3290 case FFEINFO_kindtypeREAL7:
3291 *cptr = source_array.real7;
3292 *size = sizeof (*source_array.real7);
3293 break;
3294 #endif
3295
3296 #if FFETARGET_okREAL8
3297 case FFEINFO_kindtypeREAL8:
3298 *cptr = source_array.real8;
3299 *size = sizeof (*source_array.real8);
3300 break;
3301 #endif
3302
3303 default:
3304 assert ("bad REAL ckindtype" == NULL);
3305 break;
3306 }
3307 break;
3308
3309 case FFEINFO_basictypeCOMPLEX:
3310 switch (ckt)
3311 {
3312 #if FFETARGET_okCOMPLEX1
3313 case FFEINFO_kindtypeREAL1:
3314 *cptr = source_array.complex1;
3315 *size = sizeof (*source_array.complex1);
3316 break;
3317 #endif
3318
3319 #if FFETARGET_okCOMPLEX2
3320 case FFEINFO_kindtypeREAL2:
3321 *cptr = source_array.complex2;
3322 *size = sizeof (*source_array.complex2);
3323 break;
3324 #endif
3325
3326 #if FFETARGET_okCOMPLEX3
3327 case FFEINFO_kindtypeREAL3:
3328 *cptr = source_array.complex3;
3329 *size = sizeof (*source_array.complex3);
3330 break;
3331 #endif
3332
3333 #if FFETARGET_okCOMPLEX4
3334 case FFEINFO_kindtypeREAL4:
3335 *cptr = source_array.complex4;
3336 *size = sizeof (*source_array.complex4);
3337 break;
3338 #endif
3339
3340 #if FFETARGET_okCOMPLEX5
3341 case FFEINFO_kindtypeREAL5:
3342 *cptr = source_array.complex5;
3343 *size = sizeof (*source_array.complex5);
3344 break;
3345 #endif
3346
3347 #if FFETARGET_okCOMPLEX6
3348 case FFEINFO_kindtypeREAL6:
3349 *cptr = source_array.complex6;
3350 *size = sizeof (*source_array.complex6);
3351 break;
3352 #endif
3353
3354 #if FFETARGET_okCOMPLEX7
3355 case FFEINFO_kindtypeREAL7:
3356 *cptr = source_array.complex7;
3357 *size = sizeof (*source_array.complex7);
3358 break;
3359 #endif
3360
3361 #if FFETARGET_okCOMPLEX8
3362 case FFEINFO_kindtypeREAL8:
3363 *cptr = source_array.complex8;
3364 *size = sizeof (*source_array.complex8);
3365 break;
3366 #endif
3367
3368 default:
3369 assert ("bad COMPLEX ckindtype" == NULL);
3370 break;
3371 }
3372 break;
3373
3374 case FFEINFO_basictypeCHARACTER:
3375 switch (ckt)
3376 {
3377 #if FFETARGET_okCHARACTER1
3378 case FFEINFO_kindtypeCHARACTER1:
3379 *cptr = source_array.character1;
3380 *size = sizeof (*source_array.character1);
3381 break;
3382 #endif
3383
3384 #if FFETARGET_okCHARACTER2
3385 case FFEINFO_kindtypeCHARACTER2:
3386 *cptr = source_array.character2;
3387 *size = sizeof (*source_array.character2);
3388 break;
3389 #endif
3390
3391 #if FFETARGET_okCHARACTER3
3392 case FFEINFO_kindtypeCHARACTER3:
3393 *cptr = source_array.character3;
3394 *size = sizeof (*source_array.character3);
3395 break;
3396 #endif
3397
3398 #if FFETARGET_okCHARACTER4
3399 case FFEINFO_kindtypeCHARACTER4:
3400 *cptr = source_array.character4;
3401 *size = sizeof (*source_array.character4);
3402 break;
3403 #endif
3404
3405 #if FFETARGET_okCHARACTER5
3406 case FFEINFO_kindtypeCHARACTER5:
3407 *cptr = source_array.character5;
3408 *size = sizeof (*source_array.character5);
3409 break;
3410 #endif
3411
3412 #if FFETARGET_okCHARACTER6
3413 case FFEINFO_kindtypeCHARACTER6:
3414 *cptr = source_array.character6;
3415 *size = sizeof (*source_array.character6);
3416 break;
3417 #endif
3418
3419 #if FFETARGET_okCHARACTER7
3420 case FFEINFO_kindtypeCHARACTER7:
3421 *cptr = source_array.character7;
3422 *size = sizeof (*source_array.character7);
3423 break;
3424 #endif
3425
3426 #if FFETARGET_okCHARACTER8
3427 case FFEINFO_kindtypeCHARACTER8:
3428 *cptr = source_array.character8;
3429 *size = sizeof (*source_array.character8);
3430 break;
3431 #endif
3432
3433 default:
3434 assert ("bad CHARACTER ckindtype" == NULL);
3435 break;
3436 }
3437 break;
3438
3439 default:
3440 assert ("bad cbasictype" == NULL);
3441 break;
3442 }
3443 }
3444
3445 /* ffebld_constantarray_prepare -- Prepare for copy between value and array
3446
3447 See prototype.
3448
3449 Like _put, but just returns the pointers to the beginnings of the
3450 array and the constant and returns the size (the amount of info to
3451 copy). The idea is that the caller can use memcpy to accomplish the
3452 same thing as _put (though slower), or the caller can use a different
3453 function that swaps bytes, words, etc for a different target machine.
3454 Also, the type of the array may be different from the type of the
3455 constant; the array type is used to determine the meaning (scale) of
3456 the offset field (to calculate the array pointer), the constant type is
3457 used to determine the constant pointer and the size (amount of info to
3458 copy). */
3459
3460 void
3461 ffebld_constantarray_prepare (void **aptr, void **cptr, size_t *size,
3462 ffebldConstantArray array, ffeinfoBasictype abt, ffeinfoKindtype akt,
3463 ffetargetOffset offset, ffebldConstantUnion *constant,
3464 ffeinfoBasictype cbt, ffeinfoKindtype ckt)
3465 {
3466 switch (abt)
3467 {
3468 case FFEINFO_basictypeINTEGER:
3469 switch (akt)
3470 {
3471 #if FFETARGET_okINTEGER1
3472 case FFEINFO_kindtypeINTEGER1:
3473 *aptr = array.integer1 + offset;
3474 break;
3475 #endif
3476
3477 #if FFETARGET_okINTEGER2
3478 case FFEINFO_kindtypeINTEGER2:
3479 *aptr = array.integer2 + offset;
3480 break;
3481 #endif
3482
3483 #if FFETARGET_okINTEGER3
3484 case FFEINFO_kindtypeINTEGER3:
3485 *aptr = array.integer3 + offset;
3486 break;
3487 #endif
3488
3489 #if FFETARGET_okINTEGER4
3490 case FFEINFO_kindtypeINTEGER4:
3491 *aptr = array.integer4 + offset;
3492 break;
3493 #endif
3494
3495 #if FFETARGET_okINTEGER5
3496 case FFEINFO_kindtypeINTEGER5:
3497 *aptr = array.integer5 + offset;
3498 break;
3499 #endif
3500
3501 #if FFETARGET_okINTEGER6
3502 case FFEINFO_kindtypeINTEGER6:
3503 *aptr = array.integer6 + offset;
3504 break;
3505 #endif
3506
3507 #if FFETARGET_okINTEGER7
3508 case FFEINFO_kindtypeINTEGER7:
3509 *aptr = array.integer7 + offset;
3510 break;
3511 #endif
3512
3513 #if FFETARGET_okINTEGER8
3514 case FFEINFO_kindtypeINTEGER8:
3515 *aptr = array.integer8 + offset;
3516 break;
3517 #endif
3518
3519 default:
3520 assert ("bad INTEGER akindtype" == NULL);
3521 break;
3522 }
3523 break;
3524
3525 case FFEINFO_basictypeLOGICAL:
3526 switch (akt)
3527 {
3528 #if FFETARGET_okLOGICAL1
3529 case FFEINFO_kindtypeLOGICAL1:
3530 *aptr = array.logical1 + offset;
3531 break;
3532 #endif
3533
3534 #if FFETARGET_okLOGICAL2
3535 case FFEINFO_kindtypeLOGICAL2:
3536 *aptr = array.logical2 + offset;
3537 break;
3538 #endif
3539
3540 #if FFETARGET_okLOGICAL3
3541 case FFEINFO_kindtypeLOGICAL3:
3542 *aptr = array.logical3 + offset;
3543 break;
3544 #endif
3545
3546 #if FFETARGET_okLOGICAL4
3547 case FFEINFO_kindtypeLOGICAL4:
3548 *aptr = array.logical4 + offset;
3549 break;
3550 #endif
3551
3552 #if FFETARGET_okLOGICAL5
3553 case FFEINFO_kindtypeLOGICAL5:
3554 *aptr = array.logical5 + offset;
3555 break;
3556 #endif
3557
3558 #if FFETARGET_okLOGICAL6
3559 case FFEINFO_kindtypeLOGICAL6:
3560 *aptr = array.logical6 + offset;
3561 break;
3562 #endif
3563
3564 #if FFETARGET_okLOGICAL7
3565 case FFEINFO_kindtypeLOGICAL7:
3566 *aptr = array.logical7 + offset;
3567 break;
3568 #endif
3569
3570 #if FFETARGET_okLOGICAL8
3571 case FFEINFO_kindtypeLOGICAL8:
3572 *aptr = array.logical8 + offset;
3573 break;
3574 #endif
3575
3576 default:
3577 assert ("bad LOGICAL akindtype" == NULL);
3578 break;
3579 }
3580 break;
3581
3582 case FFEINFO_basictypeREAL:
3583 switch (akt)
3584 {
3585 #if FFETARGET_okREAL1
3586 case FFEINFO_kindtypeREAL1:
3587 *aptr = array.real1 + offset;
3588 break;
3589 #endif
3590
3591 #if FFETARGET_okREAL2
3592 case FFEINFO_kindtypeREAL2:
3593 *aptr = array.real2 + offset;
3594 break;
3595 #endif
3596
3597 #if FFETARGET_okREAL3
3598 case FFEINFO_kindtypeREAL3:
3599 *aptr = array.real3 + offset;
3600 break;
3601 #endif
3602
3603 #if FFETARGET_okREAL4
3604 case FFEINFO_kindtypeREAL4:
3605 *aptr = array.real4 + offset;
3606 break;
3607 #endif
3608
3609 #if FFETARGET_okREAL5
3610 case FFEINFO_kindtypeREAL5:
3611 *aptr = array.real5 + offset;
3612 break;
3613 #endif
3614
3615 #if FFETARGET_okREAL6
3616 case FFEINFO_kindtypeREAL6:
3617 *aptr = array.real6 + offset;
3618 break;
3619 #endif
3620
3621 #if FFETARGET_okREAL7
3622 case FFEINFO_kindtypeREAL7:
3623 *aptr = array.real7 + offset;
3624 break;
3625 #endif
3626
3627 #if FFETARGET_okREAL8
3628 case FFEINFO_kindtypeREAL8:
3629 *aptr = array.real8 + offset;
3630 break;
3631 #endif
3632
3633 default:
3634 assert ("bad REAL akindtype" == NULL);
3635 break;
3636 }
3637 break;
3638
3639 case FFEINFO_basictypeCOMPLEX:
3640 switch (akt)
3641 {
3642 #if FFETARGET_okCOMPLEX1
3643 case FFEINFO_kindtypeREAL1:
3644 *aptr = array.complex1 + offset;
3645 break;
3646 #endif
3647
3648 #if FFETARGET_okCOMPLEX2
3649 case FFEINFO_kindtypeREAL2:
3650 *aptr = array.complex2 + offset;
3651 break;
3652 #endif
3653
3654 #if FFETARGET_okCOMPLEX3
3655 case FFEINFO_kindtypeREAL3:
3656 *aptr = array.complex3 + offset;
3657 break;
3658 #endif
3659
3660 #if FFETARGET_okCOMPLEX4
3661 case FFEINFO_kindtypeREAL4:
3662 *aptr = array.complex4 + offset;
3663 break;
3664 #endif
3665
3666 #if FFETARGET_okCOMPLEX5
3667 case FFEINFO_kindtypeREAL5:
3668 *aptr = array.complex5 + offset;
3669 break;
3670 #endif
3671
3672 #if FFETARGET_okCOMPLEX6
3673 case FFEINFO_kindtypeREAL6:
3674 *aptr = array.complex6 + offset;
3675 break;
3676 #endif
3677
3678 #if FFETARGET_okCOMPLEX7
3679 case FFEINFO_kindtypeREAL7:
3680 *aptr = array.complex7 + offset;
3681 break;
3682 #endif
3683
3684 #if FFETARGET_okCOMPLEX8
3685 case FFEINFO_kindtypeREAL8:
3686 *aptr = array.complex8 + offset;
3687 break;
3688 #endif
3689
3690 default:
3691 assert ("bad COMPLEX akindtype" == NULL);
3692 break;
3693 }
3694 break;
3695
3696 case FFEINFO_basictypeCHARACTER:
3697 switch (akt)
3698 {
3699 #if FFETARGET_okCHARACTER1
3700 case FFEINFO_kindtypeCHARACTER1:
3701 *aptr = array.character1 + offset;
3702 break;
3703 #endif
3704
3705 #if FFETARGET_okCHARACTER2
3706 case FFEINFO_kindtypeCHARACTER2:
3707 *aptr = array.character2 + offset;
3708 break;
3709 #endif
3710
3711 #if FFETARGET_okCHARACTER3
3712 case FFEINFO_kindtypeCHARACTER3:
3713 *aptr = array.character3 + offset;
3714 break;
3715 #endif
3716
3717 #if FFETARGET_okCHARACTER4
3718 case FFEINFO_kindtypeCHARACTER4:
3719 *aptr = array.character4 + offset;
3720 break;
3721 #endif
3722
3723 #if FFETARGET_okCHARACTER5
3724 case FFEINFO_kindtypeCHARACTER5:
3725 *aptr = array.character5 + offset;
3726 break;
3727 #endif
3728
3729 #if FFETARGET_okCHARACTER6
3730 case FFEINFO_kindtypeCHARACTER6:
3731 *aptr = array.character6 + offset;
3732 break;
3733 #endif
3734
3735 #if FFETARGET_okCHARACTER7
3736 case FFEINFO_kindtypeCHARACTER7:
3737 *aptr = array.character7 + offset;
3738 break;
3739 #endif
3740
3741 #if FFETARGET_okCHARACTER8
3742 case FFEINFO_kindtypeCHARACTER8:
3743 *aptr = array.character8 + offset;
3744 break;
3745 #endif
3746
3747 default:
3748 assert ("bad CHARACTER akindtype" == NULL);
3749 break;
3750 }
3751 break;
3752
3753 default:
3754 assert ("bad abasictype" == NULL);
3755 break;
3756 }
3757
3758 switch (cbt)
3759 {
3760 case FFEINFO_basictypeINTEGER:
3761 switch (ckt)
3762 {
3763 #if FFETARGET_okINTEGER1
3764 case FFEINFO_kindtypeINTEGER1:
3765 *cptr = &constant->integer1;
3766 *size = sizeof (constant->integer1);
3767 break;
3768 #endif
3769
3770 #if FFETARGET_okINTEGER2
3771 case FFEINFO_kindtypeINTEGER2:
3772 *cptr = &constant->integer2;
3773 *size = sizeof (constant->integer2);
3774 break;
3775 #endif
3776
3777 #if FFETARGET_okINTEGER3
3778 case FFEINFO_kindtypeINTEGER3:
3779 *cptr = &constant->integer3;
3780 *size = sizeof (constant->integer3);
3781 break;
3782 #endif
3783
3784 #if FFETARGET_okINTEGER4
3785 case FFEINFO_kindtypeINTEGER4:
3786 *cptr = &constant->integer4;
3787 *size = sizeof (constant->integer4);
3788 break;
3789 #endif
3790
3791 #if FFETARGET_okINTEGER5
3792 case FFEINFO_kindtypeINTEGER5:
3793 *cptr = &constant->integer5;
3794 *size = sizeof (constant->integer5);
3795 break;
3796 #endif
3797
3798 #if FFETARGET_okINTEGER6
3799 case FFEINFO_kindtypeINTEGER6:
3800 *cptr = &constant->integer6;
3801 *size = sizeof (constant->integer6);
3802 break;
3803 #endif
3804
3805 #if FFETARGET_okINTEGER7
3806 case FFEINFO_kindtypeINTEGER7:
3807 *cptr = &constant->integer7;
3808 *size = sizeof (constant->integer7);
3809 break;
3810 #endif
3811
3812 #if FFETARGET_okINTEGER8
3813 case FFEINFO_kindtypeINTEGER8:
3814 *cptr = &constant->integer8;
3815 *size = sizeof (constant->integer8);
3816 break;
3817 #endif
3818
3819 default:
3820 assert ("bad INTEGER ckindtype" == NULL);
3821 break;
3822 }
3823 break;
3824
3825 case FFEINFO_basictypeLOGICAL:
3826 switch (ckt)
3827 {
3828 #if FFETARGET_okLOGICAL1
3829 case FFEINFO_kindtypeLOGICAL1:
3830 *cptr = &constant->logical1;
3831 *size = sizeof (constant->logical1);
3832 break;
3833 #endif
3834
3835 #if FFETARGET_okLOGICAL2
3836 case FFEINFO_kindtypeLOGICAL2:
3837 *cptr = &constant->logical2;
3838 *size = sizeof (constant->logical2);
3839 break;
3840 #endif
3841
3842 #if FFETARGET_okLOGICAL3
3843 case FFEINFO_kindtypeLOGICAL3:
3844 *cptr = &constant->logical3;
3845 *size = sizeof (constant->logical3);
3846 break;
3847 #endif
3848
3849 #if FFETARGET_okLOGICAL4
3850 case FFEINFO_kindtypeLOGICAL4:
3851 *cptr = &constant->logical4;
3852 *size = sizeof (constant->logical4);
3853 break;
3854 #endif
3855
3856 #if FFETARGET_okLOGICAL5
3857 case FFEINFO_kindtypeLOGICAL5:
3858 *cptr = &constant->logical5;
3859 *size = sizeof (constant->logical5);
3860 break;
3861 #endif
3862
3863 #if FFETARGET_okLOGICAL6
3864 case FFEINFO_kindtypeLOGICAL6:
3865 *cptr = &constant->logical6;
3866 *size = sizeof (constant->logical6);
3867 break;
3868 #endif
3869
3870 #if FFETARGET_okLOGICAL7
3871 case FFEINFO_kindtypeLOGICAL7:
3872 *cptr = &constant->logical7;
3873 *size = sizeof (constant->logical7);
3874 break;
3875 #endif
3876
3877 #if FFETARGET_okLOGICAL8
3878 case FFEINFO_kindtypeLOGICAL8:
3879 *cptr = &constant->logical8;
3880 *size = sizeof (constant->logical8);
3881 break;
3882 #endif
3883
3884 default:
3885 assert ("bad LOGICAL ckindtype" == NULL);
3886 break;
3887 }
3888 break;
3889
3890 case FFEINFO_basictypeREAL:
3891 switch (ckt)
3892 {
3893 #if FFETARGET_okREAL1
3894 case FFEINFO_kindtypeREAL1:
3895 *cptr = &constant->real1;
3896 *size = sizeof (constant->real1);
3897 break;
3898 #endif
3899
3900 #if FFETARGET_okREAL2
3901 case FFEINFO_kindtypeREAL2:
3902 *cptr = &constant->real2;
3903 *size = sizeof (constant->real2);
3904 break;
3905 #endif
3906
3907 #if FFETARGET_okREAL3
3908 case FFEINFO_kindtypeREAL3:
3909 *cptr = &constant->real3;
3910 *size = sizeof (constant->real3);
3911 break;
3912 #endif
3913
3914 #if FFETARGET_okREAL4
3915 case FFEINFO_kindtypeREAL4:
3916 *cptr = &constant->real4;
3917 *size = sizeof (constant->real4);
3918 break;
3919 #endif
3920
3921 #if FFETARGET_okREAL5
3922 case FFEINFO_kindtypeREAL5:
3923 *cptr = &constant->real5;
3924 *size = sizeof (constant->real5);
3925 break;
3926 #endif
3927
3928 #if FFETARGET_okREAL6
3929 case FFEINFO_kindtypeREAL6:
3930 *cptr = &constant->real6;
3931 *size = sizeof (constant->real6);
3932 break;
3933 #endif
3934
3935 #if FFETARGET_okREAL7
3936 case FFEINFO_kindtypeREAL7:
3937 *cptr = &constant->real7;
3938 *size = sizeof (constant->real7);
3939 break;
3940 #endif
3941
3942 #if FFETARGET_okREAL8
3943 case FFEINFO_kindtypeREAL8:
3944 *cptr = &constant->real8;
3945 *size = sizeof (constant->real8);
3946 break;
3947 #endif
3948
3949 default:
3950 assert ("bad REAL ckindtype" == NULL);
3951 break;
3952 }
3953 break;
3954
3955 case FFEINFO_basictypeCOMPLEX:
3956 switch (ckt)
3957 {
3958 #if FFETARGET_okCOMPLEX1
3959 case FFEINFO_kindtypeREAL1:
3960 *cptr = &constant->complex1;
3961 *size = sizeof (constant->complex1);
3962 break;
3963 #endif
3964
3965 #if FFETARGET_okCOMPLEX2
3966 case FFEINFO_kindtypeREAL2:
3967 *cptr = &constant->complex2;
3968 *size = sizeof (constant->complex2);
3969 break;
3970 #endif
3971
3972 #if FFETARGET_okCOMPLEX3
3973 case FFEINFO_kindtypeREAL3:
3974 *cptr = &constant->complex3;
3975 *size = sizeof (constant->complex3);
3976 break;
3977 #endif
3978
3979 #if FFETARGET_okCOMPLEX4
3980 case FFEINFO_kindtypeREAL4:
3981 *cptr = &constant->complex4;
3982 *size = sizeof (constant->complex4);
3983 break;
3984 #endif
3985
3986 #if FFETARGET_okCOMPLEX5
3987 case FFEINFO_kindtypeREAL5:
3988 *cptr = &constant->complex5;
3989 *size = sizeof (constant->complex5);
3990 break;
3991 #endif
3992
3993 #if FFETARGET_okCOMPLEX6
3994 case FFEINFO_kindtypeREAL6:
3995 *cptr = &constant->complex6;
3996 *size = sizeof (constant->complex6);
3997 break;
3998 #endif
3999
4000 #if FFETARGET_okCOMPLEX7
4001 case FFEINFO_kindtypeREAL7:
4002 *cptr = &constant->complex7;
4003 *size = sizeof (constant->complex7);
4004 break;
4005 #endif
4006
4007 #if FFETARGET_okCOMPLEX8
4008 case FFEINFO_kindtypeREAL8:
4009 *cptr = &constant->complex8;
4010 *size = sizeof (constant->complex8);
4011 break;
4012 #endif
4013
4014 default:
4015 assert ("bad COMPLEX ckindtype" == NULL);
4016 break;
4017 }
4018 break;
4019
4020 case FFEINFO_basictypeCHARACTER:
4021 switch (ckt)
4022 {
4023 #if FFETARGET_okCHARACTER1
4024 case FFEINFO_kindtypeCHARACTER1:
4025 *cptr = ffetarget_text_character1 (constant->character1);
4026 *size = ffetarget_length_character1 (constant->character1);
4027 break;
4028 #endif
4029
4030 #if FFETARGET_okCHARACTER2
4031 case FFEINFO_kindtypeCHARACTER2:
4032 *cptr = ffetarget_text_character2 (constant->character2);
4033 *size = ffetarget_length_character2 (constant->character2);
4034 break;
4035 #endif
4036
4037 #if FFETARGET_okCHARACTER3
4038 case FFEINFO_kindtypeCHARACTER3:
4039 *cptr = ffetarget_text_character3 (constant->character3);
4040 *size = ffetarget_length_character3 (constant->character3);
4041 break;
4042 #endif
4043
4044 #if FFETARGET_okCHARACTER4
4045 case FFEINFO_kindtypeCHARACTER4:
4046 *cptr = ffetarget_text_character4 (constant->character4);
4047 *size = ffetarget_length_character4 (constant->character4);
4048 break;
4049 #endif
4050
4051 #if FFETARGET_okCHARACTER5
4052 case FFEINFO_kindtypeCHARACTER5:
4053 *cptr = ffetarget_text_character5 (constant->character5);
4054 *size = ffetarget_length_character5 (constant->character5);
4055 break;
4056 #endif
4057
4058 #if FFETARGET_okCHARACTER6
4059 case FFEINFO_kindtypeCHARACTER6:
4060 *cptr = ffetarget_text_character6 (constant->character6);
4061 *size = ffetarget_length_character6 (constant->character6);
4062 break;
4063 #endif
4064
4065 #if FFETARGET_okCHARACTER7
4066 case FFEINFO_kindtypeCHARACTER7:
4067 *cptr = ffetarget_text_character7 (constant->character7);
4068 *size = ffetarget_length_character7 (constant->character7);
4069 break;
4070 #endif
4071
4072 #if FFETARGET_okCHARACTER8
4073 case FFEINFO_kindtypeCHARACTER8:
4074 *cptr = ffetarget_text_character8 (constant->character8);
4075 *size = ffetarget_length_character8 (constant->character8);
4076 break;
4077 #endif
4078
4079 default:
4080 assert ("bad CHARACTER ckindtype" == NULL);
4081 break;
4082 }
4083 break;
4084
4085 default:
4086 assert ("bad cbasictype" == NULL);
4087 break;
4088 }
4089 }
4090
4091 /* ffebld_constantarray_put -- Put a value into an array of constants
4092
4093 See prototype. */
4094
4095 void
4096 ffebld_constantarray_put (ffebldConstantArray array, ffeinfoBasictype bt,
4097 ffeinfoKindtype kt, ffetargetOffset offset, ffebldConstantUnion constant)
4098 {
4099 switch (bt)
4100 {
4101 case FFEINFO_basictypeINTEGER:
4102 switch (kt)
4103 {
4104 #if FFETARGET_okINTEGER1
4105 case FFEINFO_kindtypeINTEGER1:
4106 *(array.integer1 + offset) = constant.integer1;
4107 break;
4108 #endif
4109
4110 #if FFETARGET_okINTEGER2
4111 case FFEINFO_kindtypeINTEGER2:
4112 *(array.integer2 + offset) = constant.integer2;
4113 break;
4114 #endif
4115
4116 #if FFETARGET_okINTEGER3
4117 case FFEINFO_kindtypeINTEGER3:
4118 *(array.integer3 + offset) = constant.integer3;
4119 break;
4120 #endif
4121
4122 #if FFETARGET_okINTEGER4
4123 case FFEINFO_kindtypeINTEGER4:
4124 *(array.integer4 + offset) = constant.integer4;
4125 break;
4126 #endif
4127
4128 #if FFETARGET_okINTEGER5
4129 case FFEINFO_kindtypeINTEGER5:
4130 *(array.integer5 + offset) = constant.integer5;
4131 break;
4132 #endif
4133
4134 #if FFETARGET_okINTEGER6
4135 case FFEINFO_kindtypeINTEGER6:
4136 *(array.integer6 + offset) = constant.integer6;
4137 break;
4138 #endif
4139
4140 #if FFETARGET_okINTEGER7
4141 case FFEINFO_kindtypeINTEGER7:
4142 *(array.integer7 + offset) = constant.integer7;
4143 break;
4144 #endif
4145
4146 #if FFETARGET_okINTEGER8
4147 case FFEINFO_kindtypeINTEGER8:
4148 *(array.integer8 + offset) = constant.integer8;
4149 break;
4150 #endif
4151
4152 default:
4153 assert ("bad INTEGER kindtype" == NULL);
4154 break;
4155 }
4156 break;
4157
4158 case FFEINFO_basictypeLOGICAL:
4159 switch (kt)
4160 {
4161 #if FFETARGET_okLOGICAL1
4162 case FFEINFO_kindtypeLOGICAL1:
4163 *(array.logical1 + offset) = constant.logical1;
4164 break;
4165 #endif
4166
4167 #if FFETARGET_okLOGICAL2
4168 case FFEINFO_kindtypeLOGICAL2:
4169 *(array.logical2 + offset) = constant.logical2;
4170 break;
4171 #endif
4172
4173 #if FFETARGET_okLOGICAL3
4174 case FFEINFO_kindtypeLOGICAL3:
4175 *(array.logical3 + offset) = constant.logical3;
4176 break;
4177 #endif
4178
4179 #if FFETARGET_okLOGICAL4
4180 case FFEINFO_kindtypeLOGICAL4:
4181 *(array.logical4 + offset) = constant.logical4;
4182 break;
4183 #endif
4184
4185 #if FFETARGET_okLOGICAL5
4186 case FFEINFO_kindtypeLOGICAL5:
4187 *(array.logical5 + offset) = constant.logical5;
4188 break;
4189 #endif
4190
4191 #if FFETARGET_okLOGICAL6
4192 case FFEINFO_kindtypeLOGICAL6:
4193 *(array.logical6 + offset) = constant.logical6;
4194 break;
4195 #endif
4196
4197 #if FFETARGET_okLOGICAL7
4198 case FFEINFO_kindtypeLOGICAL7:
4199 *(array.logical7 + offset) = constant.logical7;
4200 break;
4201 #endif
4202
4203 #if FFETARGET_okLOGICAL8
4204 case FFEINFO_kindtypeLOGICAL8:
4205 *(array.logical8 + offset) = constant.logical8;
4206 break;
4207 #endif
4208
4209 default:
4210 assert ("bad LOGICAL kindtype" == NULL);
4211 break;
4212 }
4213 break;
4214
4215 case FFEINFO_basictypeREAL:
4216 switch (kt)
4217 {
4218 #if FFETARGET_okREAL1
4219 case FFEINFO_kindtypeREAL1:
4220 *(array.real1 + offset) = constant.real1;
4221 break;
4222 #endif
4223
4224 #if FFETARGET_okREAL2
4225 case FFEINFO_kindtypeREAL2:
4226 *(array.real2 + offset) = constant.real2;
4227 break;
4228 #endif
4229
4230 #if FFETARGET_okREAL3
4231 case FFEINFO_kindtypeREAL3:
4232 *(array.real3 + offset) = constant.real3;
4233 break;
4234 #endif
4235
4236 #if FFETARGET_okREAL4
4237 case FFEINFO_kindtypeREAL4:
4238 *(array.real4 + offset) = constant.real4;
4239 break;
4240 #endif
4241
4242 #if FFETARGET_okREAL5
4243 case FFEINFO_kindtypeREAL5:
4244 *(array.real5 + offset) = constant.real5;
4245 break;
4246 #endif
4247
4248 #if FFETARGET_okREAL6
4249 case FFEINFO_kindtypeREAL6:
4250 *(array.real6 + offset) = constant.real6;
4251 break;
4252 #endif
4253
4254 #if FFETARGET_okREAL7
4255 case FFEINFO_kindtypeREAL7:
4256 *(array.real7 + offset) = constant.real7;
4257 break;
4258 #endif
4259
4260 #if FFETARGET_okREAL8
4261 case FFEINFO_kindtypeREAL8:
4262 *(array.real8 + offset) = constant.real8;
4263 break;
4264 #endif
4265
4266 default:
4267 assert ("bad REAL kindtype" == NULL);
4268 break;
4269 }
4270 break;
4271
4272 case FFEINFO_basictypeCOMPLEX:
4273 switch (kt)
4274 {
4275 #if FFETARGET_okCOMPLEX1
4276 case FFEINFO_kindtypeREAL1:
4277 *(array.complex1 + offset) = constant.complex1;
4278 break;
4279 #endif
4280
4281 #if FFETARGET_okCOMPLEX2
4282 case FFEINFO_kindtypeREAL2:
4283 *(array.complex2 + offset) = constant.complex2;
4284 break;
4285 #endif
4286
4287 #if FFETARGET_okCOMPLEX3
4288 case FFEINFO_kindtypeREAL3:
4289 *(array.complex3 + offset) = constant.complex3;
4290 break;
4291 #endif
4292
4293 #if FFETARGET_okCOMPLEX4
4294 case FFEINFO_kindtypeREAL4:
4295 *(array.complex4 + offset) = constant.complex4;
4296 break;
4297 #endif
4298
4299 #if FFETARGET_okCOMPLEX5
4300 case FFEINFO_kindtypeREAL5:
4301 *(array.complex5 + offset) = constant.complex5;
4302 break;
4303 #endif
4304
4305 #if FFETARGET_okCOMPLEX6
4306 case FFEINFO_kindtypeREAL6:
4307 *(array.complex6 + offset) = constant.complex6;
4308 break;
4309 #endif
4310
4311 #if FFETARGET_okCOMPLEX7
4312 case FFEINFO_kindtypeREAL7:
4313 *(array.complex7 + offset) = constant.complex7;
4314 break;
4315 #endif
4316
4317 #if FFETARGET_okCOMPLEX8
4318 case FFEINFO_kindtypeREAL8:
4319 *(array.complex8 + offset) = constant.complex8;
4320 break;
4321 #endif
4322
4323 default:
4324 assert ("bad COMPLEX kindtype" == NULL);
4325 break;
4326 }
4327 break;
4328
4329 case FFEINFO_basictypeCHARACTER:
4330 switch (kt)
4331 {
4332 #if FFETARGET_okCHARACTER1
4333 case FFEINFO_kindtypeCHARACTER1:
4334 memcpy (array.character1 + offset,
4335 ffetarget_text_character1 (constant.character1),
4336 ffetarget_length_character1 (constant.character1));
4337 break;
4338 #endif
4339
4340 #if FFETARGET_okCHARACTER2
4341 case FFEINFO_kindtypeCHARACTER2:
4342 memcpy (array.character2 + offset,
4343 ffetarget_text_character2 (constant.character2),
4344 ffetarget_length_character2 (constant.character2));
4345 break;
4346 #endif
4347
4348 #if FFETARGET_okCHARACTER3
4349 case FFEINFO_kindtypeCHARACTER3:
4350 memcpy (array.character3 + offset,
4351 ffetarget_text_character3 (constant.character3),
4352 ffetarget_length_character3 (constant.character3));
4353 break;
4354 #endif
4355
4356 #if FFETARGET_okCHARACTER4
4357 case FFEINFO_kindtypeCHARACTER4:
4358 memcpy (array.character4 + offset,
4359 ffetarget_text_character4 (constant.character4),
4360 ffetarget_length_character4 (constant.character4));
4361 break;
4362 #endif
4363
4364 #if FFETARGET_okCHARACTER5
4365 case FFEINFO_kindtypeCHARACTER5:
4366 memcpy (array.character5 + offset,
4367 ffetarget_text_character5 (constant.character5),
4368 ffetarget_length_character5 (constant.character5));
4369 break;
4370 #endif
4371
4372 #if FFETARGET_okCHARACTER6
4373 case FFEINFO_kindtypeCHARACTER6:
4374 memcpy (array.character6 + offset,
4375 ffetarget_text_character6 (constant.character6),
4376 ffetarget_length_character6 (constant.character6));
4377 break;
4378 #endif
4379
4380 #if FFETARGET_okCHARACTER7
4381 case FFEINFO_kindtypeCHARACTER7:
4382 memcpy (array.character7 + offset,
4383 ffetarget_text_character7 (constant.character7),
4384 ffetarget_length_character7 (constant.character7));
4385 break;
4386 #endif
4387
4388 #if FFETARGET_okCHARACTER8
4389 case FFEINFO_kindtypeCHARACTER8:
4390 memcpy (array.character8 + offset,
4391 ffetarget_text_character8 (constant.character8),
4392 ffetarget_length_character8 (constant.character8));
4393 break;
4394 #endif
4395
4396 default:
4397 assert ("bad CHARACTER kindtype" == NULL);
4398 break;
4399 }
4400 break;
4401
4402 default:
4403 assert ("bad basictype" == NULL);
4404 break;
4405 }
4406 }
4407
4408 /* ffebld_constantunion_dump -- Dump a constant
4409
4410 See prototype. */
4411
4412 void
4413 ffebld_constantunion_dump (ffebldConstantUnion u, ffeinfoBasictype bt,
4414 ffeinfoKindtype kt)
4415 {
4416 switch (bt)
4417 {
4418 case FFEINFO_basictypeINTEGER:
4419 switch (kt)
4420 {
4421 #if FFETARGET_okINTEGER1
4422 case FFEINFO_kindtypeINTEGER1:
4423 ffetarget_print_integer1 (dmpout, u.integer1);
4424 break;
4425 #endif
4426
4427 #if FFETARGET_okINTEGER2
4428 case FFEINFO_kindtypeINTEGER2:
4429 ffetarget_print_integer2 (dmpout, u.integer2);
4430 break;
4431 #endif
4432
4433 #if FFETARGET_okINTEGER3
4434 case FFEINFO_kindtypeINTEGER3:
4435 ffetarget_print_integer3 (dmpout, u.integer3);
4436 break;
4437 #endif
4438
4439 #if FFETARGET_okINTEGER4
4440 case FFEINFO_kindtypeINTEGER4:
4441 ffetarget_print_integer4 (dmpout, u.integer4);
4442 break;
4443 #endif
4444
4445 #if FFETARGET_okINTEGER5
4446 case FFEINFO_kindtypeINTEGER5:
4447 ffetarget_print_integer5 (dmpout, u.integer5);
4448 break;
4449 #endif
4450
4451 #if FFETARGET_okINTEGER6
4452 case FFEINFO_kindtypeINTEGER6:
4453 ffetarget_print_integer6 (dmpout, u.integer6);
4454 break;
4455 #endif
4456
4457 #if FFETARGET_okINTEGER7
4458 case FFEINFO_kindtypeINTEGER7:
4459 ffetarget_print_integer7 (dmpout, u.integer7);
4460 break;
4461 #endif
4462
4463 #if FFETARGET_okINTEGER8
4464 case FFEINFO_kindtypeINTEGER8:
4465 ffetarget_print_integer8 (dmpout, u.integer8);
4466 break;
4467 #endif
4468
4469 default:
4470 assert ("bad INTEGER kindtype" == NULL);
4471 break;
4472 }
4473 break;
4474
4475 case FFEINFO_basictypeLOGICAL:
4476 switch (kt)
4477 {
4478 #if FFETARGET_okLOGICAL1
4479 case FFEINFO_kindtypeLOGICAL1:
4480 ffetarget_print_logical1 (dmpout, u.logical1);
4481 break;
4482 #endif
4483
4484 #if FFETARGET_okLOGICAL2
4485 case FFEINFO_kindtypeLOGICAL2:
4486 ffetarget_print_logical2 (dmpout, u.logical2);
4487 break;
4488 #endif
4489
4490 #if FFETARGET_okLOGICAL3
4491 case FFEINFO_kindtypeLOGICAL3:
4492 ffetarget_print_logical3 (dmpout, u.logical3);
4493 break;
4494 #endif
4495
4496 #if FFETARGET_okLOGICAL4
4497 case FFEINFO_kindtypeLOGICAL4:
4498 ffetarget_print_logical4 (dmpout, u.logical4);
4499 break;
4500 #endif
4501
4502 #if FFETARGET_okLOGICAL5
4503 case FFEINFO_kindtypeLOGICAL5:
4504 ffetarget_print_logical5 (dmpout, u.logical5);
4505 break;
4506 #endif
4507
4508 #if FFETARGET_okLOGICAL6
4509 case FFEINFO_kindtypeLOGICAL6:
4510 ffetarget_print_logical6 (dmpout, u.logical6);
4511 break;
4512 #endif
4513
4514 #if FFETARGET_okLOGICAL7
4515 case FFEINFO_kindtypeLOGICAL7:
4516 ffetarget_print_logical7 (dmpout, u.logical7);
4517 break;
4518 #endif
4519
4520 #if FFETARGET_okLOGICAL8
4521 case FFEINFO_kindtypeLOGICAL8:
4522 ffetarget_print_logical8 (dmpout, u.logical8);
4523 break;
4524 #endif
4525
4526 default:
4527 assert ("bad LOGICAL kindtype" == NULL);
4528 break;
4529 }
4530 break;
4531
4532 case FFEINFO_basictypeREAL:
4533 switch (kt)
4534 {
4535 #if FFETARGET_okREAL1
4536 case FFEINFO_kindtypeREAL1:
4537 ffetarget_print_real1 (dmpout, u.real1);
4538 break;
4539 #endif
4540
4541 #if FFETARGET_okREAL2
4542 case FFEINFO_kindtypeREAL2:
4543 ffetarget_print_real2 (dmpout, u.real2);
4544 break;
4545 #endif
4546
4547 #if FFETARGET_okREAL3
4548 case FFEINFO_kindtypeREAL3:
4549 ffetarget_print_real3 (dmpout, u.real3);
4550 break;
4551 #endif
4552
4553 #if FFETARGET_okREAL4
4554 case FFEINFO_kindtypeREAL4:
4555 ffetarget_print_real4 (dmpout, u.real4);
4556 break;
4557 #endif
4558
4559 #if FFETARGET_okREAL5
4560 case FFEINFO_kindtypeREAL5:
4561 ffetarget_print_real5 (dmpout, u.real5);
4562 break;
4563 #endif
4564
4565 #if FFETARGET_okREAL6
4566 case FFEINFO_kindtypeREAL6:
4567 ffetarget_print_real6 (dmpout, u.real6);
4568 break;
4569 #endif
4570
4571 #if FFETARGET_okREAL7
4572 case FFEINFO_kindtypeREAL7:
4573 ffetarget_print_real7 (dmpout, u.real7);
4574 break;
4575 #endif
4576
4577 #if FFETARGET_okREAL8
4578 case FFEINFO_kindtypeREAL8:
4579 ffetarget_print_real8 (dmpout, u.real8);
4580 break;
4581 #endif
4582
4583 default:
4584 assert ("bad REAL kindtype" == NULL);
4585 break;
4586 }
4587 break;
4588
4589 case FFEINFO_basictypeCOMPLEX:
4590 switch (kt)
4591 {
4592 #if FFETARGET_okCOMPLEX1
4593 case FFEINFO_kindtypeREAL1:
4594 fprintf (dmpout, "(");
4595 ffetarget_print_real1 (dmpout, u.complex1.real);
4596 fprintf (dmpout, ",");
4597 ffetarget_print_real1 (dmpout, u.complex1.imaginary);
4598 fprintf (dmpout, ")");
4599 break;
4600 #endif
4601
4602 #if FFETARGET_okCOMPLEX2
4603 case FFEINFO_kindtypeREAL2:
4604 fprintf (dmpout, "(");
4605 ffetarget_print_real2 (dmpout, u.complex2.real);
4606 fprintf (dmpout, ",");
4607 ffetarget_print_real2 (dmpout, u.complex2.imaginary);
4608 fprintf (dmpout, ")");
4609 break;
4610 #endif
4611
4612 #if FFETARGET_okCOMPLEX3
4613 case FFEINFO_kindtypeREAL3:
4614 fprintf (dmpout, "(");
4615 ffetarget_print_real3 (dmpout, u.complex3.real);
4616 fprintf (dmpout, ",");
4617 ffetarget_print_real3 (dmpout, u.complex3.imaginary);
4618 fprintf (dmpout, ")");
4619 break;
4620 #endif
4621
4622 #if FFETARGET_okCOMPLEX4
4623 case FFEINFO_kindtypeREAL4:
4624 fprintf (dmpout, "(");
4625 ffetarget_print_real4 (dmpout, u.complex4.real);
4626 fprintf (dmpout, ",");
4627 ffetarget_print_real4 (dmpout, u.complex4.imaginary);
4628 fprintf (dmpout, ")");
4629 break;
4630 #endif
4631
4632 #if FFETARGET_okCOMPLEX5
4633 case FFEINFO_kindtypeREAL5:
4634 fprintf (dmpout, "(");
4635 ffetarget_print_real5 (dmpout, u.complex5.real);
4636 fprintf (dmpout, ",");
4637 ffetarget_print_real5 (dmpout, u.complex5.imaginary);
4638 fprintf (dmpout, ")");
4639 break;
4640 #endif
4641
4642 #if FFETARGET_okCOMPLEX6
4643 case FFEINFO_kindtypeREAL6:
4644 fprintf (dmpout, "(");
4645 ffetarget_print_real6 (dmpout, u.complex6.real);
4646 fprintf (dmpout, ",");
4647 ffetarget_print_real6 (dmpout, u.complex6.imaginary);
4648 fprintf (dmpout, ")");
4649 break;
4650 #endif
4651
4652 #if FFETARGET_okCOMPLEX7
4653 case FFEINFO_kindtypeREAL7:
4654 fprintf (dmpout, "(");
4655 ffetarget_print_real7 (dmpout, u.complex7.real);
4656 fprintf (dmpout, ",");
4657 ffetarget_print_real7 (dmpout, u.complex7.imaginary);
4658 fprintf (dmpout, ")");
4659 break;
4660 #endif
4661
4662 #if FFETARGET_okCOMPLEX8
4663 case FFEINFO_kindtypeREAL8:
4664 fprintf (dmpout, "(");
4665 ffetarget_print_real8 (dmpout, u.complex8.real);
4666 fprintf (dmpout, ",");
4667 ffetarget_print_real8 (dmpout, u.complex8.imaginary);
4668 fprintf (dmpout, ")");
4669 break;
4670 #endif
4671
4672 default:
4673 assert ("bad COMPLEX kindtype" == NULL);
4674 break;
4675 }
4676 break;
4677
4678 case FFEINFO_basictypeCHARACTER:
4679 switch (kt)
4680 {
4681 #if FFETARGET_okCHARACTER1
4682 case FFEINFO_kindtypeCHARACTER1:
4683 ffetarget_print_character1 (dmpout, u.character1);
4684 break;
4685 #endif
4686
4687 #if FFETARGET_okCHARACTER2
4688 case FFEINFO_kindtypeCHARACTER2:
4689 ffetarget_print_character2 (dmpout, u.character2);
4690 break;
4691 #endif
4692
4693 #if FFETARGET_okCHARACTER3
4694 case FFEINFO_kindtypeCHARACTER3:
4695 ffetarget_print_character3 (dmpout, u.character3);
4696 break;
4697 #endif
4698
4699 #if FFETARGET_okCHARACTER4
4700 case FFEINFO_kindtypeCHARACTER4:
4701 ffetarget_print_character4 (dmpout, u.character4);
4702 break;
4703 #endif
4704
4705 #if FFETARGET_okCHARACTER5
4706 case FFEINFO_kindtypeCHARACTER5:
4707 ffetarget_print_character5 (dmpout, u.character5);
4708 break;
4709 #endif
4710
4711 #if FFETARGET_okCHARACTER6
4712 case FFEINFO_kindtypeCHARACTER6:
4713 ffetarget_print_character6 (dmpout, u.character6);
4714 break;
4715 #endif
4716
4717 #if FFETARGET_okCHARACTER7
4718 case FFEINFO_kindtypeCHARACTER7:
4719 ffetarget_print_character7 (dmpout, u.character7);
4720 break;
4721 #endif
4722
4723 #if FFETARGET_okCHARACTER8
4724 case FFEINFO_kindtypeCHARACTER8:
4725 ffetarget_print_character8 (dmpout, u.character8);
4726 break;
4727 #endif
4728
4729 default:
4730 assert ("bad CHARACTER kindtype" == NULL);
4731 break;
4732 }
4733 break;
4734
4735 default:
4736 assert ("bad basictype" == NULL);
4737 break;
4738 }
4739 }
4740
4741 /* ffebld_dump -- Dump expression tree in concise form
4742
4743 ffebld b;
4744 ffebld_dump(b); */
4745
4746 void
4747 ffebld_dump (ffebld b)
4748 {
4749 ffeinfoKind k;
4750 ffeinfoWhere w;
4751
4752 if (b == NULL)
4753 {
4754 fprintf (dmpout, "(null)");
4755 return;
4756 }
4757
4758 switch (ffebld_op (b))
4759 {
4760 case FFEBLD_opITEM:
4761 fputs ("[", dmpout);
4762 while (b != NULL)
4763 {
4764 ffebld_dump (ffebld_head (b));
4765 if ((b = ffebld_trail (b)) != NULL)
4766 fputs (",", dmpout);
4767 }
4768 fputs ("]", dmpout);
4769 return;
4770
4771 case FFEBLD_opSTAR:
4772 case FFEBLD_opBOUNDS:
4773 case FFEBLD_opREPEAT:
4774 case FFEBLD_opLABTER:
4775 case FFEBLD_opLABTOK:
4776 case FFEBLD_opIMPDO:
4777 fputs (ffebld_op_string (ffebld_op (b)), dmpout);
4778 break;
4779
4780 default:
4781 if (ffeinfo_size (ffebld_info (b)) != FFETARGET_charactersizeNONE)
4782 fprintf (dmpout, "%s%d%s%s*%" ffetargetCharacterSize_f "u",
4783 ffebld_op_string (ffebld_op (b)),
4784 (int) ffeinfo_rank (ffebld_info (b)),
4785 ffeinfo_basictype_string (ffeinfo_basictype (ffebld_info (b))),
4786 ffeinfo_kindtype_string (ffeinfo_kindtype (ffebld_info (b))),
4787 ffeinfo_size (ffebld_info (b)));
4788 else
4789 fprintf (dmpout, "%s%d%s%s", ffebld_op_string (ffebld_op (b)),
4790 (int) ffeinfo_rank (ffebld_info (b)),
4791 ffeinfo_basictype_string (ffeinfo_basictype (ffebld_info (b))),
4792 ffeinfo_kindtype_string (ffeinfo_kindtype (ffebld_info (b))));
4793 if ((k = ffeinfo_kind (ffebld_info (b))) != FFEINFO_kindNONE)
4794 fprintf (dmpout, "/%s", ffeinfo_kind_string (k));
4795 if ((w = ffeinfo_where (ffebld_info (b))) != FFEINFO_whereNONE)
4796 fprintf (dmpout, "@%s", ffeinfo_where_string (w));
4797 break;
4798 }
4799
4800 switch (ffebld_arity (b))
4801 {
4802 case 2:
4803 fputs ("(", dmpout);
4804 ffebld_dump (ffebld_left (b));
4805 fputs (",", dmpout);
4806 ffebld_dump (ffebld_right (b));
4807 fputs (")", dmpout);
4808 break;
4809
4810 case 1:
4811 fputs ("(", dmpout);
4812 ffebld_dump (ffebld_left (b));
4813 fputs (")", dmpout);
4814 break;
4815
4816 default:
4817 switch (ffebld_op (b))
4818 {
4819 case FFEBLD_opCONTER:
4820 fprintf (dmpout, "<");
4821 ffebld_constant_dump (b->u.conter.expr);
4822 fprintf (dmpout, ">");
4823 break;
4824
4825 case FFEBLD_opACCTER:
4826 fprintf (dmpout, "<");
4827 ffebld_constantarray_dump (b->u.accter.array,
4828 ffeinfo_basictype (ffebld_info (b)),
4829 ffeinfo_kindtype (ffebld_info (b)),
4830 ffebit_size (b->u.accter.bits), b->u.accter.bits);
4831 fprintf (dmpout, ">");
4832 break;
4833
4834 case FFEBLD_opARRTER:
4835 fprintf (dmpout, "<");
4836 ffebld_constantarray_dump (b->u.arrter.array,
4837 ffeinfo_basictype (ffebld_info (b)),
4838 ffeinfo_kindtype (ffebld_info (b)),
4839 b->u.arrter.size, NULL);
4840 fprintf (dmpout, ">");
4841 break;
4842
4843 case FFEBLD_opLABTER:
4844 if (b->u.labter == NULL)
4845 fprintf (dmpout, "<>");
4846 else
4847 fprintf (dmpout, "<%" ffelabValue_f "u>", ffelab_value (b->u.labter));
4848 break;
4849
4850 case FFEBLD_opLABTOK:
4851 fprintf (dmpout, "<%s>", ffelex_token_text (b->u.labtok));
4852 break;
4853
4854 case FFEBLD_opSYMTER:
4855 fprintf (dmpout, "<");
4856 ffesymbol_dump (b->u.symter.symbol);
4857 if ((b->u.symter.generic != FFEINTRIN_genNONE)
4858 || (b->u.symter.specific != FFEINTRIN_specNONE))
4859 fprintf (dmpout, "{%s:%s:%s}",
4860 ffeintrin_name_generic (b->u.symter.generic),
4861 ffeintrin_name_specific (b->u.symter.specific),
4862 ffeintrin_name_implementation (b->u.symter.implementation));
4863 if (b->u.symter.do_iter)
4864 fprintf (dmpout, "{/do-iter}");
4865 fprintf (dmpout, ">");
4866 break;
4867
4868 default:
4869 break;
4870 }
4871 }
4872 }
4873
4874 /* ffebld_dump_prefix -- Dump the prefix for a constant of a given type
4875
4876 ffebld_dump_prefix(dmpout,FFEINFO_basictypeINTEGER,
4877 FFEINFO_kindtypeINTEGER1); */
4878
4879 void
4880 ffebld_dump_prefix (FILE *out, ffeinfoBasictype bt, ffeinfoKindtype kt)
4881 {
4882 switch (bt)
4883 {
4884 case FFEINFO_basictypeINTEGER:
4885 switch (kt)
4886 {
4887 #if FFETARGET_okINTEGER1
4888 case FFEINFO_kindtypeINTEGER1:
4889 fprintf (out, "I" STRX (FFETARGET_kindINTEGER1) "/");
4890 break;
4891 #endif
4892
4893 #if FFETARGET_okINTEGER2
4894 case FFEINFO_kindtypeINTEGER2:
4895 fprintf (out, "I" STRX (FFETARGET_kindINTEGER2) "/");
4896 break;
4897 #endif
4898
4899 #if FFETARGET_okINTEGER3
4900 case FFEINFO_kindtypeINTEGER3:
4901 fprintf (out, "I" STRX (FFETARGET_kindINTEGER3) "/");
4902 break;
4903 #endif
4904
4905 #if FFETARGET_okINTEGER4
4906 case FFEINFO_kindtypeINTEGER4:
4907 fprintf (out, "I" STRX (FFETARGET_kindINTEGER4) "/");
4908 break;
4909 #endif
4910
4911 #if FFETARGET_okINTEGER5
4912 case FFEINFO_kindtypeINTEGER5:
4913 fprintf (out, "I" STRX (FFETARGET_kindINTEGER5) "/");
4914 break;
4915 #endif
4916
4917 #if FFETARGET_okINTEGER6
4918 case FFEINFO_kindtypeINTEGER6:
4919 fprintf (out, "I" STRX (FFETARGET_kindINTEGER6) "/");
4920 break;
4921 #endif
4922
4923 #if FFETARGET_okINTEGER7
4924 case FFEINFO_kindtypeINTEGER7:
4925 fprintf (out, "I" STRX (FFETARGET_kindINTEGER7) "/");
4926 break;
4927 #endif
4928
4929 #if FFETARGET_okINTEGER8
4930 case FFEINFO_kindtypeINTEGER8:
4931 fprintf (out, "I" STRX (FFETARGET_kindINTEGER8) "/");
4932 break;
4933 #endif
4934
4935 default:
4936 assert ("bad INTEGER kindtype" == NULL);
4937 break;
4938 }
4939 break;
4940
4941 case FFEINFO_basictypeLOGICAL:
4942 switch (kt)
4943 {
4944 #if FFETARGET_okLOGICAL1
4945 case FFEINFO_kindtypeLOGICAL1:
4946 fprintf (out, "L" STRX (FFETARGET_kindLOGICAL1) "/");
4947 break;
4948 #endif
4949
4950 #if FFETARGET_okLOGICAL2
4951 case FFEINFO_kindtypeLOGICAL2:
4952 fprintf (out, "L" STRX (FFETARGET_kindLOGICAL2) "/");
4953 break;
4954 #endif
4955
4956 #if FFETARGET_okLOGICAL3
4957 case FFEINFO_kindtypeLOGICAL3:
4958 fprintf (out, "L" STRX (FFETARGET_kindLOGICAL3) "/");
4959 break;
4960 #endif
4961
4962 #if FFETARGET_okLOGICAL4
4963 case FFEINFO_kindtypeLOGICAL4:
4964 fprintf (out, "L" STRX (FFETARGET_kindLOGICAL4) "/");
4965 break;
4966 #endif
4967
4968 #if FFETARGET_okLOGICAL5
4969 case FFEINFO_kindtypeLOGICAL5:
4970 fprintf (out, "L" STRX (FFETARGET_kindLOGICAL5) "/");
4971 break;
4972 #endif
4973
4974 #if FFETARGET_okLOGICAL6
4975 case FFEINFO_kindtypeLOGICAL6:
4976 fprintf (out, "L" STRX (FFETARGET_kindLOGICAL6) "/");
4977 break;
4978 #endif
4979
4980 #if FFETARGET_okLOGICAL7
4981 case FFEINFO_kindtypeLOGICAL7:
4982 fprintf (out, "L" STRX (FFETARGET_kindLOGICAL7) "/");
4983 break;
4984 #endif
4985
4986 #if FFETARGET_okLOGICAL8
4987 case FFEINFO_kindtypeLOGICAL8:
4988 fprintf (out, "L" STRX (FFETARGET_kindLOGICAL8) "/");
4989 break;
4990 #endif
4991
4992 default:
4993 assert ("bad LOGICAL kindtype" == NULL);
4994 break;
4995 }
4996 break;
4997
4998 case FFEINFO_basictypeREAL:
4999 switch (kt)
5000 {
5001 #if FFETARGET_okREAL1
5002 case FFEINFO_kindtypeREAL1:
5003 fprintf (out, "R" STRX (FFETARGET_kindREAL1) "/");
5004 break;
5005 #endif
5006
5007 #if FFETARGET_okREAL2
5008 case FFEINFO_kindtypeREAL2:
5009 fprintf (out, "R" STRX (FFETARGET_kindREAL2) "/");
5010 break;
5011 #endif
5012
5013 #if FFETARGET_okREAL3
5014 case FFEINFO_kindtypeREAL3:
5015 fprintf (out, "R" STRX (FFETARGET_kindREAL3) "/");
5016 break;
5017 #endif
5018
5019 #if FFETARGET_okREAL4
5020 case FFEINFO_kindtypeREAL4:
5021 fprintf (out, "R" STRX (FFETARGET_kindREAL4) "/");
5022 break;
5023 #endif
5024
5025 #if FFETARGET_okREAL5
5026 case FFEINFO_kindtypeREAL5:
5027 fprintf (out, "R" STRX (FFETARGET_kindREAL5) "/");
5028 break;
5029 #endif
5030
5031 #if FFETARGET_okREAL6
5032 case FFEINFO_kindtypeREAL6:
5033 fprintf (out, "R" STRX (FFETARGET_kindREAL6) "/");
5034 break;
5035 #endif
5036
5037 #if FFETARGET_okREAL7
5038 case FFEINFO_kindtypeREAL7:
5039 fprintf (out, "R" STRX (FFETARGET_kindREAL7) "/");
5040 break;
5041 #endif
5042
5043 #if FFETARGET_okREAL8
5044 case FFEINFO_kindtypeREAL8:
5045 fprintf (out, "R" STRX (FFETARGET_kindREAL8) "/");
5046 break;
5047 #endif
5048
5049 default:
5050 assert ("bad REAL kindtype" == NULL);
5051 break;
5052 }
5053 break;
5054
5055 case FFEINFO_basictypeCOMPLEX:
5056 switch (kt)
5057 {
5058 #if FFETARGET_okCOMPLEX1
5059 case FFEINFO_kindtypeREAL1:
5060 fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX1) "/");
5061 break;
5062 #endif
5063
5064 #if FFETARGET_okCOMPLEX2
5065 case FFEINFO_kindtypeREAL2:
5066 fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX2) "/");
5067 break;
5068 #endif
5069
5070 #if FFETARGET_okCOMPLEX3
5071 case FFEINFO_kindtypeREAL3:
5072 fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX3) "/");
5073 break;
5074 #endif
5075
5076 #if FFETARGET_okCOMPLEX4
5077 case FFEINFO_kindtypeREAL4:
5078 fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX4) "/");
5079 break;
5080 #endif
5081
5082 #if FFETARGET_okCOMPLEX5
5083 case FFEINFO_kindtypeREAL5:
5084 fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX5) "/");
5085 break;
5086 #endif
5087
5088 #if FFETARGET_okCOMPLEX6
5089 case FFEINFO_kindtypeREAL6:
5090 fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX6) "/");
5091 break;
5092 #endif
5093
5094 #if FFETARGET_okCOMPLEX7
5095 case FFEINFO_kindtypeREAL7:
5096 fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX7) "/");
5097 break;
5098 #endif
5099
5100 #if FFETARGET_okCOMPLEX8
5101 case FFEINFO_kindtypeREAL8:
5102 fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX8) "/");
5103 break;
5104 #endif
5105
5106 default:
5107 assert ("bad COMPLEX kindtype" == NULL);
5108 break;
5109 }
5110 break;
5111
5112 case FFEINFO_basictypeCHARACTER:
5113 switch (kt)
5114 {
5115 #if FFETARGET_okCHARACTER1
5116 case FFEINFO_kindtypeCHARACTER1:
5117 fprintf (out, "A" STRX (FFETARGET_kindCHARACTER1) "/");
5118 break;
5119 #endif
5120
5121 #if FFETARGET_okCHARACTER2
5122 case FFEINFO_kindtypeCHARACTER2:
5123 fprintf (out, "A" STRX (FFETARGET_kindCHARACTER2) "/");
5124 break;
5125 #endif
5126
5127 #if FFETARGET_okCHARACTER3
5128 case FFEINFO_kindtypeCHARACTER3:
5129 fprintf (out, "A" STRX (FFETARGET_kindCHARACTER3) "/");
5130 break;
5131 #endif
5132
5133 #if FFETARGET_okCHARACTER4
5134 case FFEINFO_kindtypeCHARACTER4:
5135 fprintf (out, "A" STRX (FFETARGET_kindCHARACTER4) "/");
5136 break;
5137 #endif
5138
5139 #if FFETARGET_okCHARACTER5
5140 case FFEINFO_kindtypeCHARACTER5:
5141 fprintf (out, "A" STRX (FFETARGET_kindCHARACTER5) "/");
5142 break;
5143 #endif
5144
5145 #if FFETARGET_okCHARACTER6
5146 case FFEINFO_kindtypeCHARACTER6:
5147 fprintf (out, "A" STRX (FFETARGET_kindCHARACTER6) "/");
5148 break;
5149 #endif
5150
5151 #if FFETARGET_okCHARACTER7
5152 case FFEINFO_kindtypeCHARACTER7:
5153 fprintf (out, "A" STRX (FFETARGET_kindCHARACTER7) "/");
5154 break;
5155 #endif
5156
5157 #if FFETARGET_okCHARACTER8
5158 case FFEINFO_kindtypeCHARACTER8:
5159 fprintf (out, "A" STRX (FFETARGET_kindCHARACTER8) "/");
5160 break;
5161 #endif
5162
5163 default:
5164 assert ("bad CHARACTER kindtype" == NULL);
5165 break;
5166 }
5167 break;
5168
5169 default:
5170 assert ("bad basictype" == NULL);
5171 fprintf (out, "?/?");
5172 break;
5173 }
5174 }
5175
5176 /* ffebld_init_0 -- Initialize the module
5177
5178 ffebld_init_0(); */
5179
5180 void
5181 ffebld_init_0 ()
5182 {
5183 assert (FFEBLD_op == ARRAY_SIZE (ffebld_op_string_));
5184 assert (FFEBLD_op == ARRAY_SIZE (ffebld_arity_op_));
5185 }
5186
5187 /* ffebld_init_1 -- Initialize the module for a file
5188
5189 ffebld_init_1(); */
5190
5191 void
5192 ffebld_init_1 ()
5193 {
5194 #if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstFILE_
5195 int i;
5196
5197 #if FFETARGET_okCHARACTER1
5198 ffebld_constant_character1_ = NULL;
5199 #endif
5200 #if FFETARGET_okCHARACTER2
5201 ffebld_constant_character2_ = NULL;
5202 #endif
5203 #if FFETARGET_okCHARACTER3
5204 ffebld_constant_character3_ = NULL;
5205 #endif
5206 #if FFETARGET_okCHARACTER4
5207 ffebld_constant_character4_ = NULL;
5208 #endif
5209 #if FFETARGET_okCHARACTER5
5210 ffebld_constant_character5_ = NULL;
5211 #endif
5212 #if FFETARGET_okCHARACTER6
5213 ffebld_constant_character6_ = NULL;
5214 #endif
5215 #if FFETARGET_okCHARACTER7
5216 ffebld_constant_character7_ = NULL;
5217 #endif
5218 #if FFETARGET_okCHARACTER8
5219 ffebld_constant_character8_ = NULL;
5220 #endif
5221 #if FFETARGET_okCOMPLEX1
5222 ffebld_constant_complex1_ = NULL;
5223 #endif
5224 #if FFETARGET_okCOMPLEX2
5225 ffebld_constant_complex2_ = NULL;
5226 #endif
5227 #if FFETARGET_okCOMPLEX3
5228 ffebld_constant_complex3_ = NULL;
5229 #endif
5230 #if FFETARGET_okCOMPLEX4
5231 ffebld_constant_complex4_ = NULL;
5232 #endif
5233 #if FFETARGET_okCOMPLEX5
5234 ffebld_constant_complex5_ = NULL;
5235 #endif
5236 #if FFETARGET_okCOMPLEX6
5237 ffebld_constant_complex6_ = NULL;
5238 #endif
5239 #if FFETARGET_okCOMPLEX7
5240 ffebld_constant_complex7_ = NULL;
5241 #endif
5242 #if FFETARGET_okCOMPLEX8
5243 ffebld_constant_complex8_ = NULL;
5244 #endif
5245 #if FFETARGET_okINTEGER1
5246 ffebld_constant_integer1_ = NULL;
5247 #endif
5248 #if FFETARGET_okINTEGER2
5249 ffebld_constant_integer2_ = NULL;
5250 #endif
5251 #if FFETARGET_okINTEGER3
5252 ffebld_constant_integer3_ = NULL;
5253 #endif
5254 #if FFETARGET_okINTEGER4
5255 ffebld_constant_integer4_ = NULL;
5256 #endif
5257 #if FFETARGET_okINTEGER5
5258 ffebld_constant_integer5_ = NULL;
5259 #endif
5260 #if FFETARGET_okINTEGER6
5261 ffebld_constant_integer6_ = NULL;
5262 #endif
5263 #if FFETARGET_okINTEGER7
5264 ffebld_constant_integer7_ = NULL;
5265 #endif
5266 #if FFETARGET_okINTEGER8
5267 ffebld_constant_integer8_ = NULL;
5268 #endif
5269 #if FFETARGET_okLOGICAL1
5270 ffebld_constant_logical1_ = NULL;
5271 #endif
5272 #if FFETARGET_okLOGICAL2
5273 ffebld_constant_logical2_ = NULL;
5274 #endif
5275 #if FFETARGET_okLOGICAL3
5276 ffebld_constant_logical3_ = NULL;
5277 #endif
5278 #if FFETARGET_okLOGICAL4
5279 ffebld_constant_logical4_ = NULL;
5280 #endif
5281 #if FFETARGET_okLOGICAL5
5282 ffebld_constant_logical5_ = NULL;
5283 #endif
5284 #if FFETARGET_okLOGICAL6
5285 ffebld_constant_logical6_ = NULL;
5286 #endif
5287 #if FFETARGET_okLOGICAL7
5288 ffebld_constant_logical7_ = NULL;
5289 #endif
5290 #if FFETARGET_okLOGICAL8
5291 ffebld_constant_logical8_ = NULL;
5292 #endif
5293 #if FFETARGET_okREAL1
5294 ffebld_constant_real1_ = NULL;
5295 #endif
5296 #if FFETARGET_okREAL2
5297 ffebld_constant_real2_ = NULL;
5298 #endif
5299 #if FFETARGET_okREAL3
5300 ffebld_constant_real3_ = NULL;
5301 #endif
5302 #if FFETARGET_okREAL4
5303 ffebld_constant_real4_ = NULL;
5304 #endif
5305 #if FFETARGET_okREAL5
5306 ffebld_constant_real5_ = NULL;
5307 #endif
5308 #if FFETARGET_okREAL6
5309 ffebld_constant_real6_ = NULL;
5310 #endif
5311 #if FFETARGET_okREAL7
5312 ffebld_constant_real7_ = NULL;
5313 #endif
5314 #if FFETARGET_okREAL8
5315 ffebld_constant_real8_ = NULL;
5316 #endif
5317 ffebld_constant_hollerith_ = NULL;
5318 for (i = FFEBLD_constTYPELESS_FIRST; i <= FFEBLD_constTYPELESS_LAST; ++i)
5319 ffebld_constant_typeless_[i - FFEBLD_constTYPELESS_FIRST] = NULL;
5320 #endif
5321 }
5322
5323 /* ffebld_init_2 -- Initialize the module
5324
5325 ffebld_init_2(); */
5326
5327 void
5328 ffebld_init_2 ()
5329 {
5330 #if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstPROGUNIT_
5331 int i;
5332 #endif
5333
5334 ffebld_pool_stack_.next = NULL;
5335 ffebld_pool_stack_.pool = ffe_pool_program_unit ();
5336 #if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstPROGUNIT_
5337 #if FFETARGET_okCHARACTER1
5338 ffebld_constant_character1_ = NULL;
5339 #endif
5340 #if FFETARGET_okCHARACTER2
5341 ffebld_constant_character2_ = NULL;
5342 #endif
5343 #if FFETARGET_okCHARACTER3
5344 ffebld_constant_character3_ = NULL;
5345 #endif
5346 #if FFETARGET_okCHARACTER4
5347 ffebld_constant_character4_ = NULL;
5348 #endif
5349 #if FFETARGET_okCHARACTER5
5350 ffebld_constant_character5_ = NULL;
5351 #endif
5352 #if FFETARGET_okCHARACTER6
5353 ffebld_constant_character6_ = NULL;
5354 #endif
5355 #if FFETARGET_okCHARACTER7
5356 ffebld_constant_character7_ = NULL;
5357 #endif
5358 #if FFETARGET_okCHARACTER8
5359 ffebld_constant_character8_ = NULL;
5360 #endif
5361 #if FFETARGET_okCOMPLEX1
5362 ffebld_constant_complex1_ = NULL;
5363 #endif
5364 #if FFETARGET_okCOMPLEX2
5365 ffebld_constant_complex2_ = NULL;
5366 #endif
5367 #if FFETARGET_okCOMPLEX3
5368 ffebld_constant_complex3_ = NULL;
5369 #endif
5370 #if FFETARGET_okCOMPLEX4
5371 ffebld_constant_complex4_ = NULL;
5372 #endif
5373 #if FFETARGET_okCOMPLEX5
5374 ffebld_constant_complex5_ = NULL;
5375 #endif
5376 #if FFETARGET_okCOMPLEX6
5377 ffebld_constant_complex6_ = NULL;
5378 #endif
5379 #if FFETARGET_okCOMPLEX7
5380 ffebld_constant_complex7_ = NULL;
5381 #endif
5382 #if FFETARGET_okCOMPLEX8
5383 ffebld_constant_complex8_ = NULL;
5384 #endif
5385 #if FFETARGET_okINTEGER1
5386 ffebld_constant_integer1_ = NULL;
5387 #endif
5388 #if FFETARGET_okINTEGER2
5389 ffebld_constant_integer2_ = NULL;
5390 #endif
5391 #if FFETARGET_okINTEGER3
5392 ffebld_constant_integer3_ = NULL;
5393 #endif
5394 #if FFETARGET_okINTEGER4
5395 ffebld_constant_integer4_ = NULL;
5396 #endif
5397 #if FFETARGET_okINTEGER5
5398 ffebld_constant_integer5_ = NULL;
5399 #endif
5400 #if FFETARGET_okINTEGER6
5401 ffebld_constant_integer6_ = NULL;
5402 #endif
5403 #if FFETARGET_okINTEGER7
5404 ffebld_constant_integer7_ = NULL;
5405 #endif
5406 #if FFETARGET_okINTEGER8
5407 ffebld_constant_integer8_ = NULL;
5408 #endif
5409 #if FFETARGET_okLOGICAL1
5410 ffebld_constant_logical1_ = NULL;
5411 #endif
5412 #if FFETARGET_okLOGICAL2
5413 ffebld_constant_logical2_ = NULL;
5414 #endif
5415 #if FFETARGET_okLOGICAL3
5416 ffebld_constant_logical3_ = NULL;
5417 #endif
5418 #if FFETARGET_okLOGICAL4
5419 ffebld_constant_logical4_ = NULL;
5420 #endif
5421 #if FFETARGET_okLOGICAL5
5422 ffebld_constant_logical5_ = NULL;
5423 #endif
5424 #if FFETARGET_okLOGICAL6
5425 ffebld_constant_logical6_ = NULL;
5426 #endif
5427 #if FFETARGET_okLOGICAL7
5428 ffebld_constant_logical7_ = NULL;
5429 #endif
5430 #if FFETARGET_okLOGICAL8
5431 ffebld_constant_logical8_ = NULL;
5432 #endif
5433 #if FFETARGET_okREAL1
5434 ffebld_constant_real1_ = NULL;
5435 #endif
5436 #if FFETARGET_okREAL2
5437 ffebld_constant_real2_ = NULL;
5438 #endif
5439 #if FFETARGET_okREAL3
5440 ffebld_constant_real3_ = NULL;
5441 #endif
5442 #if FFETARGET_okREAL4
5443 ffebld_constant_real4_ = NULL;
5444 #endif
5445 #if FFETARGET_okREAL5
5446 ffebld_constant_real5_ = NULL;
5447 #endif
5448 #if FFETARGET_okREAL6
5449 ffebld_constant_real6_ = NULL;
5450 #endif
5451 #if FFETARGET_okREAL7
5452 ffebld_constant_real7_ = NULL;
5453 #endif
5454 #if FFETARGET_okREAL8
5455 ffebld_constant_real8_ = NULL;
5456 #endif
5457 ffebld_constant_hollerith_ = NULL;
5458 for (i = FFEBLD_constTYPELESS_FIRST; i <= FFEBLD_constTYPELESS_LAST; ++i)
5459 ffebld_constant_typeless_[i - FFEBLD_constTYPELESS_FIRST] = NULL;
5460 #endif
5461 }
5462
5463 /* ffebld_list_length -- Return # of opITEMs in list
5464
5465 ffebld list; // Must be NULL or opITEM
5466 ffebldListLength length;
5467 length = ffebld_list_length(list);
5468
5469 Returns 0 if list is NULL, 1 if it's ffebld_trail is NULL, and so on. */
5470
5471 ffebldListLength
5472 ffebld_list_length (ffebld list)
5473 {
5474 ffebldListLength length;
5475
5476 for (length = 0; list != NULL; ++length, list = ffebld_trail (list))
5477 ;
5478
5479 return length;
5480 }
5481
5482 /* ffebld_new_accter -- Create an ffebld object that is an array
5483
5484 ffebld x;
5485 ffebldConstantArray a;
5486 ffebit b;
5487 x = ffebld_new_accter(a,b); */
5488
5489 ffebld
5490 ffebld_new_accter (ffebldConstantArray a, ffebit b)
5491 {
5492 ffebld x;
5493
5494 x = ffebld_new ();
5495 #if FFEBLD_BLANK_
5496 *x = ffebld_blank_;
5497 #endif
5498 x->op = FFEBLD_opACCTER;
5499 x->u.accter.array = a;
5500 x->u.accter.bits = b;
5501 return x;
5502 }
5503
5504 /* ffebld_new_arrter -- Create an ffebld object that is an array
5505
5506 ffebld x;
5507 ffebldConstantArray a;
5508 ffetargetOffset size;
5509 x = ffebld_new_arrter(a,size); */
5510
5511 ffebld
5512 ffebld_new_arrter (ffebldConstantArray a, ffetargetOffset size)
5513 {
5514 ffebld x;
5515
5516 x = ffebld_new ();
5517 #if FFEBLD_BLANK_
5518 *x = ffebld_blank_;
5519 #endif
5520 x->op = FFEBLD_opARRTER;
5521 x->u.arrter.array = a;
5522 x->u.arrter.size = size;
5523 return x;
5524 }
5525
5526 /* ffebld_new_conter_with_orig -- Create an ffebld object that is a constant
5527
5528 ffebld x;
5529 ffebldConstant c;
5530 x = ffebld_new_conter_with_orig(c,NULL); */
5531
5532 ffebld
5533 ffebld_new_conter_with_orig (ffebldConstant c, ffebld o)
5534 {
5535 ffebld x;
5536
5537 x = ffebld_new ();
5538 #if FFEBLD_BLANK_
5539 *x = ffebld_blank_;
5540 #endif
5541 x->op = FFEBLD_opCONTER;
5542 x->u.conter.expr = c;
5543 x->u.conter.orig = o;
5544 return x;
5545 }
5546
5547 /* ffebld_new_item -- Create an ffebld item object
5548
5549 ffebld x,y,z;
5550 x = ffebld_new_item(y,z); */
5551
5552 ffebld
5553 ffebld_new_item (ffebld head, ffebld trail)
5554 {
5555 ffebld x;
5556
5557 x = ffebld_new ();
5558 #if FFEBLD_BLANK_
5559 *x = ffebld_blank_;
5560 #endif
5561 x->op = FFEBLD_opITEM;
5562 x->u.item.head = head;
5563 x->u.item.trail = trail;
5564 return x;
5565 }
5566
5567 /* ffebld_new_labter -- Create an ffebld object that is a label
5568
5569 ffebld x;
5570 ffelab l;
5571 x = ffebld_new_labter(c); */
5572
5573 ffebld
5574 ffebld_new_labter (ffelab l)
5575 {
5576 ffebld x;
5577
5578 x = ffebld_new ();
5579 #if FFEBLD_BLANK_
5580 *x = ffebld_blank_;
5581 #endif
5582 x->op = FFEBLD_opLABTER;
5583 x->u.labter = l;
5584 return x;
5585 }
5586
5587 /* ffebld_new_labtok -- Create object that is a label's NUMBER token
5588
5589 ffebld x;
5590 ffelexToken t;
5591 x = ffebld_new_labter(c);
5592
5593 Like the other ffebld_new_ functions, the
5594 supplied argument is stored exactly as is: ffelex_token_use is NOT
5595 called, so the token is "consumed", if one is indeed supplied (it may
5596 be NULL). */
5597
5598 ffebld
5599 ffebld_new_labtok (ffelexToken t)
5600 {
5601 ffebld x;
5602
5603 x = ffebld_new ();
5604 #if FFEBLD_BLANK_
5605 *x = ffebld_blank_;
5606 #endif
5607 x->op = FFEBLD_opLABTOK;
5608 x->u.labtok = t;
5609 return x;
5610 }
5611
5612 /* ffebld_new_none -- Create an ffebld object with no arguments
5613
5614 ffebld x;
5615 x = ffebld_new_none(FFEBLD_opWHATEVER); */
5616
5617 ffebld
5618 ffebld_new_none (ffebldOp o)
5619 {
5620 ffebld x;
5621
5622 x = ffebld_new ();
5623 #if FFEBLD_BLANK_
5624 *x = ffebld_blank_;
5625 #endif
5626 x->op = o;
5627 return x;
5628 }
5629
5630 /* ffebld_new_one -- Create an ffebld object with one argument
5631
5632 ffebld x,y;
5633 x = ffebld_new_one(FFEBLD_opWHATEVER,y); */
5634
5635 ffebld
5636 ffebld_new_one (ffebldOp o, ffebld left)
5637 {
5638 ffebld x;
5639
5640 x = ffebld_new ();
5641 #if FFEBLD_BLANK_
5642 *x = ffebld_blank_;
5643 #endif
5644 x->op = o;
5645 x->u.nonter.left = left;
5646 return x;
5647 }
5648
5649 /* ffebld_new_symter -- Create an ffebld object that is a symbol
5650
5651 ffebld x;
5652 ffesymbol s;
5653 ffeintrinGen gen; // Generic intrinsic id, if any
5654 ffeintrinSpec spec; // Specific intrinsic id, if any
5655 ffeintrinImp imp; // Implementation intrinsic id, if any
5656 x = ffebld_new_symter (s, gen, spec, imp); */
5657
5658 ffebld
5659 ffebld_new_symter (ffesymbol s, ffeintrinGen gen, ffeintrinSpec spec,
5660 ffeintrinImp imp)
5661 {
5662 ffebld x;
5663
5664 x = ffebld_new ();
5665 #if FFEBLD_BLANK_
5666 *x = ffebld_blank_;
5667 #endif
5668 x->op = FFEBLD_opSYMTER;
5669 x->u.symter.symbol = s;
5670 x->u.symter.generic = gen;
5671 x->u.symter.specific = spec;
5672 x->u.symter.implementation = imp;
5673 x->u.symter.do_iter = FALSE;
5674 return x;
5675 }
5676
5677 /* ffebld_new_two -- Create an ffebld object with two arguments
5678
5679 ffebld x,y,z;
5680 x = ffebld_new_two(FFEBLD_opWHATEVER,y,z); */
5681
5682 ffebld
5683 ffebld_new_two (ffebldOp o, ffebld left, ffebld right)
5684 {
5685 ffebld x;
5686
5687 x = ffebld_new ();
5688 #if FFEBLD_BLANK_
5689 *x = ffebld_blank_;
5690 #endif
5691 x->op = o;
5692 x->u.nonter.left = left;
5693 x->u.nonter.right = right;
5694 return x;
5695 }
5696
5697 /* ffebld_pool_pop -- Pop ffebld's pool stack
5698
5699 ffebld_pool_pop(); */
5700
5701 void
5702 ffebld_pool_pop ()
5703 {
5704 ffebldPoolstack_ ps;
5705
5706 assert (ffebld_pool_stack_.next != NULL);
5707 ps = ffebld_pool_stack_.next;
5708 ffebld_pool_stack_.next = ps->next;
5709 ffebld_pool_stack_.pool = ps->pool;
5710 malloc_kill_ks (malloc_pool_image (), ps, sizeof (*ps));
5711 }
5712
5713 /* ffebld_pool_push -- Push ffebld's pool stack
5714
5715 ffebld_pool_push(); */
5716
5717 void
5718 ffebld_pool_push (mallocPool pool)
5719 {
5720 ffebldPoolstack_ ps;
5721
5722 ps = malloc_new_ks (malloc_pool_image (), "Pool stack", sizeof (*ps));
5723 ps->next = ffebld_pool_stack_.next;
5724 ps->pool = ffebld_pool_stack_.pool;
5725 ffebld_pool_stack_.next = ps;
5726 ffebld_pool_stack_.pool = pool;
5727 }
5728
5729 /* ffebld_op_string -- Return short string describing op
5730
5731 ffebldOp o;
5732 ffebld_op_string(o);
5733
5734 Returns a short string (uppercase) containing the name of the op. */
5735
5736 char *
5737 ffebld_op_string (ffebldOp o)
5738 {
5739 if (o >= ARRAY_SIZE (ffebld_op_string_))
5740 return "?\?\?";
5741 return ffebld_op_string_[o];
5742 }
5743
5744 /* ffebld_size_max -- Return maximum possible size of CHARACTER-type expr
5745
5746 ffetargetCharacterSize sz;
5747 ffebld b;
5748 sz = ffebld_size_max (b);
5749
5750 Like ffebld_size_known, but if that would return NONE and the expression
5751 is opSUBSTR, opCONVERT, opPAREN, or opCONCATENATE, returns ffebld_size_max
5752 of the subexpression(s). */
5753
5754 ffetargetCharacterSize
5755 ffebld_size_max (ffebld b)
5756 {
5757 ffetargetCharacterSize sz;
5758
5759 recurse: /* :::::::::::::::::::: */
5760
5761 sz = ffebld_size_known (b);
5762
5763 if (sz != FFETARGET_charactersizeNONE)
5764 return sz;
5765
5766 switch (ffebld_op (b))
5767 {
5768 case FFEBLD_opSUBSTR:
5769 case FFEBLD_opCONVERT:
5770 case FFEBLD_opPAREN:
5771 b = ffebld_left (b);
5772 goto recurse; /* :::::::::::::::::::: */
5773
5774 case FFEBLD_opCONCATENATE:
5775 sz = ffebld_size_max (ffebld_left (b))
5776 + ffebld_size_max (ffebld_right (b));
5777 return sz;
5778
5779 default:
5780 return sz;
5781 }
5782 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org