* config/arm/elf.h (ASM_OUTPUT_ALIGNED_COMMON): Remove definition.
[official-gcc.git] / gcc / f / bld.c
blob3460c241b246954571c3399e0b6c9fe0c6204e3a
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.
5 This file is part of GNU Fortran.
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.
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.
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.
22 Related Modules:
23 None
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.
31 Modifications:
32 30-Aug-92 JCB 1.1
33 Change names of some things for consistency.
36 /* Include files. */
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 #include "real.h"
48 /* Externals defined here. */
50 const ffebldArity ffebld_arity_op_[(int) FFEBLD_op]
53 #define FFEBLD_OP(KWD,NAME,ARITY) ARITY,
54 #include "bld-op.def"
55 #undef FFEBLD_OP
57 struct _ffebld_pool_stack_ ffebld_pool_stack_;
59 /* Simple definitions and enumerations. */
62 /* Internal typedefs. */
65 /* Private include files. */
68 /* Internal structure definitions. */
71 /* Static objects accessed by functions in this module. */
73 #if FFEBLD_BLANK_
74 static struct _ffebld_ ffebld_blank_
78 {FFEINFO_basictypeNONE, FFEINFO_kindtypeNONE, 0, FFEINFO_kindNONE,
79 FFEINFO_whereNONE, FFETARGET_charactersizeNONE},
80 {NULL, NULL}
82 #endif
83 #if FFETARGET_okCHARACTER1
84 static ffebldConstant ffebld_constant_character1_;
85 #endif
86 #if FFETARGET_okCHARACTER2
87 static ffebldConstant ffebld_constant_character2_;
88 #endif
89 #if FFETARGET_okCHARACTER3
90 static ffebldConstant ffebld_constant_character3_;
91 #endif
92 #if FFETARGET_okCHARACTER4
93 static ffebldConstant ffebld_constant_character4_;
94 #endif
95 #if FFETARGET_okCHARACTER5
96 static ffebldConstant ffebld_constant_character5_;
97 #endif
98 #if FFETARGET_okCHARACTER6
99 static ffebldConstant ffebld_constant_character6_;
100 #endif
101 #if FFETARGET_okCHARACTER7
102 static ffebldConstant ffebld_constant_character7_;
103 #endif
104 #if FFETARGET_okCHARACTER8
105 static ffebldConstant ffebld_constant_character8_;
106 #endif
107 #if FFETARGET_okCOMPLEX1
108 static ffebldConstant ffebld_constant_complex1_;
109 #endif
110 #if FFETARGET_okCOMPLEX2
111 static ffebldConstant ffebld_constant_complex2_;
112 #endif
113 #if FFETARGET_okCOMPLEX3
114 static ffebldConstant ffebld_constant_complex3_;
115 #endif
116 #if FFETARGET_okCOMPLEX4
117 static ffebldConstant ffebld_constant_complex4_;
118 #endif
119 #if FFETARGET_okCOMPLEX5
120 static ffebldConstant ffebld_constant_complex5_;
121 #endif
122 #if FFETARGET_okCOMPLEX6
123 static ffebldConstant ffebld_constant_complex6_;
124 #endif
125 #if FFETARGET_okCOMPLEX7
126 static ffebldConstant ffebld_constant_complex7_;
127 #endif
128 #if FFETARGET_okCOMPLEX8
129 static ffebldConstant ffebld_constant_complex8_;
130 #endif
131 #if FFETARGET_okINTEGER1
132 static ffebldConstant ffebld_constant_integer1_;
133 #endif
134 #if FFETARGET_okINTEGER2
135 static ffebldConstant ffebld_constant_integer2_;
136 #endif
137 #if FFETARGET_okINTEGER3
138 static ffebldConstant ffebld_constant_integer3_;
139 #endif
140 #if FFETARGET_okINTEGER4
141 static ffebldConstant ffebld_constant_integer4_;
142 #endif
143 #if FFETARGET_okINTEGER5
144 static ffebldConstant ffebld_constant_integer5_;
145 #endif
146 #if FFETARGET_okINTEGER6
147 static ffebldConstant ffebld_constant_integer6_;
148 #endif
149 #if FFETARGET_okINTEGER7
150 static ffebldConstant ffebld_constant_integer7_;
151 #endif
152 #if FFETARGET_okINTEGER8
153 static ffebldConstant ffebld_constant_integer8_;
154 #endif
155 #if FFETARGET_okLOGICAL1
156 static ffebldConstant ffebld_constant_logical1_;
157 #endif
158 #if FFETARGET_okLOGICAL2
159 static ffebldConstant ffebld_constant_logical2_;
160 #endif
161 #if FFETARGET_okLOGICAL3
162 static ffebldConstant ffebld_constant_logical3_;
163 #endif
164 #if FFETARGET_okLOGICAL4
165 static ffebldConstant ffebld_constant_logical4_;
166 #endif
167 #if FFETARGET_okLOGICAL5
168 static ffebldConstant ffebld_constant_logical5_;
169 #endif
170 #if FFETARGET_okLOGICAL6
171 static ffebldConstant ffebld_constant_logical6_;
172 #endif
173 #if FFETARGET_okLOGICAL7
174 static ffebldConstant ffebld_constant_logical7_;
175 #endif
176 #if FFETARGET_okLOGICAL8
177 static ffebldConstant ffebld_constant_logical8_;
178 #endif
179 #if FFETARGET_okREAL1
180 static ffebldConstant ffebld_constant_real1_;
181 #endif
182 #if FFETARGET_okREAL2
183 static ffebldConstant ffebld_constant_real2_;
184 #endif
185 #if FFETARGET_okREAL3
186 static ffebldConstant ffebld_constant_real3_;
187 #endif
188 #if FFETARGET_okREAL4
189 static ffebldConstant ffebld_constant_real4_;
190 #endif
191 #if FFETARGET_okREAL5
192 static ffebldConstant ffebld_constant_real5_;
193 #endif
194 #if FFETARGET_okREAL6
195 static ffebldConstant ffebld_constant_real6_;
196 #endif
197 #if FFETARGET_okREAL7
198 static ffebldConstant ffebld_constant_real7_;
199 #endif
200 #if FFETARGET_okREAL8
201 static ffebldConstant ffebld_constant_real8_;
202 #endif
203 static ffebldConstant ffebld_constant_hollerith_;
204 static ffebldConstant ffebld_constant_typeless_[FFEBLD_constTYPELESS_LAST
205 - FFEBLD_constTYPELESS_FIRST + 1];
207 static const char *const ffebld_op_string_[]
210 #define FFEBLD_OP(KWD,NAME,ARITY) NAME,
211 #include "bld-op.def"
212 #undef FFEBLD_OP
215 /* Static functions (internal). */
218 /* Internal macros. */
220 #define integerdefault_ CATX(integer,FFETARGET_ktINTEGERDEFAULT)
221 #define logicaldefault_ CATX(logical,FFETARGET_ktLOGICALDEFAULT)
222 #define realdefault_ CATX(real,FFETARGET_ktREALDEFAULT)
223 #define realdouble_ CATX(real,FFETARGET_ktREALDOUBLE)
224 #define realquad_ CATX(real,FFETARGET_ktREALQUAD)
226 /* ffebld_constant_cmp -- Compare two constants a la strcmp
228 ffebldConstant c1, c2;
229 if (ffebld_constant_cmp(c1,c2) == 0)
230 // they're equal, else they're not.
232 Returns -1 if c1 < c2, 0 if c1 == c2, +1 if c1 == c2. */
235 ffebld_constant_cmp (ffebldConstant c1, ffebldConstant c2)
237 if (c1 == c2)
238 return 0;
240 assert (ffebld_constant_type (c1) == ffebld_constant_type (c2));
242 switch (ffebld_constant_type (c1))
244 #if FFETARGET_okINTEGER1
245 case FFEBLD_constINTEGER1:
246 return ffetarget_cmp_integer1 (ffebld_constant_integer1 (c1),
247 ffebld_constant_integer1 (c2));
248 #endif
250 #if FFETARGET_okINTEGER2
251 case FFEBLD_constINTEGER2:
252 return ffetarget_cmp_integer2 (ffebld_constant_integer2 (c1),
253 ffebld_constant_integer2 (c2));
254 #endif
256 #if FFETARGET_okINTEGER3
257 case FFEBLD_constINTEGER3:
258 return ffetarget_cmp_integer3 (ffebld_constant_integer3 (c1),
259 ffebld_constant_integer3 (c2));
260 #endif
262 #if FFETARGET_okINTEGER4
263 case FFEBLD_constINTEGER4:
264 return ffetarget_cmp_integer4 (ffebld_constant_integer4 (c1),
265 ffebld_constant_integer4 (c2));
266 #endif
268 #if FFETARGET_okINTEGER5
269 case FFEBLD_constINTEGER5:
270 return ffetarget_cmp_integer5 (ffebld_constant_integer5 (c1),
271 ffebld_constant_integer5 (c2));
272 #endif
274 #if FFETARGET_okINTEGER6
275 case FFEBLD_constINTEGER6:
276 return ffetarget_cmp_integer6 (ffebld_constant_integer6 (c1),
277 ffebld_constant_integer6 (c2));
278 #endif
280 #if FFETARGET_okINTEGER7
281 case FFEBLD_constINTEGER7:
282 return ffetarget_cmp_integer7 (ffebld_constant_integer7 (c1),
283 ffebld_constant_integer7 (c2));
284 #endif
286 #if FFETARGET_okINTEGER8
287 case FFEBLD_constINTEGER8:
288 return ffetarget_cmp_integer8 (ffebld_constant_integer8 (c1),
289 ffebld_constant_integer8 (c2));
290 #endif
292 #if FFETARGET_okLOGICAL1
293 case FFEBLD_constLOGICAL1:
294 return ffetarget_cmp_logical1 (ffebld_constant_logical1 (c1),
295 ffebld_constant_logical1 (c2));
296 #endif
298 #if FFETARGET_okLOGICAL2
299 case FFEBLD_constLOGICAL2:
300 return ffetarget_cmp_logical2 (ffebld_constant_logical2 (c1),
301 ffebld_constant_logical2 (c2));
302 #endif
304 #if FFETARGET_okLOGICAL3
305 case FFEBLD_constLOGICAL3:
306 return ffetarget_cmp_logical3 (ffebld_constant_logical3 (c1),
307 ffebld_constant_logical3 (c2));
308 #endif
310 #if FFETARGET_okLOGICAL4
311 case FFEBLD_constLOGICAL4:
312 return ffetarget_cmp_logical4 (ffebld_constant_logical4 (c1),
313 ffebld_constant_logical4 (c2));
314 #endif
316 #if FFETARGET_okLOGICAL5
317 case FFEBLD_constLOGICAL5:
318 return ffetarget_cmp_logical5 (ffebld_constant_logical5 (c1),
319 ffebld_constant_logical5 (c2));
320 #endif
322 #if FFETARGET_okLOGICAL6
323 case FFEBLD_constLOGICAL6:
324 return ffetarget_cmp_logical6 (ffebld_constant_logical6 (c1),
325 ffebld_constant_logical6 (c2));
326 #endif
328 #if FFETARGET_okLOGICAL7
329 case FFEBLD_constLOGICAL7:
330 return ffetarget_cmp_logical7 (ffebld_constant_logical7 (c1),
331 ffebld_constant_logical7 (c2));
332 #endif
334 #if FFETARGET_okLOGICAL8
335 case FFEBLD_constLOGICAL8:
336 return ffetarget_cmp_logical8 (ffebld_constant_logical8 (c1),
337 ffebld_constant_logical8 (c2));
338 #endif
340 #if FFETARGET_okREAL1
341 case FFEBLD_constREAL1:
342 return ffetarget_cmp_real1 (ffebld_constant_real1 (c1),
343 ffebld_constant_real1 (c2));
344 #endif
346 #if FFETARGET_okREAL2
347 case FFEBLD_constREAL2:
348 return ffetarget_cmp_real2 (ffebld_constant_real2 (c1),
349 ffebld_constant_real2 (c2));
350 #endif
352 #if FFETARGET_okREAL3
353 case FFEBLD_constREAL3:
354 return ffetarget_cmp_real3 (ffebld_constant_real3 (c1),
355 ffebld_constant_real3 (c2));
356 #endif
358 #if FFETARGET_okREAL4
359 case FFEBLD_constREAL4:
360 return ffetarget_cmp_real4 (ffebld_constant_real4 (c1),
361 ffebld_constant_real4 (c2));
362 #endif
364 #if FFETARGET_okREAL5
365 case FFEBLD_constREAL5:
366 return ffetarget_cmp_real5 (ffebld_constant_real5 (c1),
367 ffebld_constant_real5 (c2));
368 #endif
370 #if FFETARGET_okREAL6
371 case FFEBLD_constREAL6:
372 return ffetarget_cmp_real6 (ffebld_constant_real6 (c1),
373 ffebld_constant_real6 (c2));
374 #endif
376 #if FFETARGET_okREAL7
377 case FFEBLD_constREAL7:
378 return ffetarget_cmp_real7 (ffebld_constant_real7 (c1),
379 ffebld_constant_real7 (c2));
380 #endif
382 #if FFETARGET_okREAL8
383 case FFEBLD_constREAL8:
384 return ffetarget_cmp_real8 (ffebld_constant_real8 (c1),
385 ffebld_constant_real8 (c2));
386 #endif
388 #if FFETARGET_okCHARACTER1
389 case FFEBLD_constCHARACTER1:
390 return ffetarget_cmp_character1 (ffebld_constant_character1 (c1),
391 ffebld_constant_character1 (c2));
392 #endif
394 #if FFETARGET_okCHARACTER2
395 case FFEBLD_constCHARACTER2:
396 return ffetarget_cmp_character2 (ffebld_constant_character2 (c1),
397 ffebld_constant_character2 (c2));
398 #endif
400 #if FFETARGET_okCHARACTER3
401 case FFEBLD_constCHARACTER3:
402 return ffetarget_cmp_character3 (ffebld_constant_character3 (c1),
403 ffebld_constant_character3 (c2));
404 #endif
406 #if FFETARGET_okCHARACTER4
407 case FFEBLD_constCHARACTER4:
408 return ffetarget_cmp_character4 (ffebld_constant_character4 (c1),
409 ffebld_constant_character4 (c2));
410 #endif
412 #if FFETARGET_okCHARACTER5
413 case FFEBLD_constCHARACTER5:
414 return ffetarget_cmp_character5 (ffebld_constant_character5 (c1),
415 ffebld_constant_character5 (c2));
416 #endif
418 #if FFETARGET_okCHARACTER6
419 case FFEBLD_constCHARACTER6:
420 return ffetarget_cmp_character6 (ffebld_constant_character6 (c1),
421 ffebld_constant_character6 (c2));
422 #endif
424 #if FFETARGET_okCHARACTER7
425 case FFEBLD_constCHARACTER7:
426 return ffetarget_cmp_character7 (ffebld_constant_character7 (c1),
427 ffebld_constant_character7 (c2));
428 #endif
430 #if FFETARGET_okCHARACTER8
431 case FFEBLD_constCHARACTER8:
432 return ffetarget_cmp_character8 (ffebld_constant_character8 (c1),
433 ffebld_constant_character8 (c2));
434 #endif
436 default:
437 assert ("bad constant type" == NULL);
438 return 0;
442 /* ffebld_constant_is_magical -- Determine if integer is "magical"
444 ffebldConstant c;
445 if (ffebld_constant_is_magical(c))
446 // it is 2**(n-1), where n is # bits in ffetargetIntegerDefault type
447 // (this test is important for 2's-complement machines only). */
449 bool
450 ffebld_constant_is_magical (ffebldConstant c)
452 switch (ffebld_constant_type (c))
454 case FFEBLD_constINTEGERDEFAULT:
455 return ffetarget_integerdefault_is_magical (ffebld_constant_integer1 (c));
457 default:
458 return FALSE;
462 /* Determine if constant is zero. Used to ensure step count
463 for DO loops isn't zero, also to determine if values will
464 be binary zeros, so not entirely portable at this point. */
466 bool
467 ffebld_constant_is_zero (ffebldConstant c)
469 switch (ffebld_constant_type (c))
471 #if FFETARGET_okINTEGER1
472 case FFEBLD_constINTEGER1:
473 return ffebld_constant_integer1 (c) == 0;
474 #endif
476 #if FFETARGET_okINTEGER2
477 case FFEBLD_constINTEGER2:
478 return ffebld_constant_integer2 (c) == 0;
479 #endif
481 #if FFETARGET_okINTEGER3
482 case FFEBLD_constINTEGER3:
483 return ffebld_constant_integer3 (c) == 0;
484 #endif
486 #if FFETARGET_okINTEGER4
487 case FFEBLD_constINTEGER4:
488 return ffebld_constant_integer4 (c) == 0;
489 #endif
491 #if FFETARGET_okINTEGER5
492 case FFEBLD_constINTEGER5:
493 return ffebld_constant_integer5 (c) == 0;
494 #endif
496 #if FFETARGET_okINTEGER6
497 case FFEBLD_constINTEGER6:
498 return ffebld_constant_integer6 (c) == 0;
499 #endif
501 #if FFETARGET_okINTEGER7
502 case FFEBLD_constINTEGER7:
503 return ffebld_constant_integer7 (c) == 0;
504 #endif
506 #if FFETARGET_okINTEGER8
507 case FFEBLD_constINTEGER8:
508 return ffebld_constant_integer8 (c) == 0;
509 #endif
511 #if FFETARGET_okLOGICAL1
512 case FFEBLD_constLOGICAL1:
513 return ffebld_constant_logical1 (c) == 0;
514 #endif
516 #if FFETARGET_okLOGICAL2
517 case FFEBLD_constLOGICAL2:
518 return ffebld_constant_logical2 (c) == 0;
519 #endif
521 #if FFETARGET_okLOGICAL3
522 case FFEBLD_constLOGICAL3:
523 return ffebld_constant_logical3 (c) == 0;
524 #endif
526 #if FFETARGET_okLOGICAL4
527 case FFEBLD_constLOGICAL4:
528 return ffebld_constant_logical4 (c) == 0;
529 #endif
531 #if FFETARGET_okLOGICAL5
532 case FFEBLD_constLOGICAL5:
533 return ffebld_constant_logical5 (c) == 0;
534 #endif
536 #if FFETARGET_okLOGICAL6
537 case FFEBLD_constLOGICAL6:
538 return ffebld_constant_logical6 (c) == 0;
539 #endif
541 #if FFETARGET_okLOGICAL7
542 case FFEBLD_constLOGICAL7:
543 return ffebld_constant_logical7 (c) == 0;
544 #endif
546 #if FFETARGET_okLOGICAL8
547 case FFEBLD_constLOGICAL8:
548 return ffebld_constant_logical8 (c) == 0;
549 #endif
551 #if FFETARGET_okREAL1
552 case FFEBLD_constREAL1:
553 return ffetarget_iszero_real1 (ffebld_constant_real1 (c));
554 #endif
556 #if FFETARGET_okREAL2
557 case FFEBLD_constREAL2:
558 return ffetarget_iszero_real2 (ffebld_constant_real2 (c));
559 #endif
561 #if FFETARGET_okREAL3
562 case FFEBLD_constREAL3:
563 return ffetarget_iszero_real3 (ffebld_constant_real3 (c));
564 #endif
566 #if FFETARGET_okREAL4
567 case FFEBLD_constREAL4:
568 return ffetarget_iszero_real4 (ffebld_constant_real4 (c));
569 #endif
571 #if FFETARGET_okREAL5
572 case FFEBLD_constREAL5:
573 return ffetarget_iszero_real5 (ffebld_constant_real5 (c));
574 #endif
576 #if FFETARGET_okREAL6
577 case FFEBLD_constREAL6:
578 return ffetarget_iszero_real6 (ffebld_constant_real6 (c));
579 #endif
581 #if FFETARGET_okREAL7
582 case FFEBLD_constREAL7:
583 return ffetarget_iszero_real7 (ffebld_constant_real7 (c));
584 #endif
586 #if FFETARGET_okREAL8
587 case FFEBLD_constREAL8:
588 return ffetarget_iszero_real8 (ffebld_constant_real8 (c));
589 #endif
591 #if FFETARGET_okCOMPLEX1
592 case FFEBLD_constCOMPLEX1:
593 return ffetarget_iszero_real1 (ffebld_constant_complex1 (c).real)
594 && ffetarget_iszero_real1 (ffebld_constant_complex1 (c).imaginary);
595 #endif
597 #if FFETARGET_okCOMPLEX2
598 case FFEBLD_constCOMPLEX2:
599 return ffetarget_iszero_real2 (ffebld_constant_complex2 (c).real)
600 && ffetarget_iszero_real2 (ffebld_constant_complex2 (c).imaginary);
601 #endif
603 #if FFETARGET_okCOMPLEX3
604 case FFEBLD_constCOMPLEX3:
605 return ffetarget_iszero_real3 (ffebld_constant_complex3 (c).real)
606 && ffetarget_iszero_real3 (ffebld_constant_complex3 (c).imaginary);
607 #endif
609 #if FFETARGET_okCOMPLEX4
610 case FFEBLD_constCOMPLEX4:
611 return ffetarget_iszero_real4 (ffebld_constant_complex4 (c).real)
612 && ffetarget_iszero_real4 (ffebld_constant_complex4 (c).imaginary);
613 #endif
615 #if FFETARGET_okCOMPLEX5
616 case FFEBLD_constCOMPLEX5:
617 return ffetarget_iszero_real5 (ffebld_constant_complex5 (c).real)
618 && ffetarget_iszero_real5 (ffebld_constant_complex5 (c).imaginary);
619 #endif
621 #if FFETARGET_okCOMPLEX6
622 case FFEBLD_constCOMPLEX6:
623 return ffetarget_iszero_real6 (ffebld_constant_complex6 (c).real)
624 && ffetarget_iszero_real6 (ffebld_constant_complex6 (c).imaginary);
625 #endif
627 #if FFETARGET_okCOMPLEX7
628 case FFEBLD_constCOMPLEX7:
629 return ffetarget_iszero_real7 (ffebld_constant_complex7 (c).real)
630 && ffetarget_iszero_real7 (ffebld_constant_complex7 (c).imaginary);
631 #endif
633 #if FFETARGET_okCOMPLEX8
634 case FFEBLD_constCOMPLEX8:
635 return ffetarget_iszero_real8 (ffebld_constant_complex8 (c).real)
636 && ffetarget_iszero_real8 (ffebld_constant_complex8 (c).imaginary);
637 #endif
639 #if FFETARGET_okCHARACTER1
640 case FFEBLD_constCHARACTER1:
641 return ffetarget_iszero_character1 (ffebld_constant_character1 (c));
642 #endif
644 #if FFETARGET_okCHARACTER2 || FFETARGET_okCHARACTER3 /* ... */
645 #error "no support for these!!"
646 #endif
648 case FFEBLD_constHOLLERITH:
649 return ffetarget_iszero_hollerith (ffebld_constant_hollerith (c));
651 case FFEBLD_constBINARY_MIL:
652 case FFEBLD_constBINARY_VXT:
653 case FFEBLD_constOCTAL_MIL:
654 case FFEBLD_constOCTAL_VXT:
655 case FFEBLD_constHEX_X_MIL:
656 case FFEBLD_constHEX_X_VXT:
657 case FFEBLD_constHEX_Z_MIL:
658 case FFEBLD_constHEX_Z_VXT:
659 return ffetarget_iszero_typeless (ffebld_constant_typeless (c));
661 default:
662 return FALSE;
666 /* ffebld_constant_new_character1 -- Return character1 constant object from token
668 See prototype. */
670 #if FFETARGET_okCHARACTER1
671 ffebldConstant
672 ffebld_constant_new_character1 (ffelexToken t)
674 ffetargetCharacter1 val;
676 ffetarget_character1 (&val, t, ffebld_constant_pool());
677 return ffebld_constant_new_character1_val (val);
680 #endif
681 /* ffebld_constant_new_character1_val -- Return an character1 constant object
683 See prototype. */
685 #if FFETARGET_okCHARACTER1
686 ffebldConstant
687 ffebld_constant_new_character1_val (ffetargetCharacter1 val)
689 ffebldConstant c;
690 ffebldConstant nc;
691 int cmp;
693 ffetarget_verify_character1 (ffebld_constant_pool(), val);
695 for (c = (ffebldConstant) &ffebld_constant_character1_;
696 c->next != NULL;
697 c = c->next)
699 malloc_verify_kp (ffebld_constant_pool(),
700 c->next,
701 sizeof (*(c->next)));
702 ffetarget_verify_character1 (ffebld_constant_pool(),
703 ffebld_constant_character1 (c->next));
704 cmp = ffetarget_cmp_character1 (val,
705 ffebld_constant_character1 (c->next));
706 if (cmp == 0)
707 return c->next;
708 if (cmp > 0)
709 break;
712 nc = malloc_new_kp (ffebld_constant_pool(),
713 "FFEBLD_constCHARACTER1",
714 sizeof (*nc));
715 nc->next = c->next;
716 nc->consttype = FFEBLD_constCHARACTER1;
717 nc->u.character1 = val;
718 #ifdef FFECOM_constantHOOK
719 nc->hook = FFECOM_constantNULL;
720 #endif
721 c->next = nc;
723 return nc;
726 #endif
727 /* ffebld_constant_new_complex1 -- Return complex1 constant object from token
729 See prototype. */
731 #if FFETARGET_okCOMPLEX1
732 ffebldConstant
733 ffebld_constant_new_complex1 (ffebldConstant real,
734 ffebldConstant imaginary)
736 ffetargetComplex1 val;
738 val.real = ffebld_constant_real1 (real);
739 val.imaginary = ffebld_constant_real1 (imaginary);
740 return ffebld_constant_new_complex1_val (val);
743 #endif
744 /* ffebld_constant_new_complex1_val -- Return a complex1 constant object
746 See prototype. */
748 #if FFETARGET_okCOMPLEX1
749 ffebldConstant
750 ffebld_constant_new_complex1_val (ffetargetComplex1 val)
752 ffebldConstant c;
753 ffebldConstant nc;
754 int cmp;
756 for (c = (ffebldConstant) &ffebld_constant_complex1_;
757 c->next != NULL;
758 c = c->next)
760 cmp = ffetarget_cmp_real1 (val.real, ffebld_constant_complex1 (c->next).real);
761 if (cmp == 0)
762 cmp = ffetarget_cmp_real1 (val.imaginary,
763 ffebld_constant_complex1 (c->next).imaginary);
764 if (cmp == 0)
765 return c->next;
766 if (cmp > 0)
767 break;
770 nc = malloc_new_kp (ffebld_constant_pool(),
771 "FFEBLD_constCOMPLEX1",
772 sizeof (*nc));
773 nc->next = c->next;
774 nc->consttype = FFEBLD_constCOMPLEX1;
775 nc->u.complex1 = val;
776 #ifdef FFECOM_constantHOOK
777 nc->hook = FFECOM_constantNULL;
778 #endif
779 c->next = nc;
781 return nc;
784 #endif
785 /* ffebld_constant_new_complex2 -- Return complex2 constant object from token
787 See prototype. */
789 #if FFETARGET_okCOMPLEX2
790 ffebldConstant
791 ffebld_constant_new_complex2 (ffebldConstant real,
792 ffebldConstant imaginary)
794 ffetargetComplex2 val;
796 val.real = ffebld_constant_real2 (real);
797 val.imaginary = ffebld_constant_real2 (imaginary);
798 return ffebld_constant_new_complex2_val (val);
801 #endif
802 /* ffebld_constant_new_complex2_val -- Return a complex2 constant object
804 See prototype. */
806 #if FFETARGET_okCOMPLEX2
807 ffebldConstant
808 ffebld_constant_new_complex2_val (ffetargetComplex2 val)
810 ffebldConstant c;
811 ffebldConstant nc;
812 int cmp;
814 for (c = (ffebldConstant) &ffebld_constant_complex2_;
815 c->next != NULL;
816 c = c->next)
818 cmp = ffetarget_cmp_real2 (val.real, ffebld_constant_complex2 (c->next).real);
819 if (cmp == 0)
820 cmp = ffetarget_cmp_real2 (val.imaginary,
821 ffebld_constant_complex2 (c->next).imaginary);
822 if (cmp == 0)
823 return c->next;
824 if (cmp > 0)
825 break;
828 nc = malloc_new_kp (ffebld_constant_pool(),
829 "FFEBLD_constCOMPLEX2",
830 sizeof (*nc));
831 nc->next = c->next;
832 nc->consttype = FFEBLD_constCOMPLEX2;
833 nc->u.complex2 = val;
834 #ifdef FFECOM_constantHOOK
835 nc->hook = FFECOM_constantNULL;
836 #endif
837 c->next = nc;
839 return nc;
842 #endif
843 /* ffebld_constant_new_hollerith -- Return hollerith constant object from token
845 See prototype. */
847 ffebldConstant
848 ffebld_constant_new_hollerith (ffelexToken t)
850 ffetargetHollerith val;
852 ffetarget_hollerith (&val, t, ffebld_constant_pool());
853 return ffebld_constant_new_hollerith_val (val);
856 /* ffebld_constant_new_hollerith_val -- Return an hollerith constant object
858 See prototype. */
860 ffebldConstant
861 ffebld_constant_new_hollerith_val (ffetargetHollerith val)
863 ffebldConstant c;
864 ffebldConstant nc;
865 int cmp;
867 for (c = (ffebldConstant) &ffebld_constant_hollerith_;
868 c->next != NULL;
869 c = c->next)
871 cmp = ffetarget_cmp_hollerith (val, ffebld_constant_hollerith (c->next));
872 if (cmp == 0)
873 return c->next;
874 if (cmp > 0)
875 break;
878 nc = malloc_new_kp (ffebld_constant_pool(),
879 "FFEBLD_constHOLLERITH",
880 sizeof (*nc));
881 nc->next = c->next;
882 nc->consttype = FFEBLD_constHOLLERITH;
883 nc->u.hollerith = val;
884 #ifdef FFECOM_constantHOOK
885 nc->hook = FFECOM_constantNULL;
886 #endif
887 c->next = nc;
889 return nc;
892 /* ffebld_constant_new_integer1 -- Return integer1 constant object from token
894 See prototype.
896 Parses the token as a decimal integer constant, thus it must be an
897 FFELEX_typeNUMBER. */
899 #if FFETARGET_okINTEGER1
900 ffebldConstant
901 ffebld_constant_new_integer1 (ffelexToken t)
903 ffetargetInteger1 val;
905 assert (ffelex_token_type (t) == FFELEX_typeNUMBER);
907 ffetarget_integer1 (&val, t);
908 return ffebld_constant_new_integer1_val (val);
911 #endif
912 /* ffebld_constant_new_integer1_val -- Return an integer1 constant object
914 See prototype. */
916 #if FFETARGET_okINTEGER1
917 ffebldConstant
918 ffebld_constant_new_integer1_val (ffetargetInteger1 val)
920 ffebldConstant c;
921 ffebldConstant nc;
922 int cmp;
924 for (c = (ffebldConstant) &ffebld_constant_integer1_;
925 c->next != NULL;
926 c = c->next)
928 cmp = ffetarget_cmp_integer1 (val, ffebld_constant_integer1 (c->next));
929 if (cmp == 0)
930 return c->next;
931 if (cmp > 0)
932 break;
935 nc = malloc_new_kp (ffebld_constant_pool(),
936 "FFEBLD_constINTEGER1",
937 sizeof (*nc));
938 nc->next = c->next;
939 nc->consttype = FFEBLD_constINTEGER1;
940 nc->u.integer1 = val;
941 #ifdef FFECOM_constantHOOK
942 nc->hook = FFECOM_constantNULL;
943 #endif
944 c->next = nc;
946 return nc;
949 #endif
950 /* ffebld_constant_new_integer2_val -- Return an integer2 constant object
952 See prototype. */
954 #if FFETARGET_okINTEGER2
955 ffebldConstant
956 ffebld_constant_new_integer2_val (ffetargetInteger2 val)
958 ffebldConstant c;
959 ffebldConstant nc;
960 int cmp;
962 for (c = (ffebldConstant) &ffebld_constant_integer2_;
963 c->next != NULL;
964 c = c->next)
966 cmp = ffetarget_cmp_integer2 (val, ffebld_constant_integer2 (c->next));
967 if (cmp == 0)
968 return c->next;
969 if (cmp > 0)
970 break;
973 nc = malloc_new_kp (ffebld_constant_pool(),
974 "FFEBLD_constINTEGER2",
975 sizeof (*nc));
976 nc->next = c->next;
977 nc->consttype = FFEBLD_constINTEGER2;
978 nc->u.integer2 = val;
979 #ifdef FFECOM_constantHOOK
980 nc->hook = FFECOM_constantNULL;
981 #endif
982 c->next = nc;
984 return nc;
987 #endif
988 /* ffebld_constant_new_integer3_val -- Return an integer3 constant object
990 See prototype. */
992 #if FFETARGET_okINTEGER3
993 ffebldConstant
994 ffebld_constant_new_integer3_val (ffetargetInteger3 val)
996 ffebldConstant c;
997 ffebldConstant nc;
998 int cmp;
1000 for (c = (ffebldConstant) &ffebld_constant_integer3_;
1001 c->next != NULL;
1002 c = c->next)
1004 cmp = ffetarget_cmp_integer3 (val, ffebld_constant_integer3 (c->next));
1005 if (cmp == 0)
1006 return c->next;
1007 if (cmp > 0)
1008 break;
1011 nc = malloc_new_kp (ffebld_constant_pool(),
1012 "FFEBLD_constINTEGER3",
1013 sizeof (*nc));
1014 nc->next = c->next;
1015 nc->consttype = FFEBLD_constINTEGER3;
1016 nc->u.integer3 = val;
1017 #ifdef FFECOM_constantHOOK
1018 nc->hook = FFECOM_constantNULL;
1019 #endif
1020 c->next = nc;
1022 return nc;
1025 #endif
1026 /* ffebld_constant_new_integer4_val -- Return an integer4 constant object
1028 See prototype. */
1030 #if FFETARGET_okINTEGER4
1031 ffebldConstant
1032 ffebld_constant_new_integer4_val (ffetargetInteger4 val)
1034 ffebldConstant c;
1035 ffebldConstant nc;
1036 int cmp;
1038 for (c = (ffebldConstant) &ffebld_constant_integer4_;
1039 c->next != NULL;
1040 c = c->next)
1042 cmp = ffetarget_cmp_integer4 (val, ffebld_constant_integer4 (c->next));
1043 if (cmp == 0)
1044 return c->next;
1045 if (cmp > 0)
1046 break;
1049 nc = malloc_new_kp (ffebld_constant_pool(),
1050 "FFEBLD_constINTEGER4",
1051 sizeof (*nc));
1052 nc->next = c->next;
1053 nc->consttype = FFEBLD_constINTEGER4;
1054 nc->u.integer4 = val;
1055 #ifdef FFECOM_constantHOOK
1056 nc->hook = FFECOM_constantNULL;
1057 #endif
1058 c->next = nc;
1060 return nc;
1063 #endif
1064 /* ffebld_constant_new_integerbinary -- Return binary constant object from token
1066 See prototype.
1068 Parses the token as a binary integer constant, thus it must be an
1069 FFELEX_typeNUMBER. */
1071 ffebldConstant
1072 ffebld_constant_new_integerbinary (ffelexToken t)
1074 ffetargetIntegerDefault val;
1076 assert ((ffelex_token_type (t) == FFELEX_typeNAME)
1077 || (ffelex_token_type (t) == FFELEX_typeNUMBER));
1079 ffetarget_integerbinary (&val, t);
1080 return ffebld_constant_new_integerdefault_val (val);
1083 /* ffebld_constant_new_integerhex -- Return hex constant object from token
1085 See prototype.
1087 Parses the token as a hex integer constant, thus it must be an
1088 FFELEX_typeNUMBER. */
1090 ffebldConstant
1091 ffebld_constant_new_integerhex (ffelexToken t)
1093 ffetargetIntegerDefault val;
1095 assert ((ffelex_token_type (t) == FFELEX_typeNAME)
1096 || (ffelex_token_type (t) == FFELEX_typeNUMBER));
1098 ffetarget_integerhex (&val, t);
1099 return ffebld_constant_new_integerdefault_val (val);
1102 /* ffebld_constant_new_integeroctal -- Return octal constant object from token
1104 See prototype.
1106 Parses the token as a octal integer constant, thus it must be an
1107 FFELEX_typeNUMBER. */
1109 ffebldConstant
1110 ffebld_constant_new_integeroctal (ffelexToken t)
1112 ffetargetIntegerDefault val;
1114 assert ((ffelex_token_type (t) == FFELEX_typeNAME)
1115 || (ffelex_token_type (t) == FFELEX_typeNUMBER));
1117 ffetarget_integeroctal (&val, t);
1118 return ffebld_constant_new_integerdefault_val (val);
1121 /* ffebld_constant_new_logical1 -- Return logical1 constant object from token
1123 See prototype.
1125 Parses the token as a decimal logical constant, thus it must be an
1126 FFELEX_typeNUMBER. */
1128 #if FFETARGET_okLOGICAL1
1129 ffebldConstant
1130 ffebld_constant_new_logical1 (bool truth)
1132 ffetargetLogical1 val;
1134 ffetarget_logical1 (&val, truth);
1135 return ffebld_constant_new_logical1_val (val);
1138 #endif
1139 /* ffebld_constant_new_logical1_val -- Return a logical1 constant object
1141 See prototype. */
1143 #if FFETARGET_okLOGICAL1
1144 ffebldConstant
1145 ffebld_constant_new_logical1_val (ffetargetLogical1 val)
1147 ffebldConstant c;
1148 ffebldConstant nc;
1149 int cmp;
1151 for (c = (ffebldConstant) &ffebld_constant_logical1_;
1152 c->next != NULL;
1153 c = c->next)
1155 cmp = ffetarget_cmp_logical1 (val, ffebld_constant_logical1 (c->next));
1156 if (cmp == 0)
1157 return c->next;
1158 if (cmp > 0)
1159 break;
1162 nc = malloc_new_kp (ffebld_constant_pool(),
1163 "FFEBLD_constLOGICAL1",
1164 sizeof (*nc));
1165 nc->next = c->next;
1166 nc->consttype = FFEBLD_constLOGICAL1;
1167 nc->u.logical1 = val;
1168 #ifdef FFECOM_constantHOOK
1169 nc->hook = FFECOM_constantNULL;
1170 #endif
1171 c->next = nc;
1173 return nc;
1176 #endif
1177 /* ffebld_constant_new_logical2_val -- Return a logical2 constant object
1179 See prototype. */
1181 #if FFETARGET_okLOGICAL2
1182 ffebldConstant
1183 ffebld_constant_new_logical2_val (ffetargetLogical2 val)
1185 ffebldConstant c;
1186 ffebldConstant nc;
1187 int cmp;
1189 for (c = (ffebldConstant) &ffebld_constant_logical2_;
1190 c->next != NULL;
1191 c = c->next)
1193 cmp = ffetarget_cmp_logical2 (val, ffebld_constant_logical2 (c->next));
1194 if (cmp == 0)
1195 return c->next;
1196 if (cmp > 0)
1197 break;
1200 nc = malloc_new_kp (ffebld_constant_pool(),
1201 "FFEBLD_constLOGICAL2",
1202 sizeof (*nc));
1203 nc->next = c->next;
1204 nc->consttype = FFEBLD_constLOGICAL2;
1205 nc->u.logical2 = val;
1206 #ifdef FFECOM_constantHOOK
1207 nc->hook = FFECOM_constantNULL;
1208 #endif
1209 c->next = nc;
1211 return nc;
1214 #endif
1215 /* ffebld_constant_new_logical3_val -- Return a logical3 constant object
1217 See prototype. */
1219 #if FFETARGET_okLOGICAL3
1220 ffebldConstant
1221 ffebld_constant_new_logical3_val (ffetargetLogical3 val)
1223 ffebldConstant c;
1224 ffebldConstant nc;
1225 int cmp;
1227 for (c = (ffebldConstant) &ffebld_constant_logical3_;
1228 c->next != NULL;
1229 c = c->next)
1231 cmp = ffetarget_cmp_logical3 (val, ffebld_constant_logical3 (c->next));
1232 if (cmp == 0)
1233 return c->next;
1234 if (cmp > 0)
1235 break;
1238 nc = malloc_new_kp (ffebld_constant_pool(),
1239 "FFEBLD_constLOGICAL3",
1240 sizeof (*nc));
1241 nc->next = c->next;
1242 nc->consttype = FFEBLD_constLOGICAL3;
1243 nc->u.logical3 = val;
1244 #ifdef FFECOM_constantHOOK
1245 nc->hook = FFECOM_constantNULL;
1246 #endif
1247 c->next = nc;
1249 return nc;
1252 #endif
1253 /* ffebld_constant_new_logical4_val -- Return a logical4 constant object
1255 See prototype. */
1257 #if FFETARGET_okLOGICAL4
1258 ffebldConstant
1259 ffebld_constant_new_logical4_val (ffetargetLogical4 val)
1261 ffebldConstant c;
1262 ffebldConstant nc;
1263 int cmp;
1265 for (c = (ffebldConstant) &ffebld_constant_logical4_;
1266 c->next != NULL;
1267 c = c->next)
1269 cmp = ffetarget_cmp_logical4 (val, ffebld_constant_logical4 (c->next));
1270 if (cmp == 0)
1271 return c->next;
1272 if (cmp > 0)
1273 break;
1276 nc = malloc_new_kp (ffebld_constant_pool(),
1277 "FFEBLD_constLOGICAL4",
1278 sizeof (*nc));
1279 nc->next = c->next;
1280 nc->consttype = FFEBLD_constLOGICAL4;
1281 nc->u.logical4 = val;
1282 #ifdef FFECOM_constantHOOK
1283 nc->hook = FFECOM_constantNULL;
1284 #endif
1285 c->next = nc;
1287 return nc;
1290 #endif
1291 /* ffebld_constant_new_real1 -- Return real1 constant object from token
1293 See prototype. */
1295 #if FFETARGET_okREAL1
1296 ffebldConstant
1297 ffebld_constant_new_real1 (ffelexToken integer, ffelexToken decimal,
1298 ffelexToken fraction, ffelexToken exponent, ffelexToken exponent_sign,
1299 ffelexToken exponent_digits)
1301 ffetargetReal1 val;
1303 ffetarget_real1 (&val,
1304 integer, decimal, fraction, exponent, exponent_sign, exponent_digits);
1305 return ffebld_constant_new_real1_val (val);
1308 #endif
1309 /* ffebld_constant_new_real1_val -- Return an real1 constant object
1311 See prototype. */
1313 #if FFETARGET_okREAL1
1314 ffebldConstant
1315 ffebld_constant_new_real1_val (ffetargetReal1 val)
1317 ffebldConstant c;
1318 ffebldConstant nc;
1319 int cmp;
1321 for (c = (ffebldConstant) &ffebld_constant_real1_;
1322 c->next != NULL;
1323 c = c->next)
1325 cmp = ffetarget_cmp_real1 (val, ffebld_constant_real1 (c->next));
1326 if (cmp == 0)
1327 return c->next;
1328 if (cmp > 0)
1329 break;
1332 nc = malloc_new_kp (ffebld_constant_pool(),
1333 "FFEBLD_constREAL1",
1334 sizeof (*nc));
1335 nc->next = c->next;
1336 nc->consttype = FFEBLD_constREAL1;
1337 nc->u.real1 = val;
1338 #ifdef FFECOM_constantHOOK
1339 nc->hook = FFECOM_constantNULL;
1340 #endif
1341 c->next = nc;
1343 return nc;
1346 #endif
1347 /* ffebld_constant_new_real2 -- Return real2 constant object from token
1349 See prototype. */
1351 #if FFETARGET_okREAL2
1352 ffebldConstant
1353 ffebld_constant_new_real2 (ffelexToken integer, ffelexToken decimal,
1354 ffelexToken fraction, ffelexToken exponent, ffelexToken exponent_sign,
1355 ffelexToken exponent_digits)
1357 ffetargetReal2 val;
1359 ffetarget_real2 (&val,
1360 integer, decimal, fraction, exponent, exponent_sign, exponent_digits);
1361 return ffebld_constant_new_real2_val (val);
1364 #endif
1365 /* ffebld_constant_new_real2_val -- Return an real2 constant object
1367 See prototype. */
1369 #if FFETARGET_okREAL2
1370 ffebldConstant
1371 ffebld_constant_new_real2_val (ffetargetReal2 val)
1373 ffebldConstant c;
1374 ffebldConstant nc;
1375 int cmp;
1377 for (c = (ffebldConstant) &ffebld_constant_real2_;
1378 c->next != NULL;
1379 c = c->next)
1381 cmp = ffetarget_cmp_real2 (val, ffebld_constant_real2 (c->next));
1382 if (cmp == 0)
1383 return c->next;
1384 if (cmp > 0)
1385 break;
1388 nc = malloc_new_kp (ffebld_constant_pool(),
1389 "FFEBLD_constREAL2",
1390 sizeof (*nc));
1391 nc->next = c->next;
1392 nc->consttype = FFEBLD_constREAL2;
1393 nc->u.real2 = val;
1394 #ifdef FFECOM_constantHOOK
1395 nc->hook = FFECOM_constantNULL;
1396 #endif
1397 c->next = nc;
1399 return nc;
1402 #endif
1403 /* ffebld_constant_new_typeless_bm -- Return typeless constant object from token
1405 See prototype.
1407 Parses the token as a decimal integer constant, thus it must be an
1408 FFELEX_typeNUMBER. */
1410 ffebldConstant
1411 ffebld_constant_new_typeless_bm (ffelexToken t)
1413 ffetargetTypeless val;
1415 ffetarget_binarymil (&val, t);
1416 return ffebld_constant_new_typeless_val (FFEBLD_constBINARY_MIL, val);
1419 /* ffebld_constant_new_typeless_bv -- Return typeless constant object from token
1421 See prototype.
1423 Parses the token as a decimal integer constant, thus it must be an
1424 FFELEX_typeNUMBER. */
1426 ffebldConstant
1427 ffebld_constant_new_typeless_bv (ffelexToken t)
1429 ffetargetTypeless val;
1431 ffetarget_binaryvxt (&val, t);
1432 return ffebld_constant_new_typeless_val (FFEBLD_constBINARY_VXT, val);
1435 /* ffebld_constant_new_typeless_hxm -- Return typeless constant object from token
1437 See prototype.
1439 Parses the token as a decimal integer constant, thus it must be an
1440 FFELEX_typeNUMBER. */
1442 ffebldConstant
1443 ffebld_constant_new_typeless_hxm (ffelexToken t)
1445 ffetargetTypeless val;
1447 ffetarget_hexxmil (&val, t);
1448 return ffebld_constant_new_typeless_val (FFEBLD_constHEX_X_MIL, val);
1451 /* ffebld_constant_new_typeless_hxv -- Return typeless constant object from token
1453 See prototype.
1455 Parses the token as a decimal integer constant, thus it must be an
1456 FFELEX_typeNUMBER. */
1458 ffebldConstant
1459 ffebld_constant_new_typeless_hxv (ffelexToken t)
1461 ffetargetTypeless val;
1463 ffetarget_hexxvxt (&val, t);
1464 return ffebld_constant_new_typeless_val (FFEBLD_constHEX_X_VXT, val);
1467 /* ffebld_constant_new_typeless_hzm -- Return typeless constant object from token
1469 See prototype.
1471 Parses the token as a decimal integer constant, thus it must be an
1472 FFELEX_typeNUMBER. */
1474 ffebldConstant
1475 ffebld_constant_new_typeless_hzm (ffelexToken t)
1477 ffetargetTypeless val;
1479 ffetarget_hexzmil (&val, t);
1480 return ffebld_constant_new_typeless_val (FFEBLD_constHEX_Z_MIL, val);
1483 /* ffebld_constant_new_typeless_hzv -- Return typeless constant object from token
1485 See prototype.
1487 Parses the token as a decimal integer constant, thus it must be an
1488 FFELEX_typeNUMBER. */
1490 ffebldConstant
1491 ffebld_constant_new_typeless_hzv (ffelexToken t)
1493 ffetargetTypeless val;
1495 ffetarget_hexzvxt (&val, t);
1496 return ffebld_constant_new_typeless_val (FFEBLD_constHEX_Z_VXT, val);
1499 /* ffebld_constant_new_typeless_om -- Return typeless constant object from token
1501 See prototype.
1503 Parses the token as a decimal integer constant, thus it must be an
1504 FFELEX_typeNUMBER. */
1506 ffebldConstant
1507 ffebld_constant_new_typeless_om (ffelexToken t)
1509 ffetargetTypeless val;
1511 ffetarget_octalmil (&val, t);
1512 return ffebld_constant_new_typeless_val (FFEBLD_constOCTAL_MIL, val);
1515 /* ffebld_constant_new_typeless_ov -- Return typeless constant object from token
1517 See prototype.
1519 Parses the token as a decimal integer constant, thus it must be an
1520 FFELEX_typeNUMBER. */
1522 ffebldConstant
1523 ffebld_constant_new_typeless_ov (ffelexToken t)
1525 ffetargetTypeless val;
1527 ffetarget_octalvxt (&val, t);
1528 return ffebld_constant_new_typeless_val (FFEBLD_constOCTAL_VXT, val);
1531 /* ffebld_constant_new_typeless_val -- Return a typeless constant object
1533 See prototype. */
1535 ffebldConstant
1536 ffebld_constant_new_typeless_val (ffebldConst type, ffetargetTypeless val)
1538 ffebldConstant c;
1539 ffebldConstant nc;
1540 int cmp;
1542 for (c = (ffebldConstant) &ffebld_constant_typeless_[type
1543 - FFEBLD_constTYPELESS_FIRST];
1544 c->next != NULL;
1545 c = c->next)
1547 cmp = ffetarget_cmp_typeless (val, ffebld_constant_typeless (c->next));
1548 if (cmp == 0)
1549 return c->next;
1550 if (cmp > 0)
1551 break;
1554 nc = malloc_new_kp (ffebld_constant_pool(),
1555 "FFEBLD_constTYPELESS",
1556 sizeof (*nc));
1557 nc->next = c->next;
1558 nc->consttype = type;
1559 nc->u.typeless = val;
1560 #ifdef FFECOM_constantHOOK
1561 nc->hook = FFECOM_constantNULL;
1562 #endif
1563 c->next = nc;
1565 return nc;
1568 /* ffebld_constantarray_get -- Get a value from an array of constants
1570 See prototype. */
1572 ffebldConstantUnion
1573 ffebld_constantarray_get (ffebldConstantArray array, ffeinfoBasictype bt,
1574 ffeinfoKindtype kt, ffetargetOffset offset)
1576 ffebldConstantUnion u;
1578 switch (bt)
1580 case FFEINFO_basictypeINTEGER:
1581 switch (kt)
1583 #if FFETARGET_okINTEGER1
1584 case FFEINFO_kindtypeINTEGER1:
1585 u.integer1 = *(array.integer1 + offset);
1586 break;
1587 #endif
1589 #if FFETARGET_okINTEGER2
1590 case FFEINFO_kindtypeINTEGER2:
1591 u.integer2 = *(array.integer2 + offset);
1592 break;
1593 #endif
1595 #if FFETARGET_okINTEGER3
1596 case FFEINFO_kindtypeINTEGER3:
1597 u.integer3 = *(array.integer3 + offset);
1598 break;
1599 #endif
1601 #if FFETARGET_okINTEGER4
1602 case FFEINFO_kindtypeINTEGER4:
1603 u.integer4 = *(array.integer4 + offset);
1604 break;
1605 #endif
1607 #if FFETARGET_okINTEGER5
1608 case FFEINFO_kindtypeINTEGER5:
1609 u.integer5 = *(array.integer5 + offset);
1610 break;
1611 #endif
1613 #if FFETARGET_okINTEGER6
1614 case FFEINFO_kindtypeINTEGER6:
1615 u.integer6 = *(array.integer6 + offset);
1616 break;
1617 #endif
1619 #if FFETARGET_okINTEGER7
1620 case FFEINFO_kindtypeINTEGER7:
1621 u.integer7 = *(array.integer7 + offset);
1622 break;
1623 #endif
1625 #if FFETARGET_okINTEGER8
1626 case FFEINFO_kindtypeINTEGER8:
1627 u.integer8 = *(array.integer8 + offset);
1628 break;
1629 #endif
1631 default:
1632 assert ("bad INTEGER kindtype" == NULL);
1633 break;
1635 break;
1637 case FFEINFO_basictypeLOGICAL:
1638 switch (kt)
1640 #if FFETARGET_okLOGICAL1
1641 case FFEINFO_kindtypeLOGICAL1:
1642 u.logical1 = *(array.logical1 + offset);
1643 break;
1644 #endif
1646 #if FFETARGET_okLOGICAL2
1647 case FFEINFO_kindtypeLOGICAL2:
1648 u.logical2 = *(array.logical2 + offset);
1649 break;
1650 #endif
1652 #if FFETARGET_okLOGICAL3
1653 case FFEINFO_kindtypeLOGICAL3:
1654 u.logical3 = *(array.logical3 + offset);
1655 break;
1656 #endif
1658 #if FFETARGET_okLOGICAL4
1659 case FFEINFO_kindtypeLOGICAL4:
1660 u.logical4 = *(array.logical4 + offset);
1661 break;
1662 #endif
1664 #if FFETARGET_okLOGICAL5
1665 case FFEINFO_kindtypeLOGICAL5:
1666 u.logical5 = *(array.logical5 + offset);
1667 break;
1668 #endif
1670 #if FFETARGET_okLOGICAL6
1671 case FFEINFO_kindtypeLOGICAL6:
1672 u.logical6 = *(array.logical6 + offset);
1673 break;
1674 #endif
1676 #if FFETARGET_okLOGICAL7
1677 case FFEINFO_kindtypeLOGICAL7:
1678 u.logical7 = *(array.logical7 + offset);
1679 break;
1680 #endif
1682 #if FFETARGET_okLOGICAL8
1683 case FFEINFO_kindtypeLOGICAL8:
1684 u.logical8 = *(array.logical8 + offset);
1685 break;
1686 #endif
1688 default:
1689 assert ("bad LOGICAL kindtype" == NULL);
1690 break;
1692 break;
1694 case FFEINFO_basictypeREAL:
1695 switch (kt)
1697 #if FFETARGET_okREAL1
1698 case FFEINFO_kindtypeREAL1:
1699 u.real1 = *(array.real1 + offset);
1700 break;
1701 #endif
1703 #if FFETARGET_okREAL2
1704 case FFEINFO_kindtypeREAL2:
1705 u.real2 = *(array.real2 + offset);
1706 break;
1707 #endif
1709 #if FFETARGET_okREAL3
1710 case FFEINFO_kindtypeREAL3:
1711 u.real3 = *(array.real3 + offset);
1712 break;
1713 #endif
1715 #if FFETARGET_okREAL4
1716 case FFEINFO_kindtypeREAL4:
1717 u.real4 = *(array.real4 + offset);
1718 break;
1719 #endif
1721 #if FFETARGET_okREAL5
1722 case FFEINFO_kindtypeREAL5:
1723 u.real5 = *(array.real5 + offset);
1724 break;
1725 #endif
1727 #if FFETARGET_okREAL6
1728 case FFEINFO_kindtypeREAL6:
1729 u.real6 = *(array.real6 + offset);
1730 break;
1731 #endif
1733 #if FFETARGET_okREAL7
1734 case FFEINFO_kindtypeREAL7:
1735 u.real7 = *(array.real7 + offset);
1736 break;
1737 #endif
1739 #if FFETARGET_okREAL8
1740 case FFEINFO_kindtypeREAL8:
1741 u.real8 = *(array.real8 + offset);
1742 break;
1743 #endif
1745 default:
1746 assert ("bad REAL kindtype" == NULL);
1747 break;
1749 break;
1751 case FFEINFO_basictypeCOMPLEX:
1752 switch (kt)
1754 #if FFETARGET_okCOMPLEX1
1755 case FFEINFO_kindtypeREAL1:
1756 u.complex1 = *(array.complex1 + offset);
1757 break;
1758 #endif
1760 #if FFETARGET_okCOMPLEX2
1761 case FFEINFO_kindtypeREAL2:
1762 u.complex2 = *(array.complex2 + offset);
1763 break;
1764 #endif
1766 #if FFETARGET_okCOMPLEX3
1767 case FFEINFO_kindtypeREAL3:
1768 u.complex3 = *(array.complex3 + offset);
1769 break;
1770 #endif
1772 #if FFETARGET_okCOMPLEX4
1773 case FFEINFO_kindtypeREAL4:
1774 u.complex4 = *(array.complex4 + offset);
1775 break;
1776 #endif
1778 #if FFETARGET_okCOMPLEX5
1779 case FFEINFO_kindtypeREAL5:
1780 u.complex5 = *(array.complex5 + offset);
1781 break;
1782 #endif
1784 #if FFETARGET_okCOMPLEX6
1785 case FFEINFO_kindtypeREAL6:
1786 u.complex6 = *(array.complex6 + offset);
1787 break;
1788 #endif
1790 #if FFETARGET_okCOMPLEX7
1791 case FFEINFO_kindtypeREAL7:
1792 u.complex7 = *(array.complex7 + offset);
1793 break;
1794 #endif
1796 #if FFETARGET_okCOMPLEX8
1797 case FFEINFO_kindtypeREAL8:
1798 u.complex8 = *(array.complex8 + offset);
1799 break;
1800 #endif
1802 default:
1803 assert ("bad COMPLEX kindtype" == NULL);
1804 break;
1806 break;
1808 case FFEINFO_basictypeCHARACTER:
1809 switch (kt)
1811 #if FFETARGET_okCHARACTER1
1812 case FFEINFO_kindtypeCHARACTER1:
1813 u.character1.length = 1;
1814 u.character1.text = array.character1 + offset;
1815 break;
1816 #endif
1818 #if FFETARGET_okCHARACTER2
1819 case FFEINFO_kindtypeCHARACTER2:
1820 u.character2.length = 1;
1821 u.character2.text = array.character2 + offset;
1822 break;
1823 #endif
1825 #if FFETARGET_okCHARACTER3
1826 case FFEINFO_kindtypeCHARACTER3:
1827 u.character3.length = 1;
1828 u.character3.text = array.character3 + offset;
1829 break;
1830 #endif
1832 #if FFETARGET_okCHARACTER4
1833 case FFEINFO_kindtypeCHARACTER4:
1834 u.character4.length = 1;
1835 u.character4.text = array.character4 + offset;
1836 break;
1837 #endif
1839 #if FFETARGET_okCHARACTER5
1840 case FFEINFO_kindtypeCHARACTER5:
1841 u.character5.length = 1;
1842 u.character5.text = array.character5 + offset;
1843 break;
1844 #endif
1846 #if FFETARGET_okCHARACTER6
1847 case FFEINFO_kindtypeCHARACTER6:
1848 u.character6.length = 1;
1849 u.character6.text = array.character6 + offset;
1850 break;
1851 #endif
1853 #if FFETARGET_okCHARACTER7
1854 case FFEINFO_kindtypeCHARACTER7:
1855 u.character7.length = 1;
1856 u.character7.text = array.character7 + offset;
1857 break;
1858 #endif
1860 #if FFETARGET_okCHARACTER8
1861 case FFEINFO_kindtypeCHARACTER8:
1862 u.character8.length = 1;
1863 u.character8.text = array.character8 + offset;
1864 break;
1865 #endif
1867 default:
1868 assert ("bad CHARACTER kindtype" == NULL);
1869 break;
1871 break;
1873 default:
1874 assert ("bad basictype" == NULL);
1875 break;
1878 return u;
1881 /* ffebld_constantarray_new -- Make an array of constants
1883 See prototype. */
1885 ffebldConstantArray
1886 ffebld_constantarray_new (ffeinfoBasictype bt,
1887 ffeinfoKindtype kt, ffetargetOffset size)
1889 ffebldConstantArray ptr;
1891 switch (bt)
1893 case FFEINFO_basictypeINTEGER:
1894 switch (kt)
1896 #if FFETARGET_okINTEGER1
1897 case FFEINFO_kindtypeINTEGER1:
1898 ptr.integer1 = malloc_new_zkp (ffebld_constant_pool(),
1899 "ffebldConstantArray",
1900 size *= sizeof (ffetargetInteger1),
1902 break;
1903 #endif
1905 #if FFETARGET_okINTEGER2
1906 case FFEINFO_kindtypeINTEGER2:
1907 ptr.integer2 = malloc_new_zkp (ffebld_constant_pool(),
1908 "ffebldConstantArray",
1909 size *= sizeof (ffetargetInteger2),
1911 break;
1912 #endif
1914 #if FFETARGET_okINTEGER3
1915 case FFEINFO_kindtypeINTEGER3:
1916 ptr.integer3 = malloc_new_zkp (ffebld_constant_pool(),
1917 "ffebldConstantArray",
1918 size *= sizeof (ffetargetInteger3),
1920 break;
1921 #endif
1923 #if FFETARGET_okINTEGER4
1924 case FFEINFO_kindtypeINTEGER4:
1925 ptr.integer4 = malloc_new_zkp (ffebld_constant_pool(),
1926 "ffebldConstantArray",
1927 size *= sizeof (ffetargetInteger4),
1929 break;
1930 #endif
1932 #if FFETARGET_okINTEGER5
1933 case FFEINFO_kindtypeINTEGER5:
1934 ptr.integer5 = malloc_new_zkp (ffebld_constant_pool(),
1935 "ffebldConstantArray",
1936 size *= sizeof (ffetargetInteger5),
1938 break;
1939 #endif
1941 #if FFETARGET_okINTEGER6
1942 case FFEINFO_kindtypeINTEGER6:
1943 ptr.integer6 = malloc_new_zkp (ffebld_constant_pool(),
1944 "ffebldConstantArray",
1945 size *= sizeof (ffetargetInteger6),
1947 break;
1948 #endif
1950 #if FFETARGET_okINTEGER7
1951 case FFEINFO_kindtypeINTEGER7:
1952 ptr.integer7 = malloc_new_zkp (ffebld_constant_pool(),
1953 "ffebldConstantArray",
1954 size *= sizeof (ffetargetInteger7),
1956 break;
1957 #endif
1959 #if FFETARGET_okINTEGER8
1960 case FFEINFO_kindtypeINTEGER8:
1961 ptr.integer8 = malloc_new_zkp (ffebld_constant_pool(),
1962 "ffebldConstantArray",
1963 size *= sizeof (ffetargetInteger8),
1965 break;
1966 #endif
1968 default:
1969 assert ("bad INTEGER kindtype" == NULL);
1970 break;
1972 break;
1974 case FFEINFO_basictypeLOGICAL:
1975 switch (kt)
1977 #if FFETARGET_okLOGICAL1
1978 case FFEINFO_kindtypeLOGICAL1:
1979 ptr.logical1 = malloc_new_zkp (ffebld_constant_pool(),
1980 "ffebldConstantArray",
1981 size *= sizeof (ffetargetLogical1),
1983 break;
1984 #endif
1986 #if FFETARGET_okLOGICAL2
1987 case FFEINFO_kindtypeLOGICAL2:
1988 ptr.logical2 = malloc_new_zkp (ffebld_constant_pool(),
1989 "ffebldConstantArray",
1990 size *= sizeof (ffetargetLogical2),
1992 break;
1993 #endif
1995 #if FFETARGET_okLOGICAL3
1996 case FFEINFO_kindtypeLOGICAL3:
1997 ptr.logical3 = malloc_new_zkp (ffebld_constant_pool(),
1998 "ffebldConstantArray",
1999 size *= sizeof (ffetargetLogical3),
2001 break;
2002 #endif
2004 #if FFETARGET_okLOGICAL4
2005 case FFEINFO_kindtypeLOGICAL4:
2006 ptr.logical4 = malloc_new_zkp (ffebld_constant_pool(),
2007 "ffebldConstantArray",
2008 size *= sizeof (ffetargetLogical4),
2010 break;
2011 #endif
2013 #if FFETARGET_okLOGICAL5
2014 case FFEINFO_kindtypeLOGICAL5:
2015 ptr.logical5 = malloc_new_zkp (ffebld_constant_pool(),
2016 "ffebldConstantArray",
2017 size *= sizeof (ffetargetLogical5),
2019 break;
2020 #endif
2022 #if FFETARGET_okLOGICAL6
2023 case FFEINFO_kindtypeLOGICAL6:
2024 ptr.logical6 = malloc_new_zkp (ffebld_constant_pool(),
2025 "ffebldConstantArray",
2026 size *= sizeof (ffetargetLogical6),
2028 break;
2029 #endif
2031 #if FFETARGET_okLOGICAL7
2032 case FFEINFO_kindtypeLOGICAL7:
2033 ptr.logical7 = malloc_new_zkp (ffebld_constant_pool(),
2034 "ffebldConstantArray",
2035 size *= sizeof (ffetargetLogical7),
2037 break;
2038 #endif
2040 #if FFETARGET_okLOGICAL8
2041 case FFEINFO_kindtypeLOGICAL8:
2042 ptr.logical8 = malloc_new_zkp (ffebld_constant_pool(),
2043 "ffebldConstantArray",
2044 size *= sizeof (ffetargetLogical8),
2046 break;
2047 #endif
2049 default:
2050 assert ("bad LOGICAL kindtype" == NULL);
2051 break;
2053 break;
2055 case FFEINFO_basictypeREAL:
2056 switch (kt)
2058 #if FFETARGET_okREAL1
2059 case FFEINFO_kindtypeREAL1:
2060 ptr.real1 = malloc_new_zkp (ffebld_constant_pool(),
2061 "ffebldConstantArray",
2062 size *= sizeof (ffetargetReal1),
2064 break;
2065 #endif
2067 #if FFETARGET_okREAL2
2068 case FFEINFO_kindtypeREAL2:
2069 ptr.real2 = malloc_new_zkp (ffebld_constant_pool(),
2070 "ffebldConstantArray",
2071 size *= sizeof (ffetargetReal2),
2073 break;
2074 #endif
2076 #if FFETARGET_okREAL3
2077 case FFEINFO_kindtypeREAL3:
2078 ptr.real3 = malloc_new_zkp (ffebld_constant_pool(),
2079 "ffebldConstantArray",
2080 size *= sizeof (ffetargetReal3),
2082 break;
2083 #endif
2085 #if FFETARGET_okREAL4
2086 case FFEINFO_kindtypeREAL4:
2087 ptr.real4 = malloc_new_zkp (ffebld_constant_pool(),
2088 "ffebldConstantArray",
2089 size *= sizeof (ffetargetReal4),
2091 break;
2092 #endif
2094 #if FFETARGET_okREAL5
2095 case FFEINFO_kindtypeREAL5:
2096 ptr.real5 = malloc_new_zkp (ffebld_constant_pool(),
2097 "ffebldConstantArray",
2098 size *= sizeof (ffetargetReal5),
2100 break;
2101 #endif
2103 #if FFETARGET_okREAL6
2104 case FFEINFO_kindtypeREAL6:
2105 ptr.real6 = malloc_new_zkp (ffebld_constant_pool(),
2106 "ffebldConstantArray",
2107 size *= sizeof (ffetargetReal6),
2109 break;
2110 #endif
2112 #if FFETARGET_okREAL7
2113 case FFEINFO_kindtypeREAL7:
2114 ptr.real7 = malloc_new_zkp (ffebld_constant_pool(),
2115 "ffebldConstantArray",
2116 size *= sizeof (ffetargetReal7),
2118 break;
2119 #endif
2121 #if FFETARGET_okREAL8
2122 case FFEINFO_kindtypeREAL8:
2123 ptr.real8 = malloc_new_zkp (ffebld_constant_pool(),
2124 "ffebldConstantArray",
2125 size *= sizeof (ffetargetReal8),
2127 break;
2128 #endif
2130 default:
2131 assert ("bad REAL kindtype" == NULL);
2132 break;
2134 break;
2136 case FFEINFO_basictypeCOMPLEX:
2137 switch (kt)
2139 #if FFETARGET_okCOMPLEX1
2140 case FFEINFO_kindtypeREAL1:
2141 ptr.complex1 = malloc_new_zkp (ffebld_constant_pool(),
2142 "ffebldConstantArray",
2143 size *= sizeof (ffetargetComplex1),
2145 break;
2146 #endif
2148 #if FFETARGET_okCOMPLEX2
2149 case FFEINFO_kindtypeREAL2:
2150 ptr.complex2 = malloc_new_zkp (ffebld_constant_pool(),
2151 "ffebldConstantArray",
2152 size *= sizeof (ffetargetComplex2),
2154 break;
2155 #endif
2157 #if FFETARGET_okCOMPLEX3
2158 case FFEINFO_kindtypeREAL3:
2159 ptr.complex3 = malloc_new_zkp (ffebld_constant_pool(),
2160 "ffebldConstantArray",
2161 size *= sizeof (ffetargetComplex3),
2163 break;
2164 #endif
2166 #if FFETARGET_okCOMPLEX4
2167 case FFEINFO_kindtypeREAL4:
2168 ptr.complex4 = malloc_new_zkp (ffebld_constant_pool(),
2169 "ffebldConstantArray",
2170 size *= sizeof (ffetargetComplex4),
2172 break;
2173 #endif
2175 #if FFETARGET_okCOMPLEX5
2176 case FFEINFO_kindtypeREAL5:
2177 ptr.complex5 = malloc_new_zkp (ffebld_constant_pool(),
2178 "ffebldConstantArray",
2179 size *= sizeof (ffetargetComplex5),
2181 break;
2182 #endif
2184 #if FFETARGET_okCOMPLEX6
2185 case FFEINFO_kindtypeREAL6:
2186 ptr.complex6 = malloc_new_zkp (ffebld_constant_pool(),
2187 "ffebldConstantArray",
2188 size *= sizeof (ffetargetComplex6),
2190 break;
2191 #endif
2193 #if FFETARGET_okCOMPLEX7
2194 case FFEINFO_kindtypeREAL7:
2195 ptr.complex7 = malloc_new_zkp (ffebld_constant_pool(),
2196 "ffebldConstantArray",
2197 size *= sizeof (ffetargetComplex7),
2199 break;
2200 #endif
2202 #if FFETARGET_okCOMPLEX8
2203 case FFEINFO_kindtypeREAL8:
2204 ptr.complex8 = malloc_new_zkp (ffebld_constant_pool(),
2205 "ffebldConstantArray",
2206 size *= sizeof (ffetargetComplex8),
2208 break;
2209 #endif
2211 default:
2212 assert ("bad COMPLEX kindtype" == NULL);
2213 break;
2215 break;
2217 case FFEINFO_basictypeCHARACTER:
2218 switch (kt)
2220 #if FFETARGET_okCHARACTER1
2221 case FFEINFO_kindtypeCHARACTER1:
2222 ptr.character1 = malloc_new_zkp (ffebld_constant_pool(),
2223 "ffebldConstantArray",
2224 size
2225 *= sizeof (ffetargetCharacterUnit1),
2227 break;
2228 #endif
2230 #if FFETARGET_okCHARACTER2
2231 case FFEINFO_kindtypeCHARACTER2:
2232 ptr.character2 = malloc_new_zkp (ffebld_constant_pool(),
2233 "ffebldConstantArray",
2234 size
2235 *= sizeof (ffetargetCharacterUnit2),
2237 break;
2238 #endif
2240 #if FFETARGET_okCHARACTER3
2241 case FFEINFO_kindtypeCHARACTER3:
2242 ptr.character3 = malloc_new_zkp (ffebld_constant_pool(),
2243 "ffebldConstantArray",
2244 size
2245 *= sizeof (ffetargetCharacterUnit3),
2247 break;
2248 #endif
2250 #if FFETARGET_okCHARACTER4
2251 case FFEINFO_kindtypeCHARACTER4:
2252 ptr.character4 = malloc_new_zkp (ffebld_constant_pool(),
2253 "ffebldConstantArray",
2254 size
2255 *= sizeof (ffetargetCharacterUnit4),
2257 break;
2258 #endif
2260 #if FFETARGET_okCHARACTER5
2261 case FFEINFO_kindtypeCHARACTER5:
2262 ptr.character5 = malloc_new_zkp (ffebld_constant_pool(),
2263 "ffebldConstantArray",
2264 size
2265 *= sizeof (ffetargetCharacterUnit5),
2267 break;
2268 #endif
2270 #if FFETARGET_okCHARACTER6
2271 case FFEINFO_kindtypeCHARACTER6:
2272 ptr.character6 = malloc_new_zkp (ffebld_constant_pool(),
2273 "ffebldConstantArray",
2274 size
2275 *= sizeof (ffetargetCharacterUnit6),
2277 break;
2278 #endif
2280 #if FFETARGET_okCHARACTER7
2281 case FFEINFO_kindtypeCHARACTER7:
2282 ptr.character7 = malloc_new_zkp (ffebld_constant_pool(),
2283 "ffebldConstantArray",
2284 size
2285 *= sizeof (ffetargetCharacterUnit7),
2287 break;
2288 #endif
2290 #if FFETARGET_okCHARACTER8
2291 case FFEINFO_kindtypeCHARACTER8:
2292 ptr.character8 = malloc_new_zkp (ffebld_constant_pool(),
2293 "ffebldConstantArray",
2294 size
2295 *= sizeof (ffetargetCharacterUnit8),
2297 break;
2298 #endif
2300 default:
2301 assert ("bad CHARACTER kindtype" == NULL);
2302 break;
2304 break;
2306 default:
2307 assert ("bad basictype" == NULL);
2308 break;
2311 return ptr;
2314 /* ffebld_constantarray_preparray -- Prepare for copy between arrays
2316 See prototype.
2318 Like _prepare, but the source is an array instead of a single-value
2319 constant. */
2321 void
2322 ffebld_constantarray_preparray (void **aptr, void **cptr, size_t *size,
2323 ffebldConstantArray array, ffeinfoBasictype abt, ffeinfoKindtype akt,
2324 ffetargetOffset offset, ffebldConstantArray source_array,
2325 ffeinfoBasictype cbt, ffeinfoKindtype ckt)
2327 switch (abt)
2329 case FFEINFO_basictypeINTEGER:
2330 switch (akt)
2332 #if FFETARGET_okINTEGER1
2333 case FFEINFO_kindtypeINTEGER1:
2334 *aptr = array.integer1 + offset;
2335 break;
2336 #endif
2338 #if FFETARGET_okINTEGER2
2339 case FFEINFO_kindtypeINTEGER2:
2340 *aptr = array.integer2 + offset;
2341 break;
2342 #endif
2344 #if FFETARGET_okINTEGER3
2345 case FFEINFO_kindtypeINTEGER3:
2346 *aptr = array.integer3 + offset;
2347 break;
2348 #endif
2350 #if FFETARGET_okINTEGER4
2351 case FFEINFO_kindtypeINTEGER4:
2352 *aptr = array.integer4 + offset;
2353 break;
2354 #endif
2356 #if FFETARGET_okINTEGER5
2357 case FFEINFO_kindtypeINTEGER5:
2358 *aptr = array.integer5 + offset;
2359 break;
2360 #endif
2362 #if FFETARGET_okINTEGER6
2363 case FFEINFO_kindtypeINTEGER6:
2364 *aptr = array.integer6 + offset;
2365 break;
2366 #endif
2368 #if FFETARGET_okINTEGER7
2369 case FFEINFO_kindtypeINTEGER7:
2370 *aptr = array.integer7 + offset;
2371 break;
2372 #endif
2374 #if FFETARGET_okINTEGER8
2375 case FFEINFO_kindtypeINTEGER8:
2376 *aptr = array.integer8 + offset;
2377 break;
2378 #endif
2380 default:
2381 assert ("bad INTEGER akindtype" == NULL);
2382 break;
2384 break;
2386 case FFEINFO_basictypeLOGICAL:
2387 switch (akt)
2389 #if FFETARGET_okLOGICAL1
2390 case FFEINFO_kindtypeLOGICAL1:
2391 *aptr = array.logical1 + offset;
2392 break;
2393 #endif
2395 #if FFETARGET_okLOGICAL2
2396 case FFEINFO_kindtypeLOGICAL2:
2397 *aptr = array.logical2 + offset;
2398 break;
2399 #endif
2401 #if FFETARGET_okLOGICAL3
2402 case FFEINFO_kindtypeLOGICAL3:
2403 *aptr = array.logical3 + offset;
2404 break;
2405 #endif
2407 #if FFETARGET_okLOGICAL4
2408 case FFEINFO_kindtypeLOGICAL4:
2409 *aptr = array.logical4 + offset;
2410 break;
2411 #endif
2413 #if FFETARGET_okLOGICAL5
2414 case FFEINFO_kindtypeLOGICAL5:
2415 *aptr = array.logical5 + offset;
2416 break;
2417 #endif
2419 #if FFETARGET_okLOGICAL6
2420 case FFEINFO_kindtypeLOGICAL6:
2421 *aptr = array.logical6 + offset;
2422 break;
2423 #endif
2425 #if FFETARGET_okLOGICAL7
2426 case FFEINFO_kindtypeLOGICAL7:
2427 *aptr = array.logical7 + offset;
2428 break;
2429 #endif
2431 #if FFETARGET_okLOGICAL8
2432 case FFEINFO_kindtypeLOGICAL8:
2433 *aptr = array.logical8 + offset;
2434 break;
2435 #endif
2437 default:
2438 assert ("bad LOGICAL akindtype" == NULL);
2439 break;
2441 break;
2443 case FFEINFO_basictypeREAL:
2444 switch (akt)
2446 #if FFETARGET_okREAL1
2447 case FFEINFO_kindtypeREAL1:
2448 *aptr = array.real1 + offset;
2449 break;
2450 #endif
2452 #if FFETARGET_okREAL2
2453 case FFEINFO_kindtypeREAL2:
2454 *aptr = array.real2 + offset;
2455 break;
2456 #endif
2458 #if FFETARGET_okREAL3
2459 case FFEINFO_kindtypeREAL3:
2460 *aptr = array.real3 + offset;
2461 break;
2462 #endif
2464 #if FFETARGET_okREAL4
2465 case FFEINFO_kindtypeREAL4:
2466 *aptr = array.real4 + offset;
2467 break;
2468 #endif
2470 #if FFETARGET_okREAL5
2471 case FFEINFO_kindtypeREAL5:
2472 *aptr = array.real5 + offset;
2473 break;
2474 #endif
2476 #if FFETARGET_okREAL6
2477 case FFEINFO_kindtypeREAL6:
2478 *aptr = array.real6 + offset;
2479 break;
2480 #endif
2482 #if FFETARGET_okREAL7
2483 case FFEINFO_kindtypeREAL7:
2484 *aptr = array.real7 + offset;
2485 break;
2486 #endif
2488 #if FFETARGET_okREAL8
2489 case FFEINFO_kindtypeREAL8:
2490 *aptr = array.real8 + offset;
2491 break;
2492 #endif
2494 default:
2495 assert ("bad REAL akindtype" == NULL);
2496 break;
2498 break;
2500 case FFEINFO_basictypeCOMPLEX:
2501 switch (akt)
2503 #if FFETARGET_okCOMPLEX1
2504 case FFEINFO_kindtypeREAL1:
2505 *aptr = array.complex1 + offset;
2506 break;
2507 #endif
2509 #if FFETARGET_okCOMPLEX2
2510 case FFEINFO_kindtypeREAL2:
2511 *aptr = array.complex2 + offset;
2512 break;
2513 #endif
2515 #if FFETARGET_okCOMPLEX3
2516 case FFEINFO_kindtypeREAL3:
2517 *aptr = array.complex3 + offset;
2518 break;
2519 #endif
2521 #if FFETARGET_okCOMPLEX4
2522 case FFEINFO_kindtypeREAL4:
2523 *aptr = array.complex4 + offset;
2524 break;
2525 #endif
2527 #if FFETARGET_okCOMPLEX5
2528 case FFEINFO_kindtypeREAL5:
2529 *aptr = array.complex5 + offset;
2530 break;
2531 #endif
2533 #if FFETARGET_okCOMPLEX6
2534 case FFEINFO_kindtypeREAL6:
2535 *aptr = array.complex6 + offset;
2536 break;
2537 #endif
2539 #if FFETARGET_okCOMPLEX7
2540 case FFEINFO_kindtypeREAL7:
2541 *aptr = array.complex7 + offset;
2542 break;
2543 #endif
2545 #if FFETARGET_okCOMPLEX8
2546 case FFEINFO_kindtypeREAL8:
2547 *aptr = array.complex8 + offset;
2548 break;
2549 #endif
2551 default:
2552 assert ("bad COMPLEX akindtype" == NULL);
2553 break;
2555 break;
2557 case FFEINFO_basictypeCHARACTER:
2558 switch (akt)
2560 #if FFETARGET_okCHARACTER1
2561 case FFEINFO_kindtypeCHARACTER1:
2562 *aptr = array.character1 + offset;
2563 break;
2564 #endif
2566 #if FFETARGET_okCHARACTER2
2567 case FFEINFO_kindtypeCHARACTER2:
2568 *aptr = array.character2 + offset;
2569 break;
2570 #endif
2572 #if FFETARGET_okCHARACTER3
2573 case FFEINFO_kindtypeCHARACTER3:
2574 *aptr = array.character3 + offset;
2575 break;
2576 #endif
2578 #if FFETARGET_okCHARACTER4
2579 case FFEINFO_kindtypeCHARACTER4:
2580 *aptr = array.character4 + offset;
2581 break;
2582 #endif
2584 #if FFETARGET_okCHARACTER5
2585 case FFEINFO_kindtypeCHARACTER5:
2586 *aptr = array.character5 + offset;
2587 break;
2588 #endif
2590 #if FFETARGET_okCHARACTER6
2591 case FFEINFO_kindtypeCHARACTER6:
2592 *aptr = array.character6 + offset;
2593 break;
2594 #endif
2596 #if FFETARGET_okCHARACTER7
2597 case FFEINFO_kindtypeCHARACTER7:
2598 *aptr = array.character7 + offset;
2599 break;
2600 #endif
2602 #if FFETARGET_okCHARACTER8
2603 case FFEINFO_kindtypeCHARACTER8:
2604 *aptr = array.character8 + offset;
2605 break;
2606 #endif
2608 default:
2609 assert ("bad CHARACTER akindtype" == NULL);
2610 break;
2612 break;
2614 default:
2615 assert ("bad abasictype" == NULL);
2616 break;
2619 switch (cbt)
2621 case FFEINFO_basictypeINTEGER:
2622 switch (ckt)
2624 #if FFETARGET_okINTEGER1
2625 case FFEINFO_kindtypeINTEGER1:
2626 *cptr = source_array.integer1;
2627 *size = sizeof (*source_array.integer1);
2628 break;
2629 #endif
2631 #if FFETARGET_okINTEGER2
2632 case FFEINFO_kindtypeINTEGER2:
2633 *cptr = source_array.integer2;
2634 *size = sizeof (*source_array.integer2);
2635 break;
2636 #endif
2638 #if FFETARGET_okINTEGER3
2639 case FFEINFO_kindtypeINTEGER3:
2640 *cptr = source_array.integer3;
2641 *size = sizeof (*source_array.integer3);
2642 break;
2643 #endif
2645 #if FFETARGET_okINTEGER4
2646 case FFEINFO_kindtypeINTEGER4:
2647 *cptr = source_array.integer4;
2648 *size = sizeof (*source_array.integer4);
2649 break;
2650 #endif
2652 #if FFETARGET_okINTEGER5
2653 case FFEINFO_kindtypeINTEGER5:
2654 *cptr = source_array.integer5;
2655 *size = sizeof (*source_array.integer5);
2656 break;
2657 #endif
2659 #if FFETARGET_okINTEGER6
2660 case FFEINFO_kindtypeINTEGER6:
2661 *cptr = source_array.integer6;
2662 *size = sizeof (*source_array.integer6);
2663 break;
2664 #endif
2666 #if FFETARGET_okINTEGER7
2667 case FFEINFO_kindtypeINTEGER7:
2668 *cptr = source_array.integer7;
2669 *size = sizeof (*source_array.integer7);
2670 break;
2671 #endif
2673 #if FFETARGET_okINTEGER8
2674 case FFEINFO_kindtypeINTEGER8:
2675 *cptr = source_array.integer8;
2676 *size = sizeof (*source_array.integer8);
2677 break;
2678 #endif
2680 default:
2681 assert ("bad INTEGER ckindtype" == NULL);
2682 break;
2684 break;
2686 case FFEINFO_basictypeLOGICAL:
2687 switch (ckt)
2689 #if FFETARGET_okLOGICAL1
2690 case FFEINFO_kindtypeLOGICAL1:
2691 *cptr = source_array.logical1;
2692 *size = sizeof (*source_array.logical1);
2693 break;
2694 #endif
2696 #if FFETARGET_okLOGICAL2
2697 case FFEINFO_kindtypeLOGICAL2:
2698 *cptr = source_array.logical2;
2699 *size = sizeof (*source_array.logical2);
2700 break;
2701 #endif
2703 #if FFETARGET_okLOGICAL3
2704 case FFEINFO_kindtypeLOGICAL3:
2705 *cptr = source_array.logical3;
2706 *size = sizeof (*source_array.logical3);
2707 break;
2708 #endif
2710 #if FFETARGET_okLOGICAL4
2711 case FFEINFO_kindtypeLOGICAL4:
2712 *cptr = source_array.logical4;
2713 *size = sizeof (*source_array.logical4);
2714 break;
2715 #endif
2717 #if FFETARGET_okLOGICAL5
2718 case FFEINFO_kindtypeLOGICAL5:
2719 *cptr = source_array.logical5;
2720 *size = sizeof (*source_array.logical5);
2721 break;
2722 #endif
2724 #if FFETARGET_okLOGICAL6
2725 case FFEINFO_kindtypeLOGICAL6:
2726 *cptr = source_array.logical6;
2727 *size = sizeof (*source_array.logical6);
2728 break;
2729 #endif
2731 #if FFETARGET_okLOGICAL7
2732 case FFEINFO_kindtypeLOGICAL7:
2733 *cptr = source_array.logical7;
2734 *size = sizeof (*source_array.logical7);
2735 break;
2736 #endif
2738 #if FFETARGET_okLOGICAL8
2739 case FFEINFO_kindtypeLOGICAL8:
2740 *cptr = source_array.logical8;
2741 *size = sizeof (*source_array.logical8);
2742 break;
2743 #endif
2745 default:
2746 assert ("bad LOGICAL ckindtype" == NULL);
2747 break;
2749 break;
2751 case FFEINFO_basictypeREAL:
2752 switch (ckt)
2754 #if FFETARGET_okREAL1
2755 case FFEINFO_kindtypeREAL1:
2756 *cptr = source_array.real1;
2757 *size = sizeof (*source_array.real1);
2758 break;
2759 #endif
2761 #if FFETARGET_okREAL2
2762 case FFEINFO_kindtypeREAL2:
2763 *cptr = source_array.real2;
2764 *size = sizeof (*source_array.real2);
2765 break;
2766 #endif
2768 #if FFETARGET_okREAL3
2769 case FFEINFO_kindtypeREAL3:
2770 *cptr = source_array.real3;
2771 *size = sizeof (*source_array.real3);
2772 break;
2773 #endif
2775 #if FFETARGET_okREAL4
2776 case FFEINFO_kindtypeREAL4:
2777 *cptr = source_array.real4;
2778 *size = sizeof (*source_array.real4);
2779 break;
2780 #endif
2782 #if FFETARGET_okREAL5
2783 case FFEINFO_kindtypeREAL5:
2784 *cptr = source_array.real5;
2785 *size = sizeof (*source_array.real5);
2786 break;
2787 #endif
2789 #if FFETARGET_okREAL6
2790 case FFEINFO_kindtypeREAL6:
2791 *cptr = source_array.real6;
2792 *size = sizeof (*source_array.real6);
2793 break;
2794 #endif
2796 #if FFETARGET_okREAL7
2797 case FFEINFO_kindtypeREAL7:
2798 *cptr = source_array.real7;
2799 *size = sizeof (*source_array.real7);
2800 break;
2801 #endif
2803 #if FFETARGET_okREAL8
2804 case FFEINFO_kindtypeREAL8:
2805 *cptr = source_array.real8;
2806 *size = sizeof (*source_array.real8);
2807 break;
2808 #endif
2810 default:
2811 assert ("bad REAL ckindtype" == NULL);
2812 break;
2814 break;
2816 case FFEINFO_basictypeCOMPLEX:
2817 switch (ckt)
2819 #if FFETARGET_okCOMPLEX1
2820 case FFEINFO_kindtypeREAL1:
2821 *cptr = source_array.complex1;
2822 *size = sizeof (*source_array.complex1);
2823 break;
2824 #endif
2826 #if FFETARGET_okCOMPLEX2
2827 case FFEINFO_kindtypeREAL2:
2828 *cptr = source_array.complex2;
2829 *size = sizeof (*source_array.complex2);
2830 break;
2831 #endif
2833 #if FFETARGET_okCOMPLEX3
2834 case FFEINFO_kindtypeREAL3:
2835 *cptr = source_array.complex3;
2836 *size = sizeof (*source_array.complex3);
2837 break;
2838 #endif
2840 #if FFETARGET_okCOMPLEX4
2841 case FFEINFO_kindtypeREAL4:
2842 *cptr = source_array.complex4;
2843 *size = sizeof (*source_array.complex4);
2844 break;
2845 #endif
2847 #if FFETARGET_okCOMPLEX5
2848 case FFEINFO_kindtypeREAL5:
2849 *cptr = source_array.complex5;
2850 *size = sizeof (*source_array.complex5);
2851 break;
2852 #endif
2854 #if FFETARGET_okCOMPLEX6
2855 case FFEINFO_kindtypeREAL6:
2856 *cptr = source_array.complex6;
2857 *size = sizeof (*source_array.complex6);
2858 break;
2859 #endif
2861 #if FFETARGET_okCOMPLEX7
2862 case FFEINFO_kindtypeREAL7:
2863 *cptr = source_array.complex7;
2864 *size = sizeof (*source_array.complex7);
2865 break;
2866 #endif
2868 #if FFETARGET_okCOMPLEX8
2869 case FFEINFO_kindtypeREAL8:
2870 *cptr = source_array.complex8;
2871 *size = sizeof (*source_array.complex8);
2872 break;
2873 #endif
2875 default:
2876 assert ("bad COMPLEX ckindtype" == NULL);
2877 break;
2879 break;
2881 case FFEINFO_basictypeCHARACTER:
2882 switch (ckt)
2884 #if FFETARGET_okCHARACTER1
2885 case FFEINFO_kindtypeCHARACTER1:
2886 *cptr = source_array.character1;
2887 *size = sizeof (*source_array.character1);
2888 break;
2889 #endif
2891 #if FFETARGET_okCHARACTER2
2892 case FFEINFO_kindtypeCHARACTER2:
2893 *cptr = source_array.character2;
2894 *size = sizeof (*source_array.character2);
2895 break;
2896 #endif
2898 #if FFETARGET_okCHARACTER3
2899 case FFEINFO_kindtypeCHARACTER3:
2900 *cptr = source_array.character3;
2901 *size = sizeof (*source_array.character3);
2902 break;
2903 #endif
2905 #if FFETARGET_okCHARACTER4
2906 case FFEINFO_kindtypeCHARACTER4:
2907 *cptr = source_array.character4;
2908 *size = sizeof (*source_array.character4);
2909 break;
2910 #endif
2912 #if FFETARGET_okCHARACTER5
2913 case FFEINFO_kindtypeCHARACTER5:
2914 *cptr = source_array.character5;
2915 *size = sizeof (*source_array.character5);
2916 break;
2917 #endif
2919 #if FFETARGET_okCHARACTER6
2920 case FFEINFO_kindtypeCHARACTER6:
2921 *cptr = source_array.character6;
2922 *size = sizeof (*source_array.character6);
2923 break;
2924 #endif
2926 #if FFETARGET_okCHARACTER7
2927 case FFEINFO_kindtypeCHARACTER7:
2928 *cptr = source_array.character7;
2929 *size = sizeof (*source_array.character7);
2930 break;
2931 #endif
2933 #if FFETARGET_okCHARACTER8
2934 case FFEINFO_kindtypeCHARACTER8:
2935 *cptr = source_array.character8;
2936 *size = sizeof (*source_array.character8);
2937 break;
2938 #endif
2940 default:
2941 assert ("bad CHARACTER ckindtype" == NULL);
2942 break;
2944 break;
2946 default:
2947 assert ("bad cbasictype" == NULL);
2948 break;
2952 /* ffebld_constantarray_prepare -- Prepare for copy between value and array
2954 See prototype.
2956 Like _put, but just returns the pointers to the beginnings of the
2957 array and the constant and returns the size (the amount of info to
2958 copy). The idea is that the caller can use memcpy to accomplish the
2959 same thing as _put (though slower), or the caller can use a different
2960 function that swaps bytes, words, etc for a different target machine.
2961 Also, the type of the array may be different from the type of the
2962 constant; the array type is used to determine the meaning (scale) of
2963 the offset field (to calculate the array pointer), the constant type is
2964 used to determine the constant pointer and the size (amount of info to
2965 copy). */
2967 void
2968 ffebld_constantarray_prepare (void **aptr, void **cptr, size_t *size,
2969 ffebldConstantArray array, ffeinfoBasictype abt, ffeinfoKindtype akt,
2970 ffetargetOffset offset, ffebldConstantUnion *constant,
2971 ffeinfoBasictype cbt, ffeinfoKindtype ckt)
2973 switch (abt)
2975 case FFEINFO_basictypeINTEGER:
2976 switch (akt)
2978 #if FFETARGET_okINTEGER1
2979 case FFEINFO_kindtypeINTEGER1:
2980 *aptr = array.integer1 + offset;
2981 break;
2982 #endif
2984 #if FFETARGET_okINTEGER2
2985 case FFEINFO_kindtypeINTEGER2:
2986 *aptr = array.integer2 + offset;
2987 break;
2988 #endif
2990 #if FFETARGET_okINTEGER3
2991 case FFEINFO_kindtypeINTEGER3:
2992 *aptr = array.integer3 + offset;
2993 break;
2994 #endif
2996 #if FFETARGET_okINTEGER4
2997 case FFEINFO_kindtypeINTEGER4:
2998 *aptr = array.integer4 + offset;
2999 break;
3000 #endif
3002 #if FFETARGET_okINTEGER5
3003 case FFEINFO_kindtypeINTEGER5:
3004 *aptr = array.integer5 + offset;
3005 break;
3006 #endif
3008 #if FFETARGET_okINTEGER6
3009 case FFEINFO_kindtypeINTEGER6:
3010 *aptr = array.integer6 + offset;
3011 break;
3012 #endif
3014 #if FFETARGET_okINTEGER7
3015 case FFEINFO_kindtypeINTEGER7:
3016 *aptr = array.integer7 + offset;
3017 break;
3018 #endif
3020 #if FFETARGET_okINTEGER8
3021 case FFEINFO_kindtypeINTEGER8:
3022 *aptr = array.integer8 + offset;
3023 break;
3024 #endif
3026 default:
3027 assert ("bad INTEGER akindtype" == NULL);
3028 break;
3030 break;
3032 case FFEINFO_basictypeLOGICAL:
3033 switch (akt)
3035 #if FFETARGET_okLOGICAL1
3036 case FFEINFO_kindtypeLOGICAL1:
3037 *aptr = array.logical1 + offset;
3038 break;
3039 #endif
3041 #if FFETARGET_okLOGICAL2
3042 case FFEINFO_kindtypeLOGICAL2:
3043 *aptr = array.logical2 + offset;
3044 break;
3045 #endif
3047 #if FFETARGET_okLOGICAL3
3048 case FFEINFO_kindtypeLOGICAL3:
3049 *aptr = array.logical3 + offset;
3050 break;
3051 #endif
3053 #if FFETARGET_okLOGICAL4
3054 case FFEINFO_kindtypeLOGICAL4:
3055 *aptr = array.logical4 + offset;
3056 break;
3057 #endif
3059 #if FFETARGET_okLOGICAL5
3060 case FFEINFO_kindtypeLOGICAL5:
3061 *aptr = array.logical5 + offset;
3062 break;
3063 #endif
3065 #if FFETARGET_okLOGICAL6
3066 case FFEINFO_kindtypeLOGICAL6:
3067 *aptr = array.logical6 + offset;
3068 break;
3069 #endif
3071 #if FFETARGET_okLOGICAL7
3072 case FFEINFO_kindtypeLOGICAL7:
3073 *aptr = array.logical7 + offset;
3074 break;
3075 #endif
3077 #if FFETARGET_okLOGICAL8
3078 case FFEINFO_kindtypeLOGICAL8:
3079 *aptr = array.logical8 + offset;
3080 break;
3081 #endif
3083 default:
3084 assert ("bad LOGICAL akindtype" == NULL);
3085 break;
3087 break;
3089 case FFEINFO_basictypeREAL:
3090 switch (akt)
3092 #if FFETARGET_okREAL1
3093 case FFEINFO_kindtypeREAL1:
3094 *aptr = array.real1 + offset;
3095 break;
3096 #endif
3098 #if FFETARGET_okREAL2
3099 case FFEINFO_kindtypeREAL2:
3100 *aptr = array.real2 + offset;
3101 break;
3102 #endif
3104 #if FFETARGET_okREAL3
3105 case FFEINFO_kindtypeREAL3:
3106 *aptr = array.real3 + offset;
3107 break;
3108 #endif
3110 #if FFETARGET_okREAL4
3111 case FFEINFO_kindtypeREAL4:
3112 *aptr = array.real4 + offset;
3113 break;
3114 #endif
3116 #if FFETARGET_okREAL5
3117 case FFEINFO_kindtypeREAL5:
3118 *aptr = array.real5 + offset;
3119 break;
3120 #endif
3122 #if FFETARGET_okREAL6
3123 case FFEINFO_kindtypeREAL6:
3124 *aptr = array.real6 + offset;
3125 break;
3126 #endif
3128 #if FFETARGET_okREAL7
3129 case FFEINFO_kindtypeREAL7:
3130 *aptr = array.real7 + offset;
3131 break;
3132 #endif
3134 #if FFETARGET_okREAL8
3135 case FFEINFO_kindtypeREAL8:
3136 *aptr = array.real8 + offset;
3137 break;
3138 #endif
3140 default:
3141 assert ("bad REAL akindtype" == NULL);
3142 break;
3144 break;
3146 case FFEINFO_basictypeCOMPLEX:
3147 switch (akt)
3149 #if FFETARGET_okCOMPLEX1
3150 case FFEINFO_kindtypeREAL1:
3151 *aptr = array.complex1 + offset;
3152 break;
3153 #endif
3155 #if FFETARGET_okCOMPLEX2
3156 case FFEINFO_kindtypeREAL2:
3157 *aptr = array.complex2 + offset;
3158 break;
3159 #endif
3161 #if FFETARGET_okCOMPLEX3
3162 case FFEINFO_kindtypeREAL3:
3163 *aptr = array.complex3 + offset;
3164 break;
3165 #endif
3167 #if FFETARGET_okCOMPLEX4
3168 case FFEINFO_kindtypeREAL4:
3169 *aptr = array.complex4 + offset;
3170 break;
3171 #endif
3173 #if FFETARGET_okCOMPLEX5
3174 case FFEINFO_kindtypeREAL5:
3175 *aptr = array.complex5 + offset;
3176 break;
3177 #endif
3179 #if FFETARGET_okCOMPLEX6
3180 case FFEINFO_kindtypeREAL6:
3181 *aptr = array.complex6 + offset;
3182 break;
3183 #endif
3185 #if FFETARGET_okCOMPLEX7
3186 case FFEINFO_kindtypeREAL7:
3187 *aptr = array.complex7 + offset;
3188 break;
3189 #endif
3191 #if FFETARGET_okCOMPLEX8
3192 case FFEINFO_kindtypeREAL8:
3193 *aptr = array.complex8 + offset;
3194 break;
3195 #endif
3197 default:
3198 assert ("bad COMPLEX akindtype" == NULL);
3199 break;
3201 break;
3203 case FFEINFO_basictypeCHARACTER:
3204 switch (akt)
3206 #if FFETARGET_okCHARACTER1
3207 case FFEINFO_kindtypeCHARACTER1:
3208 *aptr = array.character1 + offset;
3209 break;
3210 #endif
3212 #if FFETARGET_okCHARACTER2
3213 case FFEINFO_kindtypeCHARACTER2:
3214 *aptr = array.character2 + offset;
3215 break;
3216 #endif
3218 #if FFETARGET_okCHARACTER3
3219 case FFEINFO_kindtypeCHARACTER3:
3220 *aptr = array.character3 + offset;
3221 break;
3222 #endif
3224 #if FFETARGET_okCHARACTER4
3225 case FFEINFO_kindtypeCHARACTER4:
3226 *aptr = array.character4 + offset;
3227 break;
3228 #endif
3230 #if FFETARGET_okCHARACTER5
3231 case FFEINFO_kindtypeCHARACTER5:
3232 *aptr = array.character5 + offset;
3233 break;
3234 #endif
3236 #if FFETARGET_okCHARACTER6
3237 case FFEINFO_kindtypeCHARACTER6:
3238 *aptr = array.character6 + offset;
3239 break;
3240 #endif
3242 #if FFETARGET_okCHARACTER7
3243 case FFEINFO_kindtypeCHARACTER7:
3244 *aptr = array.character7 + offset;
3245 break;
3246 #endif
3248 #if FFETARGET_okCHARACTER8
3249 case FFEINFO_kindtypeCHARACTER8:
3250 *aptr = array.character8 + offset;
3251 break;
3252 #endif
3254 default:
3255 assert ("bad CHARACTER akindtype" == NULL);
3256 break;
3258 break;
3260 default:
3261 assert ("bad abasictype" == NULL);
3262 break;
3265 switch (cbt)
3267 case FFEINFO_basictypeINTEGER:
3268 switch (ckt)
3270 #if FFETARGET_okINTEGER1
3271 case FFEINFO_kindtypeINTEGER1:
3272 *cptr = &constant->integer1;
3273 *size = sizeof (constant->integer1);
3274 break;
3275 #endif
3277 #if FFETARGET_okINTEGER2
3278 case FFEINFO_kindtypeINTEGER2:
3279 *cptr = &constant->integer2;
3280 *size = sizeof (constant->integer2);
3281 break;
3282 #endif
3284 #if FFETARGET_okINTEGER3
3285 case FFEINFO_kindtypeINTEGER3:
3286 *cptr = &constant->integer3;
3287 *size = sizeof (constant->integer3);
3288 break;
3289 #endif
3291 #if FFETARGET_okINTEGER4
3292 case FFEINFO_kindtypeINTEGER4:
3293 *cptr = &constant->integer4;
3294 *size = sizeof (constant->integer4);
3295 break;
3296 #endif
3298 #if FFETARGET_okINTEGER5
3299 case FFEINFO_kindtypeINTEGER5:
3300 *cptr = &constant->integer5;
3301 *size = sizeof (constant->integer5);
3302 break;
3303 #endif
3305 #if FFETARGET_okINTEGER6
3306 case FFEINFO_kindtypeINTEGER6:
3307 *cptr = &constant->integer6;
3308 *size = sizeof (constant->integer6);
3309 break;
3310 #endif
3312 #if FFETARGET_okINTEGER7
3313 case FFEINFO_kindtypeINTEGER7:
3314 *cptr = &constant->integer7;
3315 *size = sizeof (constant->integer7);
3316 break;
3317 #endif
3319 #if FFETARGET_okINTEGER8
3320 case FFEINFO_kindtypeINTEGER8:
3321 *cptr = &constant->integer8;
3322 *size = sizeof (constant->integer8);
3323 break;
3324 #endif
3326 default:
3327 assert ("bad INTEGER ckindtype" == NULL);
3328 break;
3330 break;
3332 case FFEINFO_basictypeLOGICAL:
3333 switch (ckt)
3335 #if FFETARGET_okLOGICAL1
3336 case FFEINFO_kindtypeLOGICAL1:
3337 *cptr = &constant->logical1;
3338 *size = sizeof (constant->logical1);
3339 break;
3340 #endif
3342 #if FFETARGET_okLOGICAL2
3343 case FFEINFO_kindtypeLOGICAL2:
3344 *cptr = &constant->logical2;
3345 *size = sizeof (constant->logical2);
3346 break;
3347 #endif
3349 #if FFETARGET_okLOGICAL3
3350 case FFEINFO_kindtypeLOGICAL3:
3351 *cptr = &constant->logical3;
3352 *size = sizeof (constant->logical3);
3353 break;
3354 #endif
3356 #if FFETARGET_okLOGICAL4
3357 case FFEINFO_kindtypeLOGICAL4:
3358 *cptr = &constant->logical4;
3359 *size = sizeof (constant->logical4);
3360 break;
3361 #endif
3363 #if FFETARGET_okLOGICAL5
3364 case FFEINFO_kindtypeLOGICAL5:
3365 *cptr = &constant->logical5;
3366 *size = sizeof (constant->logical5);
3367 break;
3368 #endif
3370 #if FFETARGET_okLOGICAL6
3371 case FFEINFO_kindtypeLOGICAL6:
3372 *cptr = &constant->logical6;
3373 *size = sizeof (constant->logical6);
3374 break;
3375 #endif
3377 #if FFETARGET_okLOGICAL7
3378 case FFEINFO_kindtypeLOGICAL7:
3379 *cptr = &constant->logical7;
3380 *size = sizeof (constant->logical7);
3381 break;
3382 #endif
3384 #if FFETARGET_okLOGICAL8
3385 case FFEINFO_kindtypeLOGICAL8:
3386 *cptr = &constant->logical8;
3387 *size = sizeof (constant->logical8);
3388 break;
3389 #endif
3391 default:
3392 assert ("bad LOGICAL ckindtype" == NULL);
3393 break;
3395 break;
3397 case FFEINFO_basictypeREAL:
3398 switch (ckt)
3400 #if FFETARGET_okREAL1
3401 case FFEINFO_kindtypeREAL1:
3402 *cptr = &constant->real1;
3403 *size = sizeof (constant->real1);
3404 break;
3405 #endif
3407 #if FFETARGET_okREAL2
3408 case FFEINFO_kindtypeREAL2:
3409 *cptr = &constant->real2;
3410 *size = sizeof (constant->real2);
3411 break;
3412 #endif
3414 #if FFETARGET_okREAL3
3415 case FFEINFO_kindtypeREAL3:
3416 *cptr = &constant->real3;
3417 *size = sizeof (constant->real3);
3418 break;
3419 #endif
3421 #if FFETARGET_okREAL4
3422 case FFEINFO_kindtypeREAL4:
3423 *cptr = &constant->real4;
3424 *size = sizeof (constant->real4);
3425 break;
3426 #endif
3428 #if FFETARGET_okREAL5
3429 case FFEINFO_kindtypeREAL5:
3430 *cptr = &constant->real5;
3431 *size = sizeof (constant->real5);
3432 break;
3433 #endif
3435 #if FFETARGET_okREAL6
3436 case FFEINFO_kindtypeREAL6:
3437 *cptr = &constant->real6;
3438 *size = sizeof (constant->real6);
3439 break;
3440 #endif
3442 #if FFETARGET_okREAL7
3443 case FFEINFO_kindtypeREAL7:
3444 *cptr = &constant->real7;
3445 *size = sizeof (constant->real7);
3446 break;
3447 #endif
3449 #if FFETARGET_okREAL8
3450 case FFEINFO_kindtypeREAL8:
3451 *cptr = &constant->real8;
3452 *size = sizeof (constant->real8);
3453 break;
3454 #endif
3456 default:
3457 assert ("bad REAL ckindtype" == NULL);
3458 break;
3460 break;
3462 case FFEINFO_basictypeCOMPLEX:
3463 switch (ckt)
3465 #if FFETARGET_okCOMPLEX1
3466 case FFEINFO_kindtypeREAL1:
3467 *cptr = &constant->complex1;
3468 *size = sizeof (constant->complex1);
3469 break;
3470 #endif
3472 #if FFETARGET_okCOMPLEX2
3473 case FFEINFO_kindtypeREAL2:
3474 *cptr = &constant->complex2;
3475 *size = sizeof (constant->complex2);
3476 break;
3477 #endif
3479 #if FFETARGET_okCOMPLEX3
3480 case FFEINFO_kindtypeREAL3:
3481 *cptr = &constant->complex3;
3482 *size = sizeof (constant->complex3);
3483 break;
3484 #endif
3486 #if FFETARGET_okCOMPLEX4
3487 case FFEINFO_kindtypeREAL4:
3488 *cptr = &constant->complex4;
3489 *size = sizeof (constant->complex4);
3490 break;
3491 #endif
3493 #if FFETARGET_okCOMPLEX5
3494 case FFEINFO_kindtypeREAL5:
3495 *cptr = &constant->complex5;
3496 *size = sizeof (constant->complex5);
3497 break;
3498 #endif
3500 #if FFETARGET_okCOMPLEX6
3501 case FFEINFO_kindtypeREAL6:
3502 *cptr = &constant->complex6;
3503 *size = sizeof (constant->complex6);
3504 break;
3505 #endif
3507 #if FFETARGET_okCOMPLEX7
3508 case FFEINFO_kindtypeREAL7:
3509 *cptr = &constant->complex7;
3510 *size = sizeof (constant->complex7);
3511 break;
3512 #endif
3514 #if FFETARGET_okCOMPLEX8
3515 case FFEINFO_kindtypeREAL8:
3516 *cptr = &constant->complex8;
3517 *size = sizeof (constant->complex8);
3518 break;
3519 #endif
3521 default:
3522 assert ("bad COMPLEX ckindtype" == NULL);
3523 break;
3525 break;
3527 case FFEINFO_basictypeCHARACTER:
3528 switch (ckt)
3530 #if FFETARGET_okCHARACTER1
3531 case FFEINFO_kindtypeCHARACTER1:
3532 *cptr = ffetarget_text_character1 (constant->character1);
3533 *size = ffetarget_length_character1 (constant->character1);
3534 break;
3535 #endif
3537 #if FFETARGET_okCHARACTER2
3538 case FFEINFO_kindtypeCHARACTER2:
3539 *cptr = ffetarget_text_character2 (constant->character2);
3540 *size = ffetarget_length_character2 (constant->character2);
3541 break;
3542 #endif
3544 #if FFETARGET_okCHARACTER3
3545 case FFEINFO_kindtypeCHARACTER3:
3546 *cptr = ffetarget_text_character3 (constant->character3);
3547 *size = ffetarget_length_character3 (constant->character3);
3548 break;
3549 #endif
3551 #if FFETARGET_okCHARACTER4
3552 case FFEINFO_kindtypeCHARACTER4:
3553 *cptr = ffetarget_text_character4 (constant->character4);
3554 *size = ffetarget_length_character4 (constant->character4);
3555 break;
3556 #endif
3558 #if FFETARGET_okCHARACTER5
3559 case FFEINFO_kindtypeCHARACTER5:
3560 *cptr = ffetarget_text_character5 (constant->character5);
3561 *size = ffetarget_length_character5 (constant->character5);
3562 break;
3563 #endif
3565 #if FFETARGET_okCHARACTER6
3566 case FFEINFO_kindtypeCHARACTER6:
3567 *cptr = ffetarget_text_character6 (constant->character6);
3568 *size = ffetarget_length_character6 (constant->character6);
3569 break;
3570 #endif
3572 #if FFETARGET_okCHARACTER7
3573 case FFEINFO_kindtypeCHARACTER7:
3574 *cptr = ffetarget_text_character7 (constant->character7);
3575 *size = ffetarget_length_character7 (constant->character7);
3576 break;
3577 #endif
3579 #if FFETARGET_okCHARACTER8
3580 case FFEINFO_kindtypeCHARACTER8:
3581 *cptr = ffetarget_text_character8 (constant->character8);
3582 *size = ffetarget_length_character8 (constant->character8);
3583 break;
3584 #endif
3586 default:
3587 assert ("bad CHARACTER ckindtype" == NULL);
3588 break;
3590 break;
3592 default:
3593 assert ("bad cbasictype" == NULL);
3594 break;
3598 /* ffebld_constantarray_put -- Put a value into an array of constants
3600 See prototype. */
3602 void
3603 ffebld_constantarray_put (ffebldConstantArray array, ffeinfoBasictype bt,
3604 ffeinfoKindtype kt, ffetargetOffset offset, ffebldConstantUnion constant)
3606 switch (bt)
3608 case FFEINFO_basictypeINTEGER:
3609 switch (kt)
3611 #if FFETARGET_okINTEGER1
3612 case FFEINFO_kindtypeINTEGER1:
3613 *(array.integer1 + offset) = constant.integer1;
3614 break;
3615 #endif
3617 #if FFETARGET_okINTEGER2
3618 case FFEINFO_kindtypeINTEGER2:
3619 *(array.integer2 + offset) = constant.integer2;
3620 break;
3621 #endif
3623 #if FFETARGET_okINTEGER3
3624 case FFEINFO_kindtypeINTEGER3:
3625 *(array.integer3 + offset) = constant.integer3;
3626 break;
3627 #endif
3629 #if FFETARGET_okINTEGER4
3630 case FFEINFO_kindtypeINTEGER4:
3631 *(array.integer4 + offset) = constant.integer4;
3632 break;
3633 #endif
3635 #if FFETARGET_okINTEGER5
3636 case FFEINFO_kindtypeINTEGER5:
3637 *(array.integer5 + offset) = constant.integer5;
3638 break;
3639 #endif
3641 #if FFETARGET_okINTEGER6
3642 case FFEINFO_kindtypeINTEGER6:
3643 *(array.integer6 + offset) = constant.integer6;
3644 break;
3645 #endif
3647 #if FFETARGET_okINTEGER7
3648 case FFEINFO_kindtypeINTEGER7:
3649 *(array.integer7 + offset) = constant.integer7;
3650 break;
3651 #endif
3653 #if FFETARGET_okINTEGER8
3654 case FFEINFO_kindtypeINTEGER8:
3655 *(array.integer8 + offset) = constant.integer8;
3656 break;
3657 #endif
3659 default:
3660 assert ("bad INTEGER kindtype" == NULL);
3661 break;
3663 break;
3665 case FFEINFO_basictypeLOGICAL:
3666 switch (kt)
3668 #if FFETARGET_okLOGICAL1
3669 case FFEINFO_kindtypeLOGICAL1:
3670 *(array.logical1 + offset) = constant.logical1;
3671 break;
3672 #endif
3674 #if FFETARGET_okLOGICAL2
3675 case FFEINFO_kindtypeLOGICAL2:
3676 *(array.logical2 + offset) = constant.logical2;
3677 break;
3678 #endif
3680 #if FFETARGET_okLOGICAL3
3681 case FFEINFO_kindtypeLOGICAL3:
3682 *(array.logical3 + offset) = constant.logical3;
3683 break;
3684 #endif
3686 #if FFETARGET_okLOGICAL4
3687 case FFEINFO_kindtypeLOGICAL4:
3688 *(array.logical4 + offset) = constant.logical4;
3689 break;
3690 #endif
3692 #if FFETARGET_okLOGICAL5
3693 case FFEINFO_kindtypeLOGICAL5:
3694 *(array.logical5 + offset) = constant.logical5;
3695 break;
3696 #endif
3698 #if FFETARGET_okLOGICAL6
3699 case FFEINFO_kindtypeLOGICAL6:
3700 *(array.logical6 + offset) = constant.logical6;
3701 break;
3702 #endif
3704 #if FFETARGET_okLOGICAL7
3705 case FFEINFO_kindtypeLOGICAL7:
3706 *(array.logical7 + offset) = constant.logical7;
3707 break;
3708 #endif
3710 #if FFETARGET_okLOGICAL8
3711 case FFEINFO_kindtypeLOGICAL8:
3712 *(array.logical8 + offset) = constant.logical8;
3713 break;
3714 #endif
3716 default:
3717 assert ("bad LOGICAL kindtype" == NULL);
3718 break;
3720 break;
3722 case FFEINFO_basictypeREAL:
3723 switch (kt)
3725 #if FFETARGET_okREAL1
3726 case FFEINFO_kindtypeREAL1:
3727 *(array.real1 + offset) = constant.real1;
3728 break;
3729 #endif
3731 #if FFETARGET_okREAL2
3732 case FFEINFO_kindtypeREAL2:
3733 *(array.real2 + offset) = constant.real2;
3734 break;
3735 #endif
3737 #if FFETARGET_okREAL3
3738 case FFEINFO_kindtypeREAL3:
3739 *(array.real3 + offset) = constant.real3;
3740 break;
3741 #endif
3743 #if FFETARGET_okREAL4
3744 case FFEINFO_kindtypeREAL4:
3745 *(array.real4 + offset) = constant.real4;
3746 break;
3747 #endif
3749 #if FFETARGET_okREAL5
3750 case FFEINFO_kindtypeREAL5:
3751 *(array.real5 + offset) = constant.real5;
3752 break;
3753 #endif
3755 #if FFETARGET_okREAL6
3756 case FFEINFO_kindtypeREAL6:
3757 *(array.real6 + offset) = constant.real6;
3758 break;
3759 #endif
3761 #if FFETARGET_okREAL7
3762 case FFEINFO_kindtypeREAL7:
3763 *(array.real7 + offset) = constant.real7;
3764 break;
3765 #endif
3767 #if FFETARGET_okREAL8
3768 case FFEINFO_kindtypeREAL8:
3769 *(array.real8 + offset) = constant.real8;
3770 break;
3771 #endif
3773 default:
3774 assert ("bad REAL kindtype" == NULL);
3775 break;
3777 break;
3779 case FFEINFO_basictypeCOMPLEX:
3780 switch (kt)
3782 #if FFETARGET_okCOMPLEX1
3783 case FFEINFO_kindtypeREAL1:
3784 *(array.complex1 + offset) = constant.complex1;
3785 break;
3786 #endif
3788 #if FFETARGET_okCOMPLEX2
3789 case FFEINFO_kindtypeREAL2:
3790 *(array.complex2 + offset) = constant.complex2;
3791 break;
3792 #endif
3794 #if FFETARGET_okCOMPLEX3
3795 case FFEINFO_kindtypeREAL3:
3796 *(array.complex3 + offset) = constant.complex3;
3797 break;
3798 #endif
3800 #if FFETARGET_okCOMPLEX4
3801 case FFEINFO_kindtypeREAL4:
3802 *(array.complex4 + offset) = constant.complex4;
3803 break;
3804 #endif
3806 #if FFETARGET_okCOMPLEX5
3807 case FFEINFO_kindtypeREAL5:
3808 *(array.complex5 + offset) = constant.complex5;
3809 break;
3810 #endif
3812 #if FFETARGET_okCOMPLEX6
3813 case FFEINFO_kindtypeREAL6:
3814 *(array.complex6 + offset) = constant.complex6;
3815 break;
3816 #endif
3818 #if FFETARGET_okCOMPLEX7
3819 case FFEINFO_kindtypeREAL7:
3820 *(array.complex7 + offset) = constant.complex7;
3821 break;
3822 #endif
3824 #if FFETARGET_okCOMPLEX8
3825 case FFEINFO_kindtypeREAL8:
3826 *(array.complex8 + offset) = constant.complex8;
3827 break;
3828 #endif
3830 default:
3831 assert ("bad COMPLEX kindtype" == NULL);
3832 break;
3834 break;
3836 case FFEINFO_basictypeCHARACTER:
3837 switch (kt)
3839 #if FFETARGET_okCHARACTER1
3840 case FFEINFO_kindtypeCHARACTER1:
3841 memcpy (array.character1 + offset,
3842 ffetarget_text_character1 (constant.character1),
3843 ffetarget_length_character1 (constant.character1));
3844 break;
3845 #endif
3847 #if FFETARGET_okCHARACTER2
3848 case FFEINFO_kindtypeCHARACTER2:
3849 memcpy (array.character2 + offset,
3850 ffetarget_text_character2 (constant.character2),
3851 ffetarget_length_character2 (constant.character2));
3852 break;
3853 #endif
3855 #if FFETARGET_okCHARACTER3
3856 case FFEINFO_kindtypeCHARACTER3:
3857 memcpy (array.character3 + offset,
3858 ffetarget_text_character3 (constant.character3),
3859 ffetarget_length_character3 (constant.character3));
3860 break;
3861 #endif
3863 #if FFETARGET_okCHARACTER4
3864 case FFEINFO_kindtypeCHARACTER4:
3865 memcpy (array.character4 + offset,
3866 ffetarget_text_character4 (constant.character4),
3867 ffetarget_length_character4 (constant.character4));
3868 break;
3869 #endif
3871 #if FFETARGET_okCHARACTER5
3872 case FFEINFO_kindtypeCHARACTER5:
3873 memcpy (array.character5 + offset,
3874 ffetarget_text_character5 (constant.character5),
3875 ffetarget_length_character5 (constant.character5));
3876 break;
3877 #endif
3879 #if FFETARGET_okCHARACTER6
3880 case FFEINFO_kindtypeCHARACTER6:
3881 memcpy (array.character6 + offset,
3882 ffetarget_text_character6 (constant.character6),
3883 ffetarget_length_character6 (constant.character6));
3884 break;
3885 #endif
3887 #if FFETARGET_okCHARACTER7
3888 case FFEINFO_kindtypeCHARACTER7:
3889 memcpy (array.character7 + offset,
3890 ffetarget_text_character7 (constant.character7),
3891 ffetarget_length_character7 (constant.character7));
3892 break;
3893 #endif
3895 #if FFETARGET_okCHARACTER8
3896 case FFEINFO_kindtypeCHARACTER8:
3897 memcpy (array.character8 + offset,
3898 ffetarget_text_character8 (constant.character8),
3899 ffetarget_length_character8 (constant.character8));
3900 break;
3901 #endif
3903 default:
3904 assert ("bad CHARACTER kindtype" == NULL);
3905 break;
3907 break;
3909 default:
3910 assert ("bad basictype" == NULL);
3911 break;
3915 /* ffebld_init_0 -- Initialize the module
3917 ffebld_init_0(); */
3919 void
3920 ffebld_init_0 ()
3922 assert (FFEBLD_op == ARRAY_SIZE (ffebld_op_string_));
3923 assert (FFEBLD_op == ARRAY_SIZE (ffebld_arity_op_));
3926 /* ffebld_init_1 -- Initialize the module for a file
3928 ffebld_init_1(); */
3930 void
3931 ffebld_init_1 ()
3933 #if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstFILE_
3934 int i;
3936 #if FFETARGET_okCHARACTER1
3937 ffebld_constant_character1_ = NULL;
3938 #endif
3939 #if FFETARGET_okCHARACTER2
3940 ffebld_constant_character2_ = NULL;
3941 #endif
3942 #if FFETARGET_okCHARACTER3
3943 ffebld_constant_character3_ = NULL;
3944 #endif
3945 #if FFETARGET_okCHARACTER4
3946 ffebld_constant_character4_ = NULL;
3947 #endif
3948 #if FFETARGET_okCHARACTER5
3949 ffebld_constant_character5_ = NULL;
3950 #endif
3951 #if FFETARGET_okCHARACTER6
3952 ffebld_constant_character6_ = NULL;
3953 #endif
3954 #if FFETARGET_okCHARACTER7
3955 ffebld_constant_character7_ = NULL;
3956 #endif
3957 #if FFETARGET_okCHARACTER8
3958 ffebld_constant_character8_ = NULL;
3959 #endif
3960 #if FFETARGET_okCOMPLEX1
3961 ffebld_constant_complex1_ = NULL;
3962 #endif
3963 #if FFETARGET_okCOMPLEX2
3964 ffebld_constant_complex2_ = NULL;
3965 #endif
3966 #if FFETARGET_okCOMPLEX3
3967 ffebld_constant_complex3_ = NULL;
3968 #endif
3969 #if FFETARGET_okCOMPLEX4
3970 ffebld_constant_complex4_ = NULL;
3971 #endif
3972 #if FFETARGET_okCOMPLEX5
3973 ffebld_constant_complex5_ = NULL;
3974 #endif
3975 #if FFETARGET_okCOMPLEX6
3976 ffebld_constant_complex6_ = NULL;
3977 #endif
3978 #if FFETARGET_okCOMPLEX7
3979 ffebld_constant_complex7_ = NULL;
3980 #endif
3981 #if FFETARGET_okCOMPLEX8
3982 ffebld_constant_complex8_ = NULL;
3983 #endif
3984 #if FFETARGET_okINTEGER1
3985 ffebld_constant_integer1_ = NULL;
3986 #endif
3987 #if FFETARGET_okINTEGER2
3988 ffebld_constant_integer2_ = NULL;
3989 #endif
3990 #if FFETARGET_okINTEGER3
3991 ffebld_constant_integer3_ = NULL;
3992 #endif
3993 #if FFETARGET_okINTEGER4
3994 ffebld_constant_integer4_ = NULL;
3995 #endif
3996 #if FFETARGET_okINTEGER5
3997 ffebld_constant_integer5_ = NULL;
3998 #endif
3999 #if FFETARGET_okINTEGER6
4000 ffebld_constant_integer6_ = NULL;
4001 #endif
4002 #if FFETARGET_okINTEGER7
4003 ffebld_constant_integer7_ = NULL;
4004 #endif
4005 #if FFETARGET_okINTEGER8
4006 ffebld_constant_integer8_ = NULL;
4007 #endif
4008 #if FFETARGET_okLOGICAL1
4009 ffebld_constant_logical1_ = NULL;
4010 #endif
4011 #if FFETARGET_okLOGICAL2
4012 ffebld_constant_logical2_ = NULL;
4013 #endif
4014 #if FFETARGET_okLOGICAL3
4015 ffebld_constant_logical3_ = NULL;
4016 #endif
4017 #if FFETARGET_okLOGICAL4
4018 ffebld_constant_logical4_ = NULL;
4019 #endif
4020 #if FFETARGET_okLOGICAL5
4021 ffebld_constant_logical5_ = NULL;
4022 #endif
4023 #if FFETARGET_okLOGICAL6
4024 ffebld_constant_logical6_ = NULL;
4025 #endif
4026 #if FFETARGET_okLOGICAL7
4027 ffebld_constant_logical7_ = NULL;
4028 #endif
4029 #if FFETARGET_okLOGICAL8
4030 ffebld_constant_logical8_ = NULL;
4031 #endif
4032 #if FFETARGET_okREAL1
4033 ffebld_constant_real1_ = NULL;
4034 #endif
4035 #if FFETARGET_okREAL2
4036 ffebld_constant_real2_ = NULL;
4037 #endif
4038 #if FFETARGET_okREAL3
4039 ffebld_constant_real3_ = NULL;
4040 #endif
4041 #if FFETARGET_okREAL4
4042 ffebld_constant_real4_ = NULL;
4043 #endif
4044 #if FFETARGET_okREAL5
4045 ffebld_constant_real5_ = NULL;
4046 #endif
4047 #if FFETARGET_okREAL6
4048 ffebld_constant_real6_ = NULL;
4049 #endif
4050 #if FFETARGET_okREAL7
4051 ffebld_constant_real7_ = NULL;
4052 #endif
4053 #if FFETARGET_okREAL8
4054 ffebld_constant_real8_ = NULL;
4055 #endif
4056 ffebld_constant_hollerith_ = NULL;
4057 for (i = FFEBLD_constTYPELESS_FIRST; i <= FFEBLD_constTYPELESS_LAST; ++i)
4058 ffebld_constant_typeless_[i - FFEBLD_constTYPELESS_FIRST] = NULL;
4059 #endif
4062 /* ffebld_init_2 -- Initialize the module
4064 ffebld_init_2(); */
4066 void
4067 ffebld_init_2 ()
4069 #if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstPROGUNIT_
4070 int i;
4071 #endif
4073 ffebld_pool_stack_.next = NULL;
4074 ffebld_pool_stack_.pool = ffe_pool_program_unit ();
4075 #if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstPROGUNIT_
4076 #if FFETARGET_okCHARACTER1
4077 ffebld_constant_character1_ = NULL;
4078 #endif
4079 #if FFETARGET_okCHARACTER2
4080 ffebld_constant_character2_ = NULL;
4081 #endif
4082 #if FFETARGET_okCHARACTER3
4083 ffebld_constant_character3_ = NULL;
4084 #endif
4085 #if FFETARGET_okCHARACTER4
4086 ffebld_constant_character4_ = NULL;
4087 #endif
4088 #if FFETARGET_okCHARACTER5
4089 ffebld_constant_character5_ = NULL;
4090 #endif
4091 #if FFETARGET_okCHARACTER6
4092 ffebld_constant_character6_ = NULL;
4093 #endif
4094 #if FFETARGET_okCHARACTER7
4095 ffebld_constant_character7_ = NULL;
4096 #endif
4097 #if FFETARGET_okCHARACTER8
4098 ffebld_constant_character8_ = NULL;
4099 #endif
4100 #if FFETARGET_okCOMPLEX1
4101 ffebld_constant_complex1_ = NULL;
4102 #endif
4103 #if FFETARGET_okCOMPLEX2
4104 ffebld_constant_complex2_ = NULL;
4105 #endif
4106 #if FFETARGET_okCOMPLEX3
4107 ffebld_constant_complex3_ = NULL;
4108 #endif
4109 #if FFETARGET_okCOMPLEX4
4110 ffebld_constant_complex4_ = NULL;
4111 #endif
4112 #if FFETARGET_okCOMPLEX5
4113 ffebld_constant_complex5_ = NULL;
4114 #endif
4115 #if FFETARGET_okCOMPLEX6
4116 ffebld_constant_complex6_ = NULL;
4117 #endif
4118 #if FFETARGET_okCOMPLEX7
4119 ffebld_constant_complex7_ = NULL;
4120 #endif
4121 #if FFETARGET_okCOMPLEX8
4122 ffebld_constant_complex8_ = NULL;
4123 #endif
4124 #if FFETARGET_okINTEGER1
4125 ffebld_constant_integer1_ = NULL;
4126 #endif
4127 #if FFETARGET_okINTEGER2
4128 ffebld_constant_integer2_ = NULL;
4129 #endif
4130 #if FFETARGET_okINTEGER3
4131 ffebld_constant_integer3_ = NULL;
4132 #endif
4133 #if FFETARGET_okINTEGER4
4134 ffebld_constant_integer4_ = NULL;
4135 #endif
4136 #if FFETARGET_okINTEGER5
4137 ffebld_constant_integer5_ = NULL;
4138 #endif
4139 #if FFETARGET_okINTEGER6
4140 ffebld_constant_integer6_ = NULL;
4141 #endif
4142 #if FFETARGET_okINTEGER7
4143 ffebld_constant_integer7_ = NULL;
4144 #endif
4145 #if FFETARGET_okINTEGER8
4146 ffebld_constant_integer8_ = NULL;
4147 #endif
4148 #if FFETARGET_okLOGICAL1
4149 ffebld_constant_logical1_ = NULL;
4150 #endif
4151 #if FFETARGET_okLOGICAL2
4152 ffebld_constant_logical2_ = NULL;
4153 #endif
4154 #if FFETARGET_okLOGICAL3
4155 ffebld_constant_logical3_ = NULL;
4156 #endif
4157 #if FFETARGET_okLOGICAL4
4158 ffebld_constant_logical4_ = NULL;
4159 #endif
4160 #if FFETARGET_okLOGICAL5
4161 ffebld_constant_logical5_ = NULL;
4162 #endif
4163 #if FFETARGET_okLOGICAL6
4164 ffebld_constant_logical6_ = NULL;
4165 #endif
4166 #if FFETARGET_okLOGICAL7
4167 ffebld_constant_logical7_ = NULL;
4168 #endif
4169 #if FFETARGET_okLOGICAL8
4170 ffebld_constant_logical8_ = NULL;
4171 #endif
4172 #if FFETARGET_okREAL1
4173 ffebld_constant_real1_ = NULL;
4174 #endif
4175 #if FFETARGET_okREAL2
4176 ffebld_constant_real2_ = NULL;
4177 #endif
4178 #if FFETARGET_okREAL3
4179 ffebld_constant_real3_ = NULL;
4180 #endif
4181 #if FFETARGET_okREAL4
4182 ffebld_constant_real4_ = NULL;
4183 #endif
4184 #if FFETARGET_okREAL5
4185 ffebld_constant_real5_ = NULL;
4186 #endif
4187 #if FFETARGET_okREAL6
4188 ffebld_constant_real6_ = NULL;
4189 #endif
4190 #if FFETARGET_okREAL7
4191 ffebld_constant_real7_ = NULL;
4192 #endif
4193 #if FFETARGET_okREAL8
4194 ffebld_constant_real8_ = NULL;
4195 #endif
4196 ffebld_constant_hollerith_ = NULL;
4197 for (i = FFEBLD_constTYPELESS_FIRST; i <= FFEBLD_constTYPELESS_LAST; ++i)
4198 ffebld_constant_typeless_[i - FFEBLD_constTYPELESS_FIRST] = NULL;
4199 #endif
4202 /* ffebld_list_length -- Return # of opITEMs in list
4204 ffebld list; // Must be NULL or opITEM
4205 ffebldListLength length;
4206 length = ffebld_list_length(list);
4208 Returns 0 if list is NULL, 1 if it's ffebld_trail is NULL, and so on. */
4210 ffebldListLength
4211 ffebld_list_length (ffebld list)
4213 ffebldListLength length;
4215 for (length = 0; list != NULL; ++length, list = ffebld_trail (list))
4218 return length;
4221 /* ffebld_new_accter -- Create an ffebld object that is an array
4223 ffebld x;
4224 ffebldConstantArray a;
4225 ffebit b;
4226 x = ffebld_new_accter(a,b); */
4228 ffebld
4229 ffebld_new_accter (ffebldConstantArray a, ffebit b)
4231 ffebld x;
4233 x = ffebld_new ();
4234 #if FFEBLD_BLANK_
4235 *x = ffebld_blank_;
4236 #endif
4237 x->op = FFEBLD_opACCTER;
4238 x->u.accter.array = a;
4239 x->u.accter.bits = b;
4240 x->u.accter.pad = 0;
4241 return x;
4244 /* ffebld_new_arrter -- Create an ffebld object that is an array
4246 ffebld x;
4247 ffebldConstantArray a;
4248 ffetargetOffset size;
4249 x = ffebld_new_arrter(a,size); */
4251 ffebld
4252 ffebld_new_arrter (ffebldConstantArray a, ffetargetOffset size)
4254 ffebld x;
4256 x = ffebld_new ();
4257 #if FFEBLD_BLANK_
4258 *x = ffebld_blank_;
4259 #endif
4260 x->op = FFEBLD_opARRTER;
4261 x->u.arrter.array = a;
4262 x->u.arrter.size = size;
4263 x->u.arrter.pad = 0;
4264 return x;
4267 /* ffebld_new_conter_with_orig -- Create an ffebld object that is a constant
4269 ffebld x;
4270 ffebldConstant c;
4271 x = ffebld_new_conter_with_orig(c,NULL); */
4273 ffebld
4274 ffebld_new_conter_with_orig (ffebldConstant c, ffebld o)
4276 ffebld x;
4278 x = ffebld_new ();
4279 #if FFEBLD_BLANK_
4280 *x = ffebld_blank_;
4281 #endif
4282 x->op = FFEBLD_opCONTER;
4283 x->u.conter.expr = c;
4284 x->u.conter.orig = o;
4285 x->u.conter.pad = 0;
4286 return x;
4289 /* ffebld_new_item -- Create an ffebld item object
4291 ffebld x,y,z;
4292 x = ffebld_new_item(y,z); */
4294 ffebld
4295 ffebld_new_item (ffebld head, ffebld trail)
4297 ffebld x;
4299 x = ffebld_new ();
4300 #if FFEBLD_BLANK_
4301 *x = ffebld_blank_;
4302 #endif
4303 x->op = FFEBLD_opITEM;
4304 x->u.item.head = head;
4305 x->u.item.trail = trail;
4306 #ifdef FFECOM_itemHOOK
4307 x->u.item.hook = FFECOM_itemNULL;
4308 #endif
4309 return x;
4312 /* ffebld_new_labter -- Create an ffebld object that is a label
4314 ffebld x;
4315 ffelab l;
4316 x = ffebld_new_labter(c); */
4318 ffebld
4319 ffebld_new_labter (ffelab l)
4321 ffebld x;
4323 x = ffebld_new ();
4324 #if FFEBLD_BLANK_
4325 *x = ffebld_blank_;
4326 #endif
4327 x->op = FFEBLD_opLABTER;
4328 x->u.labter = l;
4329 return x;
4332 /* ffebld_new_labtok -- Create object that is a label's NUMBER token
4334 ffebld x;
4335 ffelexToken t;
4336 x = ffebld_new_labter(c);
4338 Like the other ffebld_new_ functions, the
4339 supplied argument is stored exactly as is: ffelex_token_use is NOT
4340 called, so the token is "consumed", if one is indeed supplied (it may
4341 be NULL). */
4343 ffebld
4344 ffebld_new_labtok (ffelexToken t)
4346 ffebld x;
4348 x = ffebld_new ();
4349 #if FFEBLD_BLANK_
4350 *x = ffebld_blank_;
4351 #endif
4352 x->op = FFEBLD_opLABTOK;
4353 x->u.labtok = t;
4354 return x;
4357 /* ffebld_new_none -- Create an ffebld object with no arguments
4359 ffebld x;
4360 x = ffebld_new_none(FFEBLD_opWHATEVER); */
4362 ffebld
4363 ffebld_new_none (ffebldOp o)
4365 ffebld x;
4367 x = ffebld_new ();
4368 #if FFEBLD_BLANK_
4369 *x = ffebld_blank_;
4370 #endif
4371 x->op = o;
4372 return x;
4375 /* ffebld_new_one -- Create an ffebld object with one argument
4377 ffebld x,y;
4378 x = ffebld_new_one(FFEBLD_opWHATEVER,y); */
4380 ffebld
4381 ffebld_new_one (ffebldOp o, ffebld left)
4383 ffebld x;
4385 x = ffebld_new ();
4386 #if FFEBLD_BLANK_
4387 *x = ffebld_blank_;
4388 #endif
4389 x->op = o;
4390 x->u.nonter.left = left;
4391 #ifdef FFECOM_nonterHOOK
4392 x->u.nonter.hook = FFECOM_nonterNULL;
4393 #endif
4394 return x;
4397 /* ffebld_new_symter -- Create an ffebld object that is a symbol
4399 ffebld x;
4400 ffesymbol s;
4401 ffeintrinGen gen; // Generic intrinsic id, if any
4402 ffeintrinSpec spec; // Specific intrinsic id, if any
4403 ffeintrinImp imp; // Implementation intrinsic id, if any
4404 x = ffebld_new_symter (s, gen, spec, imp); */
4406 ffebld
4407 ffebld_new_symter (ffesymbol s, ffeintrinGen gen, ffeintrinSpec spec,
4408 ffeintrinImp imp)
4410 ffebld x;
4412 x = ffebld_new ();
4413 #if FFEBLD_BLANK_
4414 *x = ffebld_blank_;
4415 #endif
4416 x->op = FFEBLD_opSYMTER;
4417 x->u.symter.symbol = s;
4418 x->u.symter.generic = gen;
4419 x->u.symter.specific = spec;
4420 x->u.symter.implementation = imp;
4421 x->u.symter.do_iter = FALSE;
4422 return x;
4425 /* ffebld_new_two -- Create an ffebld object with two arguments
4427 ffebld x,y,z;
4428 x = ffebld_new_two(FFEBLD_opWHATEVER,y,z); */
4430 ffebld
4431 ffebld_new_two (ffebldOp o, ffebld left, ffebld right)
4433 ffebld x;
4435 x = ffebld_new ();
4436 #if FFEBLD_BLANK_
4437 *x = ffebld_blank_;
4438 #endif
4439 x->op = o;
4440 x->u.nonter.left = left;
4441 x->u.nonter.right = right;
4442 #ifdef FFECOM_nonterHOOK
4443 x->u.nonter.hook = FFECOM_nonterNULL;
4444 #endif
4445 return x;
4448 /* ffebld_pool_pop -- Pop ffebld's pool stack
4450 ffebld_pool_pop(); */
4452 void
4453 ffebld_pool_pop ()
4455 ffebldPoolstack_ ps;
4457 assert (ffebld_pool_stack_.next != NULL);
4458 ps = ffebld_pool_stack_.next;
4459 ffebld_pool_stack_.next = ps->next;
4460 ffebld_pool_stack_.pool = ps->pool;
4461 malloc_kill_ks (malloc_pool_image (), ps, sizeof (*ps));
4464 /* ffebld_pool_push -- Push ffebld's pool stack
4466 ffebld_pool_push(); */
4468 void
4469 ffebld_pool_push (mallocPool pool)
4471 ffebldPoolstack_ ps;
4473 ps = malloc_new_ks (malloc_pool_image (), "Pool stack", sizeof (*ps));
4474 ps->next = ffebld_pool_stack_.next;
4475 ps->pool = ffebld_pool_stack_.pool;
4476 ffebld_pool_stack_.next = ps;
4477 ffebld_pool_stack_.pool = pool;
4480 /* ffebld_op_string -- Return short string describing op
4482 ffebldOp o;
4483 ffebld_op_string(o);
4485 Returns a short string (uppercase) containing the name of the op. */
4487 const char *
4488 ffebld_op_string (ffebldOp o)
4490 if (o >= ARRAY_SIZE (ffebld_op_string_))
4491 return "?\?\?";
4492 return ffebld_op_string_[o];
4495 /* ffebld_size_max -- Return maximum possible size of CHARACTER-type expr
4497 ffetargetCharacterSize sz;
4498 ffebld b;
4499 sz = ffebld_size_max (b);
4501 Like ffebld_size_known, but if that would return NONE and the expression
4502 is opSUBSTR, opCONVERT, opPAREN, or opCONCATENATE, returns ffebld_size_max
4503 of the subexpression(s). */
4505 ffetargetCharacterSize
4506 ffebld_size_max (ffebld b)
4508 ffetargetCharacterSize sz;
4510 recurse: /* :::::::::::::::::::: */
4512 sz = ffebld_size_known (b);
4514 if (sz != FFETARGET_charactersizeNONE)
4515 return sz;
4517 switch (ffebld_op (b))
4519 case FFEBLD_opSUBSTR:
4520 case FFEBLD_opCONVERT:
4521 case FFEBLD_opPAREN:
4522 b = ffebld_left (b);
4523 goto recurse; /* :::::::::::::::::::: */
4525 case FFEBLD_opCONCATENATE:
4526 sz = ffebld_size_max (ffebld_left (b))
4527 + ffebld_size_max (ffebld_right (b));
4528 return sz;
4530 default:
4531 return sz;