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