1 /* bld.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996 Free Software Foundation, Inc.
3 Contributed by James Craig Burley.
4
5 This file is part of GNU Fortran.
6
7 GNU Fortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
10 any later version.
11
12 GNU Fortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GNU Fortran; see the file COPYING. If not, write to
19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
20 02111-1307, USA.
21
22 Related Modules:
23 None
24
25 Description:
26 The primary "output" of the FFE includes ffebld objects, which
27 connect expressions, operators, and operands together, along with
28 connecting lists of expressions together for argument or dimension
29 lists.
30
31 Modifications:
32 30-Aug-92 JCB 1.1
33 Change names of some things for consistency.
34 */
35
36 /* Include files. */
37
38 #include "proj.h"
39 #include "bld.h"
40 #include "bit.h"
41 #include "info.h"
42 #include "lex.h"
43 #include "malloc.h"
44 #include "target.h"
45 #include "where.h"
46 #include "real.h"
47
48 /* Externals defined here. */
49
50 const ffebldArity ffebld_arity_op_[(int) FFEBLD_op]
51 =
52 {
53 #define FFEBLD_OP(KWD,NAME,ARITY) ARITY,
54 #include "bld-op.def"
55 #undef FFEBLD_OP
56 };
57 struct _ffebld_pool_stack_ ffebld_pool_stack_;
58
59 /* Simple definitions and enumerations. */
60
61
62 /* Internal typedefs. */
63
64
65 /* Private include files. */
66
67
68 /* Internal structure definitions. */
69
70
71 /* Static objects accessed by functions in this module. */
72
73 #if FFEBLD_BLANK_
74 static struct _ffebld_ ffebld_blank_
75 =
76 {
77 0,
78 {FFEINFO_basictypeNONE, FFEINFO_kindtypeNONE, 0, FFEINFO_kindNONE,
79 FFEINFO_whereNONE, FFETARGET_charactersizeNONE},
80 {NULL, NULL}
81 };
82 #endif
83 #if FFETARGET_okCHARACTER1
84 static ffebldConstant ffebld_constant_character1_;
85 #endif
86 #if FFETARGET_okCHARACTER2
87 static ffebldConstant ffebld_constant_character2_;
88 #endif
89 #if FFETARGET_okCHARACTER3
90 static ffebldConstant ffebld_constant_character3_;
91 #endif
92 #if FFETARGET_okCHARACTER4
93 static ffebldConstant ffebld_constant_character4_;
94 #endif
95 #if FFETARGET_okCHARACTER5
96 static ffebldConstant ffebld_constant_character5_;
97 #endif
98 #if FFETARGET_okCHARACTER6
99 static ffebldConstant ffebld_constant_character6_;
100 #endif
101 #if FFETARGET_okCHARACTER7
102 static ffebldConstant ffebld_constant_character7_;
103 #endif
104 #if FFETARGET_okCHARACTER8
105 static ffebldConstant ffebld_constant_character8_;
106 #endif
107 #if FFETARGET_okCOMPLEX1
108 static ffebldConstant ffebld_constant_complex1_;
109 #endif
110 #if FFETARGET_okCOMPLEX2
111 static ffebldConstant ffebld_constant_complex2_;
112 #endif
113 #if FFETARGET_okCOMPLEX3
114 static ffebldConstant ffebld_constant_complex3_;
115 #endif
116 #if FFETARGET_okCOMPLEX4
117 static ffebldConstant ffebld_constant_complex4_;
118 #endif
119 #if FFETARGET_okCOMPLEX5
120 static ffebldConstant ffebld_constant_complex5_;
121 #endif
122 #if FFETARGET_okCOMPLEX6
123 static ffebldConstant ffebld_constant_complex6_;
124 #endif
125 #if FFETARGET_okCOMPLEX7
126 static ffebldConstant ffebld_constant_complex7_;
127 #endif
128 #if FFETARGET_okCOMPLEX8
129 static ffebldConstant ffebld_constant_complex8_;
130 #endif
131 #if FFETARGET_okINTEGER1
132 static ffebldConstant ffebld_constant_integer1_;
133 #endif
134 #if FFETARGET_okINTEGER2
135 static ffebldConstant ffebld_constant_integer2_;
136 #endif
137 #if FFETARGET_okINTEGER3
138 static ffebldConstant ffebld_constant_integer3_;
139 #endif
140 #if FFETARGET_okINTEGER4
141 static ffebldConstant ffebld_constant_integer4_;
142 #endif
143 #if FFETARGET_okINTEGER5
144 static ffebldConstant ffebld_constant_integer5_;
145 #endif
146 #if FFETARGET_okINTEGER6
147 static ffebldConstant ffebld_constant_integer6_;
148 #endif
149 #if FFETARGET_okINTEGER7
150 static ffebldConstant ffebld_constant_integer7_;
151 #endif
152 #if FFETARGET_okINTEGER8
153 static ffebldConstant ffebld_constant_integer8_;
154 #endif
155 #if FFETARGET_okLOGICAL1
156 static ffebldConstant ffebld_constant_logical1_;
157 #endif
158 #if FFETARGET_okLOGICAL2
159 static ffebldConstant ffebld_constant_logical2_;
160 #endif
161 #if FFETARGET_okLOGICAL3
162 static ffebldConstant ffebld_constant_logical3_;
163 #endif
164 #if FFETARGET_okLOGICAL4
165 static ffebldConstant ffebld_constant_logical4_;
166 #endif
167 #if FFETARGET_okLOGICAL5
168 static ffebldConstant ffebld_constant_logical5_;
169 #endif
170 #if FFETARGET_okLOGICAL6
171 static ffebldConstant ffebld_constant_logical6_;
172 #endif
173 #if FFETARGET_okLOGICAL7
174 static ffebldConstant ffebld_constant_logical7_;
175 #endif
176 #if FFETARGET_okLOGICAL8
177 static ffebldConstant ffebld_constant_logical8_;
178 #endif
179 #if FFETARGET_okREAL1
180 static ffebldConstant ffebld_constant_real1_;
181 #endif
182 #if FFETARGET_okREAL2
183 static ffebldConstant ffebld_constant_real2_;
184 #endif
185 #if FFETARGET_okREAL3
186 static ffebldConstant ffebld_constant_real3_;
187 #endif
188 #if FFETARGET_okREAL4
189 static ffebldConstant ffebld_constant_real4_;
190 #endif
191 #if FFETARGET_okREAL5
192 static ffebldConstant ffebld_constant_real5_;
193 #endif
194 #if FFETARGET_okREAL6
195 static ffebldConstant ffebld_constant_real6_;
196 #endif
197 #if FFETARGET_okREAL7
198 static ffebldConstant ffebld_constant_real7_;
199 #endif
200 #if FFETARGET_okREAL8
201 static ffebldConstant ffebld_constant_real8_;
202 #endif
203 static ffebldConstant ffebld_constant_hollerith_;
204 static ffebldConstant ffebld_constant_typeless_[FFEBLD_constTYPELESS_LAST
205 - FFEBLD_constTYPELESS_FIRST + 1];
206
207 static const char *const ffebld_op_string_[]
208 =
209 {
210 #define FFEBLD_OP(KWD,NAME,ARITY) NAME,
211 #include "bld-op.def"
212 #undef FFEBLD_OP
213 };
214
215 /* Static functions (internal). */
216
217
218 /* Internal macros. */
219
220 #define integerdefault_ CATX(integer,FFETARGET_ktINTEGERDEFAULT)
221 #define logicaldefault_ CATX(logical,FFETARGET_ktLOGICALDEFAULT)
222 #define realdefault_ CATX(real,FFETARGET_ktREALDEFAULT)
223 #define realdouble_ CATX(real,FFETARGET_ktREALDOUBLE)
224 #define realquad_ CATX(real,FFETARGET_ktREALQUAD)
225
226 /* ffebld_constant_cmp -- Compare two constants a la strcmp
227
228 ffebldConstant c1, c2;
229 if (ffebld_constant_cmp(c1,c2) == 0)
230 // they're equal, else they're not.
231
232 Returns -1 if c1 < c2, 0 if c1 == c2, +1 if c1 == c2. */
233
234 int
ffebld_constant_cmp(ffebldConstant c1,ffebldConstant c2)235 ffebld_constant_cmp (ffebldConstant c1, ffebldConstant c2)
236 {
237 if (c1 == c2)
238 return 0;
239
240 assert (ffebld_constant_type (c1) == ffebld_constant_type (c2));
241
242 switch (ffebld_constant_type (c1))
243 {
244 #if FFETARGET_okINTEGER1
245 case FFEBLD_constINTEGER1:
246 return ffetarget_cmp_integer1 (ffebld_constant_integer1 (c1),
247 ffebld_constant_integer1 (c2));
248 #endif
249
250 #if FFETARGET_okINTEGER2
251 case FFEBLD_constINTEGER2:
252 return ffetarget_cmp_integer2 (ffebld_constant_integer2 (c1),
253 ffebld_constant_integer2 (c2));
254 #endif
255
256 #if FFETARGET_okINTEGER3
257 case FFEBLD_constINTEGER3:
258 return ffetarget_cmp_integer3 (ffebld_constant_integer3 (c1),
259 ffebld_constant_integer3 (c2));
260 #endif
261
262 #if FFETARGET_okINTEGER4
263 case FFEBLD_constINTEGER4:
264 return ffetarget_cmp_integer4 (ffebld_constant_integer4 (c1),
265 ffebld_constant_integer4 (c2));
266 #endif
267
268 #if FFETARGET_okINTEGER5
269 case FFEBLD_constINTEGER5:
270 return ffetarget_cmp_integer5 (ffebld_constant_integer5 (c1),
271 ffebld_constant_integer5 (c2));
272 #endif
273
274 #if FFETARGET_okINTEGER6
275 case FFEBLD_constINTEGER6:
276 return ffetarget_cmp_integer6 (ffebld_constant_integer6 (c1),
277 ffebld_constant_integer6 (c2));
278 #endif
279
280 #if FFETARGET_okINTEGER7
281 case FFEBLD_constINTEGER7:
282 return ffetarget_cmp_integer7 (ffebld_constant_integer7 (c1),
283 ffebld_constant_integer7 (c2));
284 #endif
285
286 #if FFETARGET_okINTEGER8
287 case FFEBLD_constINTEGER8:
288 return ffetarget_cmp_integer8 (ffebld_constant_integer8 (c1),
289 ffebld_constant_integer8 (c2));
290 #endif
291
292 #if FFETARGET_okLOGICAL1
293 case FFEBLD_constLOGICAL1:
294 return ffetarget_cmp_logical1 (ffebld_constant_logical1 (c1),
295 ffebld_constant_logical1 (c2));
296 #endif
297
298 #if FFETARGET_okLOGICAL2
299 case FFEBLD_constLOGICAL2:
300 return ffetarget_cmp_logical2 (ffebld_constant_logical2 (c1),
301 ffebld_constant_logical2 (c2));
302 #endif
303
304 #if FFETARGET_okLOGICAL3
305 case FFEBLD_constLOGICAL3:
306 return ffetarget_cmp_logical3 (ffebld_constant_logical3 (c1),
307 ffebld_constant_logical3 (c2));
308 #endif
309
310 #if FFETARGET_okLOGICAL4
311 case FFEBLD_constLOGICAL4:
312 return ffetarget_cmp_logical4 (ffebld_constant_logical4 (c1),
313 ffebld_constant_logical4 (c2));
314 #endif
315
316 #if FFETARGET_okLOGICAL5
317 case FFEBLD_constLOGICAL5:
318 return ffetarget_cmp_logical5 (ffebld_constant_logical5 (c1),
319 ffebld_constant_logical5 (c2));
320 #endif
321
322 #if FFETARGET_okLOGICAL6
323 case FFEBLD_constLOGICAL6:
324 return ffetarget_cmp_logical6 (ffebld_constant_logical6 (c1),
325 ffebld_constant_logical6 (c2));
326 #endif
327
328 #if FFETARGET_okLOGICAL7
329 case FFEBLD_constLOGICAL7:
330 return ffetarget_cmp_logical7 (ffebld_constant_logical7 (c1),
331 ffebld_constant_logical7 (c2));
332 #endif
333
334 #if FFETARGET_okLOGICAL8
335 case FFEBLD_constLOGICAL8:
336 return ffetarget_cmp_logical8 (ffebld_constant_logical8 (c1),
337 ffebld_constant_logical8 (c2));
338 #endif
339
340 #if FFETARGET_okREAL1
341 case FFEBLD_constREAL1:
342 return ffetarget_cmp_real1 (ffebld_constant_real1 (c1),
343 ffebld_constant_real1 (c2));
344 #endif
345
346 #if FFETARGET_okREAL2
347 case FFEBLD_constREAL2:
348 return ffetarget_cmp_real2 (ffebld_constant_real2 (c1),
349 ffebld_constant_real2 (c2));
350 #endif
351
352 #if FFETARGET_okREAL3
353 case FFEBLD_constREAL3:
354 return ffetarget_cmp_real3 (ffebld_constant_real3 (c1),
355 ffebld_constant_real3 (c2));
356 #endif
357
358 #if FFETARGET_okREAL4
359 case FFEBLD_constREAL4:
360 return ffetarget_cmp_real4 (ffebld_constant_real4 (c1),
361 ffebld_constant_real4 (c2));
362 #endif
363
364 #if FFETARGET_okREAL5
365 case FFEBLD_constREAL5:
366 return ffetarget_cmp_real5 (ffebld_constant_real5 (c1),
367 ffebld_constant_real5 (c2));
368 #endif
369
370 #if FFETARGET_okREAL6
371 case FFEBLD_constREAL6:
372 return ffetarget_cmp_real6 (ffebld_constant_real6 (c1),
373 ffebld_constant_real6 (c2));
374 #endif
375
376 #if FFETARGET_okREAL7
377 case FFEBLD_constREAL7:
378 return ffetarget_cmp_real7 (ffebld_constant_real7 (c1),
379 ffebld_constant_real7 (c2));
380 #endif
381
382 #if FFETARGET_okREAL8
383 case FFEBLD_constREAL8:
384 return ffetarget_cmp_real8 (ffebld_constant_real8 (c1),
385 ffebld_constant_real8 (c2));
386 #endif
387
388 #if FFETARGET_okCHARACTER1
389 case FFEBLD_constCHARACTER1:
390 return ffetarget_cmp_character1 (ffebld_constant_character1 (c1),
391 ffebld_constant_character1 (c2));
392 #endif
393
394 #if FFETARGET_okCHARACTER2
395 case FFEBLD_constCHARACTER2:
396 return ffetarget_cmp_character2 (ffebld_constant_character2 (c1),
397 ffebld_constant_character2 (c2));
398 #endif
399
400 #if FFETARGET_okCHARACTER3
401 case FFEBLD_constCHARACTER3:
402 return ffetarget_cmp_character3 (ffebld_constant_character3 (c1),
403 ffebld_constant_character3 (c2));
404 #endif
405
406 #if FFETARGET_okCHARACTER4
407 case FFEBLD_constCHARACTER4:
408 return ffetarget_cmp_character4 (ffebld_constant_character4 (c1),
409 ffebld_constant_character4 (c2));
410 #endif
411
412 #if FFETARGET_okCHARACTER5
413 case FFEBLD_constCHARACTER5:
414 return ffetarget_cmp_character5 (ffebld_constant_character5 (c1),
415 ffebld_constant_character5 (c2));
416 #endif
417
418 #if FFETARGET_okCHARACTER6
419 case FFEBLD_constCHARACTER6:
420 return ffetarget_cmp_character6 (ffebld_constant_character6 (c1),
421 ffebld_constant_character6 (c2));
422 #endif
423
424 #if FFETARGET_okCHARACTER7
425 case FFEBLD_constCHARACTER7:
426 return ffetarget_cmp_character7 (ffebld_constant_character7 (c1),
427 ffebld_constant_character7 (c2));
428 #endif
429
430 #if FFETARGET_okCHARACTER8
431 case FFEBLD_constCHARACTER8:
432 return ffetarget_cmp_character8 (ffebld_constant_character8 (c1),
433 ffebld_constant_character8 (c2));
434 #endif
435
436 default:
437 assert ("bad constant type" == NULL);
438 return 0;
439 }
440 }
441
442 /* ffebld_constant_is_magical -- Determine if integer is "magical"
443
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). */
448
449 bool
ffebld_constant_is_magical(ffebldConstant c)450 ffebld_constant_is_magical (ffebldConstant c)
451 {
452 switch (ffebld_constant_type (c))
453 {
454 case FFEBLD_constINTEGERDEFAULT:
455 return ffetarget_integerdefault_is_magical (ffebld_constant_integer1 (c));
456
457 default:
458 return FALSE;
459 }
460 }
461
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. */
465
466 bool
ffebld_constant_is_zero(ffebldConstant c)467 ffebld_constant_is_zero (ffebldConstant c)
468 {
469 switch (ffebld_constant_type (c))
470 {
471 #if FFETARGET_okINTEGER1
472 case FFEBLD_constINTEGER1:
473 return ffebld_constant_integer1 (c) == 0;
474 #endif
475
476 #if FFETARGET_okINTEGER2
477 case FFEBLD_constINTEGER2:
478 return ffebld_constant_integer2 (c) == 0;
479 #endif
480
481 #if FFETARGET_okINTEGER3
482 case FFEBLD_constINTEGER3:
483 return ffebld_constant_integer3 (c) == 0;
484 #endif
485
486 #if FFETARGET_okINTEGER4
487 case FFEBLD_constINTEGER4:
488 return ffebld_constant_integer4 (c) == 0;
489 #endif
490
491 #if FFETARGET_okINTEGER5
492 case FFEBLD_constINTEGER5:
493 return ffebld_constant_integer5 (c) == 0;
494 #endif
495
496 #if FFETARGET_okINTEGER6
497 case FFEBLD_constINTEGER6:
498 return ffebld_constant_integer6 (c) == 0;
499 #endif
500
501 #if FFETARGET_okINTEGER7
502 case FFEBLD_constINTEGER7:
503 return ffebld_constant_integer7 (c) == 0;
504 #endif
505
506 #if FFETARGET_okINTEGER8
507 case FFEBLD_constINTEGER8:
508 return ffebld_constant_integer8 (c) == 0;
509 #endif
510
511 #if FFETARGET_okLOGICAL1
512 case FFEBLD_constLOGICAL1:
513 return ffebld_constant_logical1 (c) == 0;
514 #endif
515
516 #if FFETARGET_okLOGICAL2
517 case FFEBLD_constLOGICAL2:
518 return ffebld_constant_logical2 (c) == 0;
519 #endif
520
521 #if FFETARGET_okLOGICAL3
522 case FFEBLD_constLOGICAL3:
523 return ffebld_constant_logical3 (c) == 0;
524 #endif
525
526 #if FFETARGET_okLOGICAL4
527 case FFEBLD_constLOGICAL4:
528 return ffebld_constant_logical4 (c) == 0;
529 #endif
530
531 #if FFETARGET_okLOGICAL5
532 case FFEBLD_constLOGICAL5:
533 return ffebld_constant_logical5 (c) == 0;
534 #endif
535
536 #if FFETARGET_okLOGICAL6
537 case FFEBLD_constLOGICAL6:
538 return ffebld_constant_logical6 (c) == 0;
539 #endif
540
541 #if FFETARGET_okLOGICAL7
542 case FFEBLD_constLOGICAL7:
543 return ffebld_constant_logical7 (c) == 0;
544 #endif
545
546 #if FFETARGET_okLOGICAL8
547 case FFEBLD_constLOGICAL8:
548 return ffebld_constant_logical8 (c) == 0;
549 #endif
550
551 #if FFETARGET_okREAL1
552 case FFEBLD_constREAL1:
553 return ffetarget_iszero_real1 (ffebld_constant_real1 (c));
554 #endif
555
556 #if FFETARGET_okREAL2
557 case FFEBLD_constREAL2:
558 return ffetarget_iszero_real2 (ffebld_constant_real2 (c));
559 #endif
560
561 #if FFETARGET_okREAL3
562 case FFEBLD_constREAL3:
563 return ffetarget_iszero_real3 (ffebld_constant_real3 (c));
564 #endif
565
566 #if FFETARGET_okREAL4
567 case FFEBLD_constREAL4:
568 return ffetarget_iszero_real4 (ffebld_constant_real4 (c));
569 #endif
570
571 #if FFETARGET_okREAL5
572 case FFEBLD_constREAL5:
573 return ffetarget_iszero_real5 (ffebld_constant_real5 (c));
574 #endif
575
576 #if FFETARGET_okREAL6
577 case FFEBLD_constREAL6:
578 return ffetarget_iszero_real6 (ffebld_constant_real6 (c));
579 #endif
580
581 #if FFETARGET_okREAL7
582 case FFEBLD_constREAL7:
583 return ffetarget_iszero_real7 (ffebld_constant_real7 (c));
584 #endif
585
586 #if FFETARGET_okREAL8
587 case FFEBLD_constREAL8:
588 return ffetarget_iszero_real8 (ffebld_constant_real8 (c));
589 #endif
590
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
596
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
602
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
608
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
614
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
620
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
626
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
632
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
638
639 #if FFETARGET_okCHARACTER1
640 case FFEBLD_constCHARACTER1:
641 return ffetarget_iszero_character1 (ffebld_constant_character1 (c));
642 #endif
643
644 #if FFETARGET_okCHARACTER2 || FFETARGET_okCHARACTER3 /* ... */
645 #error "no support for these!!"
646 #endif
647
648 case FFEBLD_constHOLLERITH:
649 return ffetarget_iszero_hollerith (ffebld_constant_hollerith (c));
650
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));
660
661 default:
662 return FALSE;
663 }
664 }
665
666 /* ffebld_constant_new_character1 -- Return character1 constant object from token
667
668 See prototype. */
669
670 #if FFETARGET_okCHARACTER1
671 ffebldConstant
ffebld_constant_new_character1(ffelexToken t)672 ffebld_constant_new_character1 (ffelexToken t)
673 {
674 ffetargetCharacter1 val;
675
676 ffetarget_character1 (&val, t, ffebld_constant_pool());
677 return ffebld_constant_new_character1_val (val);
678 }
679
680 #endif
681 /* ffebld_constant_new_character1_val -- Return an character1 constant object
682
683 See prototype. */
684
685 #if FFETARGET_okCHARACTER1
686 ffebldConstant
ffebld_constant_new_character1_val(ffetargetCharacter1 val)687 ffebld_constant_new_character1_val (ffetargetCharacter1 val)
688 {
689 ffebldConstant c;
690 ffebldConstant nc;
691 int cmp;
692
693 ffetarget_verify_character1 (ffebld_constant_pool(), val);
694
695 for (c = (ffebldConstant) &ffebld_constant_character1_;
696 c->next != NULL;
697 c = c->next)
698 {
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;
710 }
711
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;
722
723 return nc;
724 }
725
726 #endif
727 /* ffebld_constant_new_complex1 -- Return complex1 constant object from token
728
729 See prototype. */
730
731 #if FFETARGET_okCOMPLEX1
732 ffebldConstant
ffebld_constant_new_complex1(ffebldConstant real,ffebldConstant imaginary)733 ffebld_constant_new_complex1 (ffebldConstant real,
734 ffebldConstant imaginary)
735 {
736 ffetargetComplex1 val;
737
738 val.real = ffebld_constant_real1 (real);
739 val.imaginary = ffebld_constant_real1 (imaginary);
740 return ffebld_constant_new_complex1_val (val);
741 }
742
743 #endif
744 /* ffebld_constant_new_complex1_val -- Return a complex1 constant object
745
746 See prototype. */
747
748 #if FFETARGET_okCOMPLEX1
749 ffebldConstant
ffebld_constant_new_complex1_val(ffetargetComplex1 val)750 ffebld_constant_new_complex1_val (ffetargetComplex1 val)
751 {
752 ffebldConstant c;
753 ffebldConstant nc;
754 int cmp;
755
756 for (c = (ffebldConstant) &ffebld_constant_complex1_;
757 c->next != NULL;
758 c = c->next)
759 {
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;
768 }
769
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;
780
781 return nc;
782 }
783
784 #endif
785 /* ffebld_constant_new_complex2 -- Return complex2 constant object from token
786
787 See prototype. */
788
789 #if FFETARGET_okCOMPLEX2
790 ffebldConstant
ffebld_constant_new_complex2(ffebldConstant real,ffebldConstant imaginary)791 ffebld_constant_new_complex2 (ffebldConstant real,
792 ffebldConstant imaginary)
793 {
794 ffetargetComplex2 val;
795
796 val.real = ffebld_constant_real2 (real);
797 val.imaginary = ffebld_constant_real2 (imaginary);
798 return ffebld_constant_new_complex2_val (val);
799 }
800
801 #endif
802 /* ffebld_constant_new_complex2_val -- Return a complex2 constant object
803
804 See prototype. */
805
806 #if FFETARGET_okCOMPLEX2
807 ffebldConstant
ffebld_constant_new_complex2_val(ffetargetComplex2 val)808 ffebld_constant_new_complex2_val (ffetargetComplex2 val)
809 {
810 ffebldConstant c;
811 ffebldConstant nc;
812 int cmp;
813
814 for (c = (ffebldConstant) &ffebld_constant_complex2_;
815 c->next != NULL;
816 c = c->next)
817 {
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;
826 }
827
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;
838
839 return nc;
840 }
841
842 #endif
843 /* ffebld_constant_new_hollerith -- Return hollerith constant object from token
844
845 See prototype. */
846
847 ffebldConstant
ffebld_constant_new_hollerith(ffelexToken t)848 ffebld_constant_new_hollerith (ffelexToken t)
849 {
850 ffetargetHollerith val;
851
852 ffetarget_hollerith (&val, t, ffebld_constant_pool());
853 return ffebld_constant_new_hollerith_val (val);
854 }
855
856 /* ffebld_constant_new_hollerith_val -- Return an hollerith constant object
857
858 See prototype. */
859
860 ffebldConstant
ffebld_constant_new_hollerith_val(ffetargetHollerith val)861 ffebld_constant_new_hollerith_val (ffetargetHollerith val)
862 {
863 ffebldConstant c;
864 ffebldConstant nc;
865 int cmp;
866
867 for (c = (ffebldConstant) &ffebld_constant_hollerith_;
868 c->next != NULL;
869 c = c->next)
870 {
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;
876 }
877
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;
888
889 return nc;
890 }
891
892 /* ffebld_constant_new_integer1 -- Return integer1 constant object from token
893
894 See prototype.
895
896 Parses the token as a decimal integer constant, thus it must be an
897 FFELEX_typeNUMBER. */
898
899 #if FFETARGET_okINTEGER1
900 ffebldConstant
ffebld_constant_new_integer1(ffelexToken t)901 ffebld_constant_new_integer1 (ffelexToken t)
902 {
903 ffetargetInteger1 val;
904
905 assert (ffelex_token_type (t) == FFELEX_typeNUMBER);
906
907 ffetarget_integer1 (&val, t);
908 return ffebld_constant_new_integer1_val (val);
909 }
910
911 #endif
912 /* ffebld_constant_new_integer1_val -- Return an integer1 constant object
913
914 See prototype. */
915
916 #if FFETARGET_okINTEGER1
917 ffebldConstant
ffebld_constant_new_integer1_val(ffetargetInteger1 val)918 ffebld_constant_new_integer1_val (ffetargetInteger1 val)
919 {
920 ffebldConstant c;
921 ffebldConstant nc;
922 int cmp;
923
924 for (c = (ffebldConstant) &ffebld_constant_integer1_;
925 c->next != NULL;
926 c = c->next)
927 {
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;
933 }
934
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;
945
946 return nc;
947 }
948
949 #endif
950 /* ffebld_constant_new_integer2_val -- Return an integer2 constant object
951
952 See prototype. */
953
954 #if FFETARGET_okINTEGER2
955 ffebldConstant
ffebld_constant_new_integer2_val(ffetargetInteger2 val)956 ffebld_constant_new_integer2_val (ffetargetInteger2 val)
957 {
958 ffebldConstant c;
959 ffebldConstant nc;
960 int cmp;
961
962 for (c = (ffebldConstant) &ffebld_constant_integer2_;
963 c->next != NULL;
964 c = c->next)
965 {
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;
971 }
972
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;
983
984 return nc;
985 }
986
987 #endif
988 /* ffebld_constant_new_integer3_val -- Return an integer3 constant object
989
990 See prototype. */
991
992 #if FFETARGET_okINTEGER3
993 ffebldConstant
ffebld_constant_new_integer3_val(ffetargetInteger3 val)994 ffebld_constant_new_integer3_val (ffetargetInteger3 val)
995 {
996 ffebldConstant c;
997 ffebldConstant nc;
998 int cmp;
999
1000 for (c = (ffebldConstant) &ffebld_constant_integer3_;
1001 c->next != NULL;
1002 c = c->next)
1003 {
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;
1009 }
1010
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;
1021
1022 return nc;
1023 }
1024
1025 #endif
1026 /* ffebld_constant_new_integer4_val -- Return an integer4 constant object
1027
1028 See prototype. */
1029
1030 #if FFETARGET_okINTEGER4
1031 ffebldConstant
ffebld_constant_new_integer4_val(ffetargetInteger4 val)1032 ffebld_constant_new_integer4_val (ffetargetInteger4 val)
1033 {
1034 ffebldConstant c;
1035 ffebldConstant nc;
1036 int cmp;
1037
1038 for (c = (ffebldConstant) &ffebld_constant_integer4_;
1039 c->next != NULL;
1040 c = c->next)
1041 {
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;
1047 }
1048
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;
1059
1060 return nc;
1061 }
1062
1063 #endif
1064 /* ffebld_constant_new_integerbinary -- Return binary constant object from token
1065
1066 See prototype.
1067
1068 Parses the token as a binary integer constant, thus it must be an
1069 FFELEX_typeNUMBER. */
1070
1071 ffebldConstant
ffebld_constant_new_integerbinary(ffelexToken t)1072 ffebld_constant_new_integerbinary (ffelexToken t)
1073 {
1074 ffetargetIntegerDefault val;
1075
1076 assert ((ffelex_token_type (t) == FFELEX_typeNAME)
1077 || (ffelex_token_type (t) == FFELEX_typeNUMBER));
1078
1079 ffetarget_integerbinary (&val, t);
1080 return ffebld_constant_new_integerdefault_val (val);
1081 }
1082
1083 /* ffebld_constant_new_integerhex -- Return hex constant object from token
1084
1085 See prototype.
1086
1087 Parses the token as a hex integer constant, thus it must be an
1088 FFELEX_typeNUMBER. */
1089
1090 ffebldConstant
ffebld_constant_new_integerhex(ffelexToken t)1091 ffebld_constant_new_integerhex (ffelexToken t)
1092 {
1093 ffetargetIntegerDefault val;
1094
1095 assert ((ffelex_token_type (t) == FFELEX_typeNAME)
1096 || (ffelex_token_type (t) == FFELEX_typeNUMBER));
1097
1098 ffetarget_integerhex (&val, t);
1099 return ffebld_constant_new_integerdefault_val (val);
1100 }
1101
1102 /* ffebld_constant_new_integeroctal -- Return octal constant object from token
1103
1104 See prototype.
1105
1106 Parses the token as a octal integer constant, thus it must be an
1107 FFELEX_typeNUMBER. */
1108
1109 ffebldConstant
ffebld_constant_new_integeroctal(ffelexToken t)1110 ffebld_constant_new_integeroctal (ffelexToken t)
1111 {
1112 ffetargetIntegerDefault val;
1113
1114 assert ((ffelex_token_type (t) == FFELEX_typeNAME)
1115 || (ffelex_token_type (t) == FFELEX_typeNUMBER));
1116
1117 ffetarget_integeroctal (&val, t);
1118 return ffebld_constant_new_integerdefault_val (val);
1119 }
1120
1121 /* ffebld_constant_new_logical1 -- Return logical1 constant object from token
1122
1123 See prototype.
1124
1125 Parses the token as a decimal logical constant, thus it must be an
1126 FFELEX_typeNUMBER. */
1127
1128 #if FFETARGET_okLOGICAL1
1129 ffebldConstant
ffebld_constant_new_logical1(bool truth)1130 ffebld_constant_new_logical1 (bool truth)
1131 {
1132 ffetargetLogical1 val;
1133
1134 ffetarget_logical1 (&val, truth);
1135 return ffebld_constant_new_logical1_val (val);
1136 }
1137
1138 #endif
1139 /* ffebld_constant_new_logical1_val -- Return a logical1 constant object
1140
1141 See prototype. */
1142
1143 #if FFETARGET_okLOGICAL1
1144 ffebldConstant
ffebld_constant_new_logical1_val(ffetargetLogical1 val)1145 ffebld_constant_new_logical1_val (ffetargetLogical1 val)
1146 {
1147 ffebldConstant c;
1148 ffebldConstant nc;
1149 int cmp;
1150
1151 for (c = (ffebldConstant) &ffebld_constant_logical1_;
1152 c->next != NULL;
1153 c = c->next)
1154 {
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;
1160 }
1161
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;
1172
1173 return nc;
1174 }
1175
1176 #endif
1177 /* ffebld_constant_new_logical2_val -- Return a logical2 constant object
1178
1179 See prototype. */
1180
1181 #if FFETARGET_okLOGICAL2
1182 ffebldConstant
ffebld_constant_new_logical2_val(ffetargetLogical2 val)1183 ffebld_constant_new_logical2_val (ffetargetLogical2 val)
1184 {
1185 ffebldConstant c;
1186 ffebldConstant nc;
1187 int cmp;
1188
1189 for (c = (ffebldConstant) &ffebld_constant_logical2_;
1190 c->next != NULL;
1191 c = c->next)
1192 {
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;
1198 }
1199
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;
1210
1211 return nc;
1212 }
1213
1214 #endif
1215 /* ffebld_constant_new_logical3_val -- Return a logical3 constant object
1216
1217 See prototype. */
1218
1219 #if FFETARGET_okLOGICAL3
1220 ffebldConstant
ffebld_constant_new_logical3_val(ffetargetLogical3 val)1221 ffebld_constant_new_logical3_val (ffetargetLogical3 val)
1222 {
1223 ffebldConstant c;
1224 ffebldConstant nc;
1225 int cmp;
1226
1227 for (c = (ffebldConstant) &ffebld_constant_logical3_;
1228 c->next != NULL;
1229 c = c->next)
1230 {
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;
1236 }
1237
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;
1248
1249 return nc;
1250 }
1251
1252 #endif
1253 /* ffebld_constant_new_logical4_val -- Return a logical4 constant object
1254
1255 See prototype. */
1256
1257 #if FFETARGET_okLOGICAL4
1258 ffebldConstant
ffebld_constant_new_logical4_val(ffetargetLogical4 val)1259 ffebld_constant_new_logical4_val (ffetargetLogical4 val)
1260 {
1261 ffebldConstant c;
1262 ffebldConstant nc;
1263 int cmp;
1264
1265 for (c = (ffebldConstant) &ffebld_constant_logical4_;
1266 c->next != NULL;
1267 c = c->next)
1268 {
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;
1274 }
1275
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;
1286
1287 return nc;
1288 }
1289
1290 #endif
1291 /* ffebld_constant_new_real1 -- Return real1 constant object from token
1292
1293 See prototype. */
1294
1295 #if FFETARGET_okREAL1
1296 ffebldConstant
ffebld_constant_new_real1(ffelexToken integer,ffelexToken decimal,ffelexToken fraction,ffelexToken exponent,ffelexToken exponent_sign,ffelexToken exponent_digits)1297 ffebld_constant_new_real1 (ffelexToken integer, ffelexToken decimal,
1298 ffelexToken fraction, ffelexToken exponent, ffelexToken exponent_sign,
1299 ffelexToken exponent_digits)
1300 {
1301 ffetargetReal1 val;
1302
1303 ffetarget_real1 (&val,
1304 integer, decimal, fraction, exponent, exponent_sign, exponent_digits);
1305 return ffebld_constant_new_real1_val (val);
1306 }
1307
1308 #endif
1309 /* ffebld_constant_new_real1_val -- Return an real1 constant object
1310
1311 See prototype. */
1312
1313 #if FFETARGET_okREAL1
1314 ffebldConstant
ffebld_constant_new_real1_val(ffetargetReal1 val)1315 ffebld_constant_new_real1_val (ffetargetReal1 val)
1316 {
1317 ffebldConstant c;
1318 ffebldConstant nc;
1319 int cmp;
1320
1321 for (c = (ffebldConstant) &ffebld_constant_real1_;
1322 c->next != NULL;
1323 c = c->next)
1324 {
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;
1330 }
1331
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;
1342
1343 return nc;
1344 }
1345
1346 #endif
1347 /* ffebld_constant_new_real2 -- Return real2 constant object from token
1348
1349 See prototype. */
1350
1351 #if FFETARGET_okREAL2
1352 ffebldConstant
ffebld_constant_new_real2(ffelexToken integer,ffelexToken decimal,ffelexToken fraction,ffelexToken exponent,ffelexToken exponent_sign,ffelexToken exponent_digits)1353 ffebld_constant_new_real2 (ffelexToken integer, ffelexToken decimal,
1354 ffelexToken fraction, ffelexToken exponent, ffelexToken exponent_sign,
1355 ffelexToken exponent_digits)
1356 {
1357 ffetargetReal2 val;
1358
1359 ffetarget_real2 (&val,
1360 integer, decimal, fraction, exponent, exponent_sign, exponent_digits);
1361 return ffebld_constant_new_real2_val (val);
1362 }
1363
1364 #endif
1365 /* ffebld_constant_new_real2_val -- Return an real2 constant object
1366
1367 See prototype. */
1368
1369 #if FFETARGET_okREAL2
1370 ffebldConstant
ffebld_constant_new_real2_val(ffetargetReal2 val)1371 ffebld_constant_new_real2_val (ffetargetReal2 val)
1372 {
1373 ffebldConstant c;
1374 ffebldConstant nc;
1375 int cmp;
1376
1377 for (c = (ffebldConstant) &ffebld_constant_real2_;
1378 c->next != NULL;
1379 c = c->next)
1380 {
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;
1386 }
1387
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;
1398
1399 return nc;
1400 }
1401
1402 #endif
1403 /* ffebld_constant_new_typeless_bm -- Return typeless constant object from token
1404
1405 See prototype.
1406
1407 Parses the token as a decimal integer constant, thus it must be an
1408 FFELEX_typeNUMBER. */
1409
1410 ffebldConstant
ffebld_constant_new_typeless_bm(ffelexToken t)1411 ffebld_constant_new_typeless_bm (ffelexToken t)
1412 {
1413 ffetargetTypeless val;
1414
1415 ffetarget_binarymil (&val, t);
1416 return ffebld_constant_new_typeless_val (FFEBLD_constBINARY_MIL, val);
1417 }
1418
1419 /* ffebld_constant_new_typeless_bv -- Return typeless constant object from token
1420
1421 See prototype.
1422
1423 Parses the token as a decimal integer constant, thus it must be an
1424 FFELEX_typeNUMBER. */
1425
1426 ffebldConstant
ffebld_constant_new_typeless_bv(ffelexToken t)1427 ffebld_constant_new_typeless_bv (ffelexToken t)
1428 {
1429 ffetargetTypeless val;
1430
1431 ffetarget_binaryvxt (&val, t);
1432 return ffebld_constant_new_typeless_val (FFEBLD_constBINARY_VXT, val);
1433 }
1434
1435 /* ffebld_constant_new_typeless_hxm -- Return typeless constant object from token
1436
1437 See prototype.
1438
1439 Parses the token as a decimal integer constant, thus it must be an
1440 FFELEX_typeNUMBER. */
1441
1442 ffebldConstant
ffebld_constant_new_typeless_hxm(ffelexToken t)1443 ffebld_constant_new_typeless_hxm (ffelexToken t)
1444 {
1445 ffetargetTypeless val;
1446
1447 ffetarget_hexxmil (&val, t);
1448 return ffebld_constant_new_typeless_val (FFEBLD_constHEX_X_MIL, val);
1449 }
1450
1451 /* ffebld_constant_new_typeless_hxv -- Return typeless constant object from token
1452
1453 See prototype.
1454
1455 Parses the token as a decimal integer constant, thus it must be an
1456 FFELEX_typeNUMBER. */
1457
1458 ffebldConstant
ffebld_constant_new_typeless_hxv(ffelexToken t)1459 ffebld_constant_new_typeless_hxv (ffelexToken t)
1460 {
1461 ffetargetTypeless val;
1462
1463 ffetarget_hexxvxt (&val, t);
1464 return ffebld_constant_new_typeless_val (FFEBLD_constHEX_X_VXT, val);
1465 }
1466
1467 /* ffebld_constant_new_typeless_hzm -- Return typeless constant object from token
1468
1469 See prototype.
1470
1471 Parses the token as a decimal integer constant, thus it must be an
1472 FFELEX_typeNUMBER. */
1473
1474 ffebldConstant
ffebld_constant_new_typeless_hzm(ffelexToken t)1475 ffebld_constant_new_typeless_hzm (ffelexToken t)
1476 {
1477 ffetargetTypeless val;
1478
1479 ffetarget_hexzmil (&val, t);
1480 return ffebld_constant_new_typeless_val (FFEBLD_constHEX_Z_MIL, val);
1481 }
1482
1483 /* ffebld_constant_new_typeless_hzv -- Return typeless constant object from token
1484
1485 See prototype.
1486
1487 Parses the token as a decimal integer constant, thus it must be an
1488 FFELEX_typeNUMBER. */
1489
1490 ffebldConstant
ffebld_constant_new_typeless_hzv(ffelexToken t)1491 ffebld_constant_new_typeless_hzv (ffelexToken t)
1492 {
1493 ffetargetTypeless val;
1494
1495 ffetarget_hexzvxt (&val, t);
1496 return ffebld_constant_new_typeless_val (FFEBLD_constHEX_Z_VXT, val);
1497 }
1498
1499 /* ffebld_constant_new_typeless_om -- Return typeless constant object from token
1500
1501 See prototype.
1502
1503 Parses the token as a decimal integer constant, thus it must be an
1504 FFELEX_typeNUMBER. */
1505
1506 ffebldConstant
ffebld_constant_new_typeless_om(ffelexToken t)1507 ffebld_constant_new_typeless_om (ffelexToken t)
1508 {
1509 ffetargetTypeless val;
1510
1511 ffetarget_octalmil (&val, t);
1512 return ffebld_constant_new_typeless_val (FFEBLD_constOCTAL_MIL, val);
1513 }
1514
1515 /* ffebld_constant_new_typeless_ov -- Return typeless constant object from token
1516
1517 See prototype.
1518
1519 Parses the token as a decimal integer constant, thus it must be an
1520 FFELEX_typeNUMBER. */
1521
1522 ffebldConstant
ffebld_constant_new_typeless_ov(ffelexToken t)1523 ffebld_constant_new_typeless_ov (ffelexToken t)
1524 {
1525 ffetargetTypeless val;
1526
1527 ffetarget_octalvxt (&val, t);
1528 return ffebld_constant_new_typeless_val (FFEBLD_constOCTAL_VXT, val);
1529 }
1530
1531 /* ffebld_constant_new_typeless_val -- Return a typeless constant object
1532
1533 See prototype. */
1534
1535 ffebldConstant
ffebld_constant_new_typeless_val(ffebldConst type,ffetargetTypeless val)1536 ffebld_constant_new_typeless_val (ffebldConst type, ffetargetTypeless val)
1537 {
1538 ffebldConstant c;
1539 ffebldConstant nc;
1540 int cmp;
1541
1542 for (c = (ffebldConstant) &ffebld_constant_typeless_[type
1543 - FFEBLD_constTYPELESS_FIRST];
1544 c->next != NULL;
1545 c = c->next)
1546 {
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;
1552 }
1553
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;
1564
1565 return nc;
1566 }
1567
1568 /* ffebld_constantarray_get -- Get a value from an array of constants
1569
1570 See prototype. */
1571
1572 ffebldConstantUnion
ffebld_constantarray_get(ffebldConstantArray array,ffeinfoBasictype bt,ffeinfoKindtype kt,ffetargetOffset offset)1573 ffebld_constantarray_get (ffebldConstantArray array, ffeinfoBasictype bt,
1574 ffeinfoKindtype kt, ffetargetOffset offset)
1575 {
1576 ffebldConstantUnion u;
1577
1578 switch (bt)
1579 {
1580 case FFEINFO_basictypeINTEGER:
1581 switch (kt)
1582 {
1583 #if FFETARGET_okINTEGER1
1584 case FFEINFO_kindtypeINTEGER1:
1585 u.integer1 = *(array.integer1 + offset);
1586 break;
1587 #endif
1588
1589 #if FFETARGET_okINTEGER2
1590 case FFEINFO_kindtypeINTEGER2:
1591 u.integer2 = *(array.integer2 + offset);
1592 break;
1593 #endif
1594
1595 #if FFETARGET_okINTEGER3
1596 case FFEINFO_kindtypeINTEGER3:
1597 u.integer3 = *(array.integer3 + offset);
1598 break;
1599 #endif
1600
1601 #if FFETARGET_okINTEGER4
1602 case FFEINFO_kindtypeINTEGER4:
1603 u.integer4 = *(array.integer4 + offset);
1604 break;
1605 #endif
1606
1607 #if FFETARGET_okINTEGER5
1608 case FFEINFO_kindtypeINTEGER5:
1609 u.integer5 = *(array.integer5 + offset);
1610 break;
1611 #endif
1612
1613 #if FFETARGET_okINTEGER6
1614 case FFEINFO_kindtypeINTEGER6:
1615 u.integer6 = *(array.integer6 + offset);
1616 break;
1617 #endif
1618
1619 #if FFETARGET_okINTEGER7
1620 case FFEINFO_kindtypeINTEGER7:
1621 u.integer7 = *(array.integer7 + offset);
1622 break;
1623 #endif
1624
1625 #if FFETARGET_okINTEGER8
1626 case FFEINFO_kindtypeINTEGER8:
1627 u.integer8 = *(array.integer8 + offset);
1628 break;
1629 #endif
1630
1631 default:
1632 assert ("bad INTEGER kindtype" == NULL);
1633 break;
1634 }
1635 break;
1636
1637 case FFEINFO_basictypeLOGICAL:
1638 switch (kt)
1639 {
1640 #if FFETARGET_okLOGICAL1
1641 case FFEINFO_kindtypeLOGICAL1:
1642 u.logical1 = *(array.logical1 + offset);
1643 break;
1644 #endif
1645
1646 #if FFETARGET_okLOGICAL2
1647 case FFEINFO_kindtypeLOGICAL2:
1648 u.logical2 = *(array.logical2 + offset);
1649 break;
1650 #endif
1651
1652 #if FFETARGET_okLOGICAL3
1653 case FFEINFO_kindtypeLOGICAL3:
1654 u.logical3 = *(array.logical3 + offset);
1655 break;
1656 #endif
1657
1658 #if FFETARGET_okLOGICAL4
1659 case FFEINFO_kindtypeLOGICAL4:
1660 u.logical4 = *(array.logical4 + offset);
1661 break;
1662 #endif
1663
1664 #if FFETARGET_okLOGICAL5
1665 case FFEINFO_kindtypeLOGICAL5:
1666 u.logical5 = *(array.logical5 + offset);
1667 break;
1668 #endif
1669
1670 #if FFETARGET_okLOGICAL6
1671 case FFEINFO_kindtypeLOGICAL6:
1672 u.logical6 = *(array.logical6 + offset);
1673 break;
1674 #endif
1675
1676 #if FFETARGET_okLOGICAL7
1677 case FFEINFO_kindtypeLOGICAL7:
1678 u.logical7 = *(array.logical7 + offset);
1679 break;
1680 #endif
1681
1682 #if FFETARGET_okLOGICAL8
1683 case FFEINFO_kindtypeLOGICAL8:
1684 u.logical8 = *(array.logical8 + offset);
1685 break;
1686 #endif
1687
1688 default:
1689 assert ("bad LOGICAL kindtype" == NULL);
1690 break;
1691 }
1692 break;
1693
1694 case FFEINFO_basictypeREAL:
1695 switch (kt)
1696 {
1697 #if FFETARGET_okREAL1
1698 case FFEINFO_kindtypeREAL1:
1699 u.real1 = *(array.real1 + offset);
1700 break;
1701 #endif
1702
1703 #if FFETARGET_okREAL2
1704 case FFEINFO_kindtypeREAL2:
1705 u.real2 = *(array.real2 + offset);
1706 break;
1707 #endif
1708
1709 #if FFETARGET_okREAL3
1710 case FFEINFO_kindtypeREAL3:
1711 u.real3 = *(array.real3 + offset);
1712 break;
1713 #endif
1714
1715 #if FFETARGET_okREAL4
1716 case FFEINFO_kindtypeREAL4:
1717 u.real4 = *(array.real4 + offset);
1718 break;
1719 #endif
1720
1721 #if FFETARGET_okREAL5
1722 case FFEINFO_kindtypeREAL5:
1723 u.real5 = *(array.real5 + offset);
1724 break;
1725 #endif
1726
1727 #if FFETARGET_okREAL6
1728 case FFEINFO_kindtypeREAL6:
1729 u.real6 = *(array.real6 + offset);
1730 break;
1731 #endif
1732
1733 #if FFETARGET_okREAL7
1734 case FFEINFO_kindtypeREAL7:
1735 u.real7 = *(array.real7 + offset);
1736 break;
1737 #endif
1738
1739 #if FFETARGET_okREAL8
1740 case FFEINFO_kindtypeREAL8:
1741 u.real8 = *(array.real8 + offset);
1742 break;
1743 #endif
1744
1745 default:
1746 assert ("bad REAL kindtype" == NULL);
1747 break;
1748 }
1749 break;
1750
1751 case FFEINFO_basictypeCOMPLEX:
1752 switch (kt)
1753 {
1754 #if FFETARGET_okCOMPLEX1
1755 case FFEINFO_kindtypeREAL1:
1756 u.complex1 = *(array.complex1 + offset);
1757 break;
1758 #endif
1759
1760 #if FFETARGET_okCOMPLEX2
1761 case FFEINFO_kindtypeREAL2:
1762 u.complex2 = *(array.complex2 + offset);
1763 break;
1764 #endif
1765
1766 #if FFETARGET_okCOMPLEX3
1767 case FFEINFO_kindtypeREAL3:
1768 u.complex3 = *(array.complex3 + offset);
1769 break;
1770 #endif
1771
1772 #if FFETARGET_okCOMPLEX4
1773 case FFEINFO_kindtypeREAL4:
1774 u.complex4 = *(array.complex4 + offset);
1775 break;
1776 #endif
1777
1778 #if FFETARGET_okCOMPLEX5
1779 case FFEINFO_kindtypeREAL5:
1780 u.complex5 = *(array.complex5 + offset);
1781 break;
1782 #endif
1783
1784 #if FFETARGET_okCOMPLEX6
1785 case FFEINFO_kindtypeREAL6:
1786 u.complex6 = *(array.complex6 + offset);
1787 break;
1788 #endif
1789
1790 #if FFETARGET_okCOMPLEX7
1791 case FFEINFO_kindtypeREAL7:
1792 u.complex7 = *(array.complex7 + offset);
1793 break;
1794 #endif
1795
1796 #if FFETARGET_okCOMPLEX8
1797 case FFEINFO_kindtypeREAL8:
1798 u.complex8 = *(array.complex8 + offset);
1799 break;
1800 #endif
1801
1802 default:
1803 assert ("bad COMPLEX kindtype" == NULL);
1804 break;
1805 }
1806 break;
1807
1808 case FFEINFO_basictypeCHARACTER:
1809 switch (kt)
1810 {
1811 #if FFETARGET_okCHARACTER1
1812 case FFEINFO_kindtypeCHARACTER1:
1813 u.character1.length = 1;
1814 u.character1.text = array.character1 + offset;
1815 break;
1816 #endif
1817
1818 #if FFETARGET_okCHARACTER2
1819 case FFEINFO_kindtypeCHARACTER2:
1820 u.character2.length = 1;
1821 u.character2.text = array.character2 + offset;
1822 break;
1823 #endif
1824
1825 #if FFETARGET_okCHARACTER3
1826 case FFEINFO_kindtypeCHARACTER3:
1827 u.character3.length = 1;
1828 u.character3.text = array.character3 + offset;
1829 break;
1830 #endif
1831
1832 #if FFETARGET_okCHARACTER4
1833 case FFEINFO_kindtypeCHARACTER4:
1834 u.character4.length = 1;
1835 u.character4.text = array.character4 + offset;
1836 break;
1837 #endif
1838
1839 #if FFETARGET_okCHARACTER5
1840 case FFEINFO_kindtypeCHARACTER5:
1841 u.character5.length = 1;
1842 u.character5.text = array.character5 + offset;
1843 break;
1844 #endif
1845
1846 #if FFETARGET_okCHARACTER6
1847 case FFEINFO_kindtypeCHARACTER6:
1848 u.character6.length = 1;
1849 u.character6.text = array.character6 + offset;
1850 break;
1851 #endif
1852
1853 #if FFETARGET_okCHARACTER7
1854 case FFEINFO_kindtypeCHARACTER7:
1855 u.character7.length = 1;
1856 u.character7.text = array.character7 + offset;
1857 break;
1858 #endif
1859
1860 #if FFETARGET_okCHARACTER8
1861 case FFEINFO_kindtypeCHARACTER8:
1862 u.character8.length = 1;
1863 u.character8.text = array.character8 + offset;
1864 break;
1865 #endif
1866
1867 default:
1868 assert ("bad CHARACTER kindtype" == NULL);
1869 break;
1870 }
1871 break;
1872
1873 default:
1874 assert ("bad basictype" == NULL);
1875 break;
1876 }
1877
1878 return u;
1879 }
1880
1881 /* ffebld_constantarray_new -- Make an array of constants
1882
1883 See prototype. */
1884
1885 ffebldConstantArray
ffebld_constantarray_new(ffeinfoBasictype bt,ffeinfoKindtype kt,ffetargetOffset size)1886 ffebld_constantarray_new (ffeinfoBasictype bt,
1887 ffeinfoKindtype kt, ffetargetOffset size)
1888 {
1889 ffebldConstantArray ptr;
1890
1891 switch (bt)
1892 {
1893 case FFEINFO_basictypeINTEGER:
1894 switch (kt)
1895 {
1896 #if FFETARGET_okINTEGER1
1897 case FFEINFO_kindtypeINTEGER1:
1898 ptr.integer1 = malloc_new_zkp (ffebld_constant_pool(),
1899 "ffebldConstantArray",
1900 size *= sizeof (ffetargetInteger1),
1901 0);
1902 break;
1903 #endif
1904
1905 #if FFETARGET_okINTEGER2
1906 case FFEINFO_kindtypeINTEGER2:
1907 ptr.integer2 = malloc_new_zkp (ffebld_constant_pool(),
1908 "ffebldConstantArray",
1909 size *= sizeof (ffetargetInteger2),
1910 0);
1911 break;
1912 #endif
1913
1914 #if FFETARGET_okINTEGER3
1915 case FFEINFO_kindtypeINTEGER3:
1916 ptr.integer3 = malloc_new_zkp (ffebld_constant_pool(),
1917 "ffebldConstantArray",
1918 size *= sizeof (ffetargetInteger3),
1919 0);
1920 break;
1921 #endif
1922
1923 #if FFETARGET_okINTEGER4
1924 case FFEINFO_kindtypeINTEGER4:
1925 ptr.integer4 = malloc_new_zkp (ffebld_constant_pool(),
1926 "ffebldConstantArray",
1927 size *= sizeof (ffetargetInteger4),
1928 0);
1929 break;
1930 #endif
1931
1932 #if FFETARGET_okINTEGER5
1933 case FFEINFO_kindtypeINTEGER5:
1934 ptr.integer5 = malloc_new_zkp (ffebld_constant_pool(),
1935 "ffebldConstantArray",
1936 size *= sizeof (ffetargetInteger5),
1937 0);
1938 break;
1939 #endif
1940
1941 #if FFETARGET_okINTEGER6
1942 case FFEINFO_kindtypeINTEGER6:
1943 ptr.integer6 = malloc_new_zkp (ffebld_constant_pool(),
1944 "ffebldConstantArray",
1945 size *= sizeof (ffetargetInteger6),
1946 0);
1947 break;
1948 #endif
1949
1950 #if FFETARGET_okINTEGER7
1951 case FFEINFO_kindtypeINTEGER7:
1952 ptr.integer7 = malloc_new_zkp (ffebld_constant_pool(),
1953 "ffebldConstantArray",
1954 size *= sizeof (ffetargetInteger7),
1955 0);
1956 break;
1957 #endif
1958
1959 #if FFETARGET_okINTEGER8
1960 case FFEINFO_kindtypeINTEGER8:
1961 ptr.integer8 = malloc_new_zkp (ffebld_constant_pool(),
1962 "ffebldConstantArray",
1963 size *= sizeof (ffetargetInteger8),
1964 0);
1965 break;
1966 #endif
1967
1968 default:
1969 assert ("bad INTEGER kindtype" == NULL);
1970 break;
1971 }
1972 break;
1973
1974 case FFEINFO_basictypeLOGICAL:
1975 switch (kt)
1976 {
1977 #if FFETARGET_okLOGICAL1
1978 case FFEINFO_kindtypeLOGICAL1:
1979 ptr.logical1 = malloc_new_zkp (ffebld_constant_pool(),
1980 "ffebldConstantArray",
1981 size *= sizeof (ffetargetLogical1),
1982 0);
1983 break;
1984 #endif
1985
1986 #if FFETARGET_okLOGICAL2
1987 case FFEINFO_kindtypeLOGICAL2:
1988 ptr.logical2 = malloc_new_zkp (ffebld_constant_pool(),
1989 "ffebldConstantArray",
1990 size *= sizeof (ffetargetLogical2),
1991 0);
1992 break;
1993 #endif
1994
1995 #if FFETARGET_okLOGICAL3
1996 case FFEINFO_kindtypeLOGICAL3:
1997 ptr.logical3 = malloc_new_zkp (ffebld_constant_pool(),
1998 "ffebldConstantArray",
1999 size *= sizeof (ffetargetLogical3),
2000 0);
2001 break;
2002 #endif
2003
2004 #if FFETARGET_okLOGICAL4
2005 case FFEINFO_kindtypeLOGICAL4:
2006 ptr.logical4 = malloc_new_zkp (ffebld_constant_pool(),
2007 "ffebldConstantArray",
2008 size *= sizeof (ffetargetLogical4),
2009 0);
2010 break;
2011 #endif
2012
2013 #if FFETARGET_okLOGICAL5
2014 case FFEINFO_kindtypeLOGICAL5:
2015 ptr.logical5 = malloc_new_zkp (ffebld_constant_pool(),
2016 "ffebldConstantArray",
2017 size *= sizeof (ffetargetLogical5),
2018 0);
2019 break;
2020 #endif
2021
2022 #if FFETARGET_okLOGICAL6
2023 case FFEINFO_kindtypeLOGICAL6:
2024 ptr.logical6 = malloc_new_zkp (ffebld_constant_pool(),
2025 "ffebldConstantArray",
2026 size *= sizeof (ffetargetLogical6),
2027 0);
2028 break;
2029 #endif
2030
2031 #if FFETARGET_okLOGICAL7
2032 case FFEINFO_kindtypeLOGICAL7:
2033 ptr.logical7 = malloc_new_zkp (ffebld_constant_pool(),
2034 "ffebldConstantArray",
2035 size *= sizeof (ffetargetLogical7),
2036 0);
2037 break;
2038 #endif
2039
2040 #if FFETARGET_okLOGICAL8
2041 case FFEINFO_kindtypeLOGICAL8:
2042 ptr.logical8 = malloc_new_zkp (ffebld_constant_pool(),
2043 "ffebldConstantArray",
2044 size *= sizeof (ffetargetLogical8),
2045 0);
2046 break;
2047 #endif
2048
2049 default:
2050 assert ("bad LOGICAL kindtype" == NULL);
2051 break;
2052 }
2053 break;
2054
2055 case FFEINFO_basictypeREAL:
2056 switch (kt)
2057 {
2058 #if FFETARGET_okREAL1
2059 case FFEINFO_kindtypeREAL1:
2060 ptr.real1 = malloc_new_zkp (ffebld_constant_pool(),
2061 "ffebldConstantArray",
2062 size *= sizeof (ffetargetReal1),
2063 0);
2064 break;
2065 #endif
2066
2067 #if FFETARGET_okREAL2
2068 case FFEINFO_kindtypeREAL2:
2069 ptr.real2 = malloc_new_zkp (ffebld_constant_pool(),
2070 "ffebldConstantArray",
2071 size *= sizeof (ffetargetReal2),
2072 0);
2073 break;
2074 #endif
2075
2076 #if FFETARGET_okREAL3
2077 case FFEINFO_kindtypeREAL3:
2078 ptr.real3 = malloc_new_zkp (ffebld_constant_pool(),
2079 "ffebldConstantArray",
2080 size *= sizeof (ffetargetReal3),
2081 0);
2082 break;
2083 #endif
2084
2085 #if FFETARGET_okREAL4
2086 case FFEINFO_kindtypeREAL4:
2087 ptr.real4 = malloc_new_zkp (ffebld_constant_pool(),
2088 "ffebldConstantArray",
2089 size *= sizeof (ffetargetReal4),
2090 0);
2091 break;
2092 #endif
2093
2094 #if FFETARGET_okREAL5
2095 case FFEINFO_kindtypeREAL5:
2096 ptr.real5 = malloc_new_zkp (ffebld_constant_pool(),
2097 "ffebldConstantArray",
2098 size *= sizeof (ffetargetReal5),
2099 0);
2100 break;
2101 #endif
2102
2103 #if FFETARGET_okREAL6
2104 case FFEINFO_kindtypeREAL6:
2105 ptr.real6 = malloc_new_zkp (ffebld_constant_pool(),
2106 "ffebldConstantArray",
2107 size *= sizeof (ffetargetReal6),
2108 0);
2109 break;
2110 #endif
2111
2112 #if FFETARGET_okREAL7
2113 case FFEINFO_kindtypeREAL7:
2114 ptr.real7 = malloc_new_zkp (ffebld_constant_pool(),
2115 "ffebldConstantArray",
2116 size *= sizeof (ffetargetReal7),
2117 0);
2118 break;
2119 #endif
2120
2121 #if FFETARGET_okREAL8
2122 case FFEINFO_kindtypeREAL8:
2123 ptr.real8 = malloc_new_zkp (ffebld_constant_pool(),
2124 "ffebldConstantArray",
2125 size *= sizeof (ffetargetReal8),
2126 0);
2127 break;
2128 #endif
2129
2130 default:
2131 assert ("bad REAL kindtype" == NULL);
2132 break;
2133 }
2134 break;
2135
2136 case FFEINFO_basictypeCOMPLEX:
2137 switch (kt)
2138 {
2139 #if FFETARGET_okCOMPLEX1
2140 case FFEINFO_kindtypeREAL1:
2141 ptr.complex1 = malloc_new_zkp (ffebld_constant_pool(),
2142 "ffebldConstantArray",
2143 size *= sizeof (ffetargetComplex1),
2144 0);
2145 break;
2146 #endif
2147
2148 #if FFETARGET_okCOMPLEX2
2149 case FFEINFO_kindtypeREAL2:
2150 ptr.complex2 = malloc_new_zkp (ffebld_constant_pool(),
2151 "ffebldConstantArray",
2152 size *= sizeof (ffetargetComplex2),
2153 0);
2154 break;
2155 #endif
2156
2157 #if FFETARGET_okCOMPLEX3
2158 case FFEINFO_kindtypeREAL3:
2159 ptr.complex3 = malloc_new_zkp (ffebld_constant_pool(),
2160 "ffebldConstantArray",
2161 size *= sizeof (ffetargetComplex3),
2162 0);
2163 break;
2164 #endif
2165
2166 #if FFETARGET_okCOMPLEX4
2167 case FFEINFO_kindtypeREAL4:
2168 ptr.complex4 = malloc_new_zkp (ffebld_constant_pool(),
2169 "ffebldConstantArray",
2170 size *= sizeof (ffetargetComplex4),
2171 0);
2172 break;
2173 #endif
2174
2175 #if FFETARGET_okCOMPLEX5
2176 case FFEINFO_kindtypeREAL5:
2177 ptr.complex5 = malloc_new_zkp (ffebld_constant_pool(),
2178 "ffebldConstantArray",
2179 size *= sizeof (ffetargetComplex5),
2180 0);
2181 break;
2182 #endif
2183
2184 #if FFETARGET_okCOMPLEX6
2185 case FFEINFO_kindtypeREAL6:
2186 ptr.complex6 = malloc_new_zkp (ffebld_constant_pool(),
2187 "ffebldConstantArray",
2188 size *= sizeof (ffetargetComplex6),
2189 0);
2190 break;
2191 #endif
2192
2193 #if FFETARGET_okCOMPLEX7
2194 case FFEINFO_kindtypeREAL7:
2195 ptr.complex7 = malloc_new_zkp (ffebld_constant_pool(),
2196 "ffebldConstantArray",
2197 size *= sizeof (ffetargetComplex7),
2198 0);
2199 break;
2200 #endif
2201
2202 #if FFETARGET_okCOMPLEX8
2203 case FFEINFO_kindtypeREAL8:
2204 ptr.complex8 = malloc_new_zkp (ffebld_constant_pool(),
2205 "ffebldConstantArray",
2206 size *= sizeof (ffetargetComplex8),
2207 0);
2208 break;
2209 #endif
2210
2211 default:
2212 assert ("bad COMPLEX kindtype" == NULL);
2213 break;
2214 }
2215 break;
2216
2217 case FFEINFO_basictypeCHARACTER:
2218 switch (kt)
2219 {
2220 #if FFETARGET_okCHARACTER1
2221 case FFEINFO_kindtypeCHARACTER1:
2222 ptr.character1 = malloc_new_zkp (ffebld_constant_pool(),
2223 "ffebldConstantArray",
2224 size
2225 *= sizeof (ffetargetCharacterUnit1),
2226 0);
2227 break;
2228 #endif
2229
2230 #if FFETARGET_okCHARACTER2
2231 case FFEINFO_kindtypeCHARACTER2:
2232 ptr.character2 = malloc_new_zkp (ffebld_constant_pool(),
2233 "ffebldConstantArray",
2234 size
2235 *= sizeof (ffetargetCharacterUnit2),
2236 0);
2237 break;
2238 #endif
2239
2240 #if FFETARGET_okCHARACTER3
2241 case FFEINFO_kindtypeCHARACTER3:
2242 ptr.character3 = malloc_new_zkp (ffebld_constant_pool(),
2243 "ffebldConstantArray",
2244 size
2245 *= sizeof (ffetargetCharacterUnit3),
2246 0);
2247 break;
2248 #endif
2249
2250 #if FFETARGET_okCHARACTER4
2251 case FFEINFO_kindtypeCHARACTER4:
2252 ptr.character4 = malloc_new_zkp (ffebld_constant_pool(),
2253 "ffebldConstantArray",
2254 size
2255 *= sizeof (ffetargetCharacterUnit4),
2256 0);
2257 break;
2258 #endif
2259
2260 #if FFETARGET_okCHARACTER5
2261 case FFEINFO_kindtypeCHARACTER5:
2262 ptr.character5 = malloc_new_zkp (ffebld_constant_pool(),
2263 "ffebldConstantArray",
2264 size
2265 *= sizeof (ffetargetCharacterUnit5),
2266 0);
2267 break;
2268 #endif
2269
2270 #if FFETARGET_okCHARACTER6
2271 case FFEINFO_kindtypeCHARACTER6:
2272 ptr.character6 = malloc_new_zkp (ffebld_constant_pool(),
2273 "ffebldConstantArray",
2274 size
2275 *= sizeof (ffetargetCharacterUnit6),
2276 0);
2277 break;
2278 #endif
2279
2280 #if FFETARGET_okCHARACTER7
2281 case FFEINFO_kindtypeCHARACTER7:
2282 ptr.character7 = malloc_new_zkp (ffebld_constant_pool(),
2283 "ffebldConstantArray",
2284 size
2285 *= sizeof (ffetargetCharacterUnit7),
2286 0);
2287 break;
2288 #endif
2289
2290 #if FFETARGET_okCHARACTER8
2291 case FFEINFO_kindtypeCHARACTER8:
2292 ptr.character8 = malloc_new_zkp (ffebld_constant_pool(),
2293 "ffebldConstantArray",
2294 size
2295 *= sizeof (ffetargetCharacterUnit8),
2296 0);
2297 break;
2298 #endif
2299
2300 default:
2301 assert ("bad CHARACTER kindtype" == NULL);
2302 break;
2303 }
2304 break;
2305
2306 default:
2307 assert ("bad basictype" == NULL);
2308 break;
2309 }
2310
2311 return ptr;
2312 }
2313
2314 /* ffebld_constantarray_preparray -- Prepare for copy between arrays
2315
2316 See prototype.
2317
2318 Like _prepare, but the source is an array instead of a single-value
2319 constant. */
2320
2321 void
ffebld_constantarray_preparray(void ** aptr,void ** cptr,size_t * size,ffebldConstantArray array,ffeinfoBasictype abt,ffeinfoKindtype akt,ffetargetOffset offset,ffebldConstantArray source_array,ffeinfoBasictype cbt,ffeinfoKindtype ckt)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)
2326 {
2327 switch (abt)
2328 {
2329 case FFEINFO_basictypeINTEGER:
2330 switch (akt)
2331 {
2332 #if FFETARGET_okINTEGER1
2333 case FFEINFO_kindtypeINTEGER1:
2334 *aptr = array.integer1 + offset;
2335 break;
2336 #endif
2337
2338 #if FFETARGET_okINTEGER2
2339 case FFEINFO_kindtypeINTEGER2:
2340 *aptr = array.integer2 + offset;
2341 break;
2342 #endif
2343
2344 #if FFETARGET_okINTEGER3
2345 case FFEINFO_kindtypeINTEGER3:
2346 *aptr = array.integer3 + offset;
2347 break;
2348 #endif
2349
2350 #if FFETARGET_okINTEGER4
2351 case FFEINFO_kindtypeINTEGER4:
2352 *aptr = array.integer4 + offset;
2353 break;
2354 #endif
2355
2356 #if FFETARGET_okINTEGER5
2357 case FFEINFO_kindtypeINTEGER5:
2358 *aptr = array.integer5 + offset;
2359 break;
2360 #endif
2361
2362 #if FFETARGET_okINTEGER6
2363 case FFEINFO_kindtypeINTEGER6:
2364 *aptr = array.integer6 + offset;
2365 break;
2366 #endif
2367
2368 #if FFETARGET_okINTEGER7
2369 case FFEINFO_kindtypeINTEGER7:
2370 *aptr = array.integer7 + offset;
2371 break;
2372 #endif
2373
2374 #if FFETARGET_okINTEGER8
2375 case FFEINFO_kindtypeINTEGER8:
2376 *aptr = array.integer8 + offset;
2377 break;
2378 #endif
2379
2380 default:
2381 assert ("bad INTEGER akindtype" == NULL);
2382 break;
2383 }
2384 break;
2385
2386 case FFEINFO_basictypeLOGICAL:
2387 switch (akt)
2388 {
2389 #if FFETARGET_okLOGICAL1
2390 case FFEINFO_kindtypeLOGICAL1:
2391 *aptr = array.logical1 + offset;
2392 break;
2393 #endif
2394
2395 #if FFETARGET_okLOGICAL2
2396 case FFEINFO_kindtypeLOGICAL2:
2397 *aptr = array.logical2 + offset;
2398 break;
2399 #endif
2400
2401 #if FFETARGET_okLOGICAL3
2402 case FFEINFO_kindtypeLOGICAL3:
2403 *aptr = array.logical3 + offset;
2404 break;
2405 #endif
2406
2407 #if FFETARGET_okLOGICAL4
2408 case FFEINFO_kindtypeLOGICAL4:
2409 *aptr = array.logical4 + offset;
2410 break;
2411 #endif
2412
2413 #if FFETARGET_okLOGICAL5
2414 case FFEINFO_kindtypeLOGICAL5:
2415 *aptr = array.logical5 + offset;
2416 break;
2417 #endif
2418
2419 #if FFETARGET_okLOGICAL6
2420 case FFEINFO_kindtypeLOGICAL6:
2421 *aptr = array.logical6 + offset;
2422 break;
2423 #endif
2424
2425 #if FFETARGET_okLOGICAL7
2426 case FFEINFO_kindtypeLOGICAL7:
2427 *aptr = array.logical7 + offset;
2428 break;
2429 #endif
2430
2431 #if FFETARGET_okLOGICAL8
2432 case FFEINFO_kindtypeLOGICAL8:
2433 *aptr = array.logical8 + offset;
2434 break;
2435 #endif
2436
2437 default:
2438 assert ("bad LOGICAL akindtype" == NULL);
2439 break;
2440 }
2441 break;
2442
2443 case FFEINFO_basictypeREAL:
2444 switch (akt)
2445 {
2446 #if FFETARGET_okREAL1
2447 case FFEINFO_kindtypeREAL1:
2448 *aptr = array.real1 + offset;
2449 break;
2450 #endif
2451
2452 #if FFETARGET_okREAL2
2453 case FFEINFO_kindtypeREAL2:
2454 *aptr = array.real2 + offset;
2455 break;
2456 #endif
2457
2458 #if FFETARGET_okREAL3
2459 case FFEINFO_kindtypeREAL3:
2460 *aptr = array.real3 + offset;
2461 break;
2462 #endif
2463
2464 #if FFETARGET_okREAL4
2465 case FFEINFO_kindtypeREAL4:
2466 *aptr = array.real4 + offset;
2467 break;
2468 #endif
2469
2470 #if FFETARGET_okREAL5
2471 case FFEINFO_kindtypeREAL5:
2472 *aptr = array.real5 + offset;
2473 break;
2474 #endif
2475
2476 #if FFETARGET_okREAL6
2477 case FFEINFO_kindtypeREAL6:
2478 *aptr = array.real6 + offset;
2479 break;
2480 #endif
2481
2482 #if FFETARGET_okREAL7
2483 case FFEINFO_kindtypeREAL7:
2484 *aptr = array.real7 + offset;
2485 break;
2486 #endif
2487
2488 #if FFETARGET_okREAL8
2489 case FFEINFO_kindtypeREAL8:
2490 *aptr = array.real8 + offset;
2491 break;
2492 #endif
2493
2494 default:
2495 assert ("bad REAL akindtype" == NULL);
2496 break;
2497 }
2498 break;
2499
2500 case FFEINFO_basictypeCOMPLEX:
2501 switch (akt)
2502 {
2503 #if FFETARGET_okCOMPLEX1
2504 case FFEINFO_kindtypeREAL1:
2505 *aptr = array.complex1 + offset;
2506 break;
2507 #endif
2508
2509 #if FFETARGET_okCOMPLEX2
2510 case FFEINFO_kindtypeREAL2:
2511 *aptr = array.complex2 + offset;
2512 break;
2513 #endif
2514
2515 #if FFETARGET_okCOMPLEX3
2516 case FFEINFO_kindtypeREAL3:
2517 *aptr = array.complex3 + offset;
2518 break;
2519 #endif
2520
2521 #if FFETARGET_okCOMPLEX4
2522 case FFEINFO_kindtypeREAL4:
2523 *aptr = array.complex4 + offset;
2524 break;
2525 #endif
2526
2527 #if FFETARGET_okCOMPLEX5
2528 case FFEINFO_kindtypeREAL5:
2529 *aptr = array.complex5 + offset;
2530 break;
2531 #endif
2532
2533 #if FFETARGET_okCOMPLEX6
2534 case FFEINFO_kindtypeREAL6:
2535 *aptr = array.complex6 + offset;
2536 break;
2537 #endif
2538
2539 #if FFETARGET_okCOMPLEX7
2540 case FFEINFO_kindtypeREAL7:
2541 *aptr = array.complex7 + offset;
2542 break;
2543 #endif
2544
2545 #if FFETARGET_okCOMPLEX8
2546 case FFEINFO_kindtypeREAL8:
2547 *aptr = array.complex8 + offset;
2548 break;
2549 #endif
2550
2551 default:
2552 assert ("bad COMPLEX akindtype" == NULL);
2553 break;
2554 }
2555 break;
2556
2557 case FFEINFO_basictypeCHARACTER:
2558 switch (akt)
2559 {
2560 #if FFETARGET_okCHARACTER1
2561 case FFEINFO_kindtypeCHARACTER1:
2562 *aptr = array.character1 + offset;
2563 break;
2564 #endif
2565
2566 #if FFETARGET_okCHARACTER2
2567 case FFEINFO_kindtypeCHARACTER2:
2568 *aptr = array.character2 + offset;
2569 break;
2570 #endif
2571
2572 #if FFETARGET_okCHARACTER3
2573 case FFEINFO_kindtypeCHARACTER3:
2574 *aptr = array.character3 + offset;
2575 break;
2576 #endif
2577
2578 #if FFETARGET_okCHARACTER4
2579 case FFEINFO_kindtypeCHARACTER4:
2580 *aptr = array.character4 + offset;
2581 break;
2582 #endif
2583
2584 #if FFETARGET_okCHARACTER5
2585 case FFEINFO_kindtypeCHARACTER5:
2586 *aptr = array.character5 + offset;
2587 break;
2588 #endif
2589
2590 #if FFETARGET_okCHARACTER6
2591 case FFEINFO_kindtypeCHARACTER6:
2592 *aptr = array.character6 + offset;
2593 break;
2594 #endif
2595
2596 #if FFETARGET_okCHARACTER7
2597 case FFEINFO_kindtypeCHARACTER7:
2598 *aptr = array.character7 + offset;
2599 break;
2600 #endif
2601
2602 #if FFETARGET_okCHARACTER8
2603 case FFEINFO_kindtypeCHARACTER8:
2604 *aptr = array.character8 + offset;
2605 break;
2606 #endif
2607
2608 default:
2609 assert ("bad CHARACTER akindtype" == NULL);
2610 break;
2611 }
2612 break;
2613
2614 default:
2615 assert ("bad abasictype" == NULL);
2616 break;
2617 }
2618
2619 switch (cbt)
2620 {
2621 case FFEINFO_basictypeINTEGER:
2622 switch (ckt)
2623 {
2624 #if FFETARGET_okINTEGER1
2625 case FFEINFO_kindtypeINTEGER1:
2626 *cptr = source_array.integer1;
2627 *size = sizeof (*source_array.integer1);
2628 break;
2629 #endif
2630
2631 #if FFETARGET_okINTEGER2
2632 case FFEINFO_kindtypeINTEGER2:
2633 *cptr = source_array.integer2;
2634 *size = sizeof (*source_array.integer2);
2635 break;
2636 #endif
2637
2638 #if FFETARGET_okINTEGER3
2639 case FFEINFO_kindtypeINTEGER3:
2640 *cptr = source_array.integer3;
2641 *size = sizeof (*source_array.integer3);
2642 break;
2643 #endif
2644
2645 #if FFETARGET_okINTEGER4
2646 case FFEINFO_kindtypeINTEGER4:
2647 *cptr = source_array.integer4;
2648 *size = sizeof (*source_array.integer4);
2649 break;
2650 #endif
2651
2652 #if FFETARGET_okINTEGER5
2653 case FFEINFO_kindtypeINTEGER5:
2654 *cptr = source_array.integer5;
2655 *size = sizeof (*source_array.integer5);
2656 break;
2657 #endif
2658
2659 #if FFETARGET_okINTEGER6
2660 case FFEINFO_kindtypeINTEGER6:
2661 *cptr = source_array.integer6;
2662 *size = sizeof (*source_array.integer6);
2663 break;
2664 #endif
2665
2666 #if FFETARGET_okINTEGER7
2667 case FFEINFO_kindtypeINTEGER7:
2668 *cptr = source_array.integer7;
2669 *size = sizeof (*source_array.integer7);
2670 break;
2671 #endif
2672
2673 #if FFETARGET_okINTEGER8
2674 case FFEINFO_kindtypeINTEGER8:
2675 *cptr = source_array.integer8;
2676 *size = sizeof (*source_array.integer8);
2677 break;
2678 #endif
2679
2680 default:
2681 assert ("bad INTEGER ckindtype" == NULL);
2682 break;
2683 }
2684 break;
2685
2686 case FFEINFO_basictypeLOGICAL:
2687 switch (ckt)
2688 {
2689 #if FFETARGET_okLOGICAL1
2690 case FFEINFO_kindtypeLOGICAL1:
2691 *cptr = source_array.logical1;
2692 *size = sizeof (*source_array.logical1);
2693 break;
2694 #endif
2695
2696 #if FFETARGET_okLOGICAL2
2697 case FFEINFO_kindtypeLOGICAL2:
2698 *cptr = source_array.logical2;
2699 *size = sizeof (*source_array.logical2);
2700 break;
2701 #endif
2702
2703 #if FFETARGET_okLOGICAL3
2704 case FFEINFO_kindtypeLOGICAL3:
2705 *cptr = source_array.logical3;
2706 *size = sizeof (*source_array.logical3);
2707 break;
2708 #endif
2709
2710 #if FFETARGET_okLOGICAL4
2711 case FFEINFO_kindtypeLOGICAL4:
2712 *cptr = source_array.logical4;
2713 *size = sizeof (*source_array.logical4);
2714 break;
2715 #endif
2716
2717 #if FFETARGET_okLOGICAL5
2718 case FFEINFO_kindtypeLOGICAL5:
2719 *cptr = source_array.logical5;
2720 *size = sizeof (*source_array.logical5);
2721 break;
2722 #endif
2723
2724 #if FFETARGET_okLOGICAL6
2725 case FFEINFO_kindtypeLOGICAL6:
2726 *cptr = source_array.logical6;
2727 *size = sizeof (*source_array.logical6);
2728 break;
2729 #endif
2730
2731 #if FFETARGET_okLOGICAL7
2732 case FFEINFO_kindtypeLOGICAL7:
2733 *cptr = source_array.logical7;
2734 *size = sizeof (*source_array.logical7);
2735 break;
2736 #endif
2737
2738 #if FFETARGET_okLOGICAL8
2739 case FFEINFO_kindtypeLOGICAL8:
2740 *cptr = source_array.logical8;
2741 *size = sizeof (*source_array.logical8);
2742 break;
2743 #endif
2744
2745 default:
2746 assert ("bad LOGICAL ckindtype" == NULL);
2747 break;
2748 }
2749 break;
2750
2751 case FFEINFO_basictypeREAL:
2752 switch (ckt)
2753 {
2754 #if FFETARGET_okREAL1
2755 case FFEINFO_kindtypeREAL1:
2756 *cptr = source_array.real1;
2757 *size = sizeof (*source_array.real1);
2758 break;
2759 #endif
2760
2761 #if FFETARGET_okREAL2
2762 case FFEINFO_kindtypeREAL2:
2763 *cptr = source_array.real2;
2764 *size = sizeof (*source_array.real2);
2765 break;
2766 #endif
2767
2768 #if FFETARGET_okREAL3
2769 case FFEINFO_kindtypeREAL3:
2770 *cptr = source_array.real3;
2771 *size = sizeof (*source_array.real3);
2772 break;
2773 #endif
2774
2775 #if FFETARGET_okREAL4
2776 case FFEINFO_kindtypeREAL4:
2777 *cptr = source_array.real4;
2778 *size = sizeof (*source_array.real4);
2779 break;
2780 #endif
2781
2782 #if FFETARGET_okREAL5
2783 case FFEINFO_kindtypeREAL5:
2784 *cptr = source_array.real5;
2785 *size = sizeof (*source_array.real5);
2786 break;
2787 #endif
2788
2789 #if FFETARGET_okREAL6
2790 case FFEINFO_kindtypeREAL6:
2791 *cptr = source_array.real6;
2792 *size = sizeof (*source_array.real6);
2793 break;
2794 #endif
2795
2796 #if FFETARGET_okREAL7
2797 case FFEINFO_kindtypeREAL7:
2798 *cptr = source_array.real7;
2799 *size = sizeof (*source_array.real7);
2800 break;
2801 #endif
2802
2803 #if FFETARGET_okREAL8
2804 case FFEINFO_kindtypeREAL8:
2805 *cptr = source_array.real8;
2806 *size = sizeof (*source_array.real8);
2807 break;
2808 #endif
2809
2810 default:
2811 assert ("bad REAL ckindtype" == NULL);
2812 break;
2813 }
2814 break;
2815
2816 case FFEINFO_basictypeCOMPLEX:
2817 switch (ckt)
2818 {
2819 #if FFETARGET_okCOMPLEX1
2820 case FFEINFO_kindtypeREAL1:
2821 *cptr = source_array.complex1;
2822 *size = sizeof (*source_array.complex1);
2823 break;
2824 #endif
2825
2826 #if FFETARGET_okCOMPLEX2
2827 case FFEINFO_kindtypeREAL2:
2828 *cptr = source_array.complex2;
2829 *size = sizeof (*source_array.complex2);
2830 break;
2831 #endif
2832
2833 #if FFETARGET_okCOMPLEX3
2834 case FFEINFO_kindtypeREAL3:
2835 *cptr = source_array.complex3;
2836 *size = sizeof (*source_array.complex3);
2837 break;
2838 #endif
2839
2840 #if FFETARGET_okCOMPLEX4
2841 case FFEINFO_kindtypeREAL4:
2842 *cptr = source_array.complex4;
2843 *size = sizeof (*source_array.complex4);
2844 break;
2845 #endif
2846
2847 #if FFETARGET_okCOMPLEX5
2848 case FFEINFO_kindtypeREAL5:
2849 *cptr = source_array.complex5;
2850 *size = sizeof (*source_array.complex5);
2851 break;
2852 #endif
2853
2854 #if FFETARGET_okCOMPLEX6
2855 case FFEINFO_kindtypeREAL6:
2856 *cptr = source_array.complex6;
2857 *size = sizeof (*source_array.complex6);
2858 break;
2859 #endif
2860
2861 #if FFETARGET_okCOMPLEX7
2862 case FFEINFO_kindtypeREAL7:
2863 *cptr = source_array.complex7;
2864 *size = sizeof (*source_array.complex7);
2865 break;
2866 #endif
2867
2868 #if FFETARGET_okCOMPLEX8
2869 case FFEINFO_kindtypeREAL8:
2870 *cptr = source_array.complex8;
2871 *size = sizeof (*source_array.complex8);
2872 break;
2873 #endif
2874
2875 default:
2876 assert ("bad COMPLEX ckindtype" == NULL);
2877 break;
2878 }
2879 break;
2880
2881 case FFEINFO_basictypeCHARACTER:
2882 switch (ckt)
2883 {
2884 #if FFETARGET_okCHARACTER1
2885 case FFEINFO_kindtypeCHARACTER1:
2886 *cptr = source_array.character1;
2887 *size = sizeof (*source_array.character1);
2888 break;
2889 #endif
2890
2891 #if FFETARGET_okCHARACTER2
2892 case FFEINFO_kindtypeCHARACTER2:
2893 *cptr = source_array.character2;
2894 *size = sizeof (*source_array.character2);
2895 break;
2896 #endif
2897
2898 #if FFETARGET_okCHARACTER3
2899 case FFEINFO_kindtypeCHARACTER3:
2900 *cptr = source_array.character3;
2901 *size = sizeof (*source_array.character3);
2902 break;
2903 #endif
2904
2905 #if FFETARGET_okCHARACTER4
2906 case FFEINFO_kindtypeCHARACTER4:
2907 *cptr = source_array.character4;
2908 *size = sizeof (*source_array.character4);
2909 break;
2910 #endif
2911
2912 #if FFETARGET_okCHARACTER5
2913 case FFEINFO_kindtypeCHARACTER5:
2914 *cptr = source_array.character5;
2915 *size = sizeof (*source_array.character5);
2916 break;
2917 #endif
2918
2919 #if FFETARGET_okCHARACTER6
2920 case FFEINFO_kindtypeCHARACTER6:
2921 *cptr = source_array.character6;
2922 *size = sizeof (*source_array.character6);
2923 break;
2924 #endif
2925
2926 #if FFETARGET_okCHARACTER7
2927 case FFEINFO_kindtypeCHARACTER7:
2928 *cptr = source_array.character7;
2929 *size = sizeof (*source_array.character7);
2930 break;
2931 #endif
2932
2933 #if FFETARGET_okCHARACTER8
2934 case FFEINFO_kindtypeCHARACTER8:
2935 *cptr = source_array.character8;
2936 *size = sizeof (*source_array.character8);
2937 break;
2938 #endif
2939
2940 default:
2941 assert ("bad CHARACTER ckindtype" == NULL);
2942 break;
2943 }
2944 break;
2945
2946 default:
2947 assert ("bad cbasictype" == NULL);
2948 break;
2949 }
2950 }
2951
2952 /* ffebld_constantarray_prepare -- Prepare for copy between value and array
2953
2954 See prototype.
2955
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). */
2966
2967 void
ffebld_constantarray_prepare(void ** aptr,void ** cptr,size_t * size,ffebldConstantArray array,ffeinfoBasictype abt,ffeinfoKindtype akt,ffetargetOffset offset,ffebldConstantUnion * constant,ffeinfoBasictype cbt,ffeinfoKindtype ckt)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)
2972 {
2973 switch (abt)
2974 {
2975 case FFEINFO_basictypeINTEGER:
2976 switch (akt)
2977 {
2978 #if FFETARGET_okINTEGER1
2979 case FFEINFO_kindtypeINTEGER1:
2980 *aptr = array.integer1 + offset;
2981 break;
2982 #endif
2983
2984 #if FFETARGET_okINTEGER2
2985 case FFEINFO_kindtypeINTEGER2:
2986 *aptr = array.integer2 + offset;
2987 break;
2988 #endif
2989
2990 #if FFETARGET_okINTEGER3
2991 case FFEINFO_kindtypeINTEGER3:
2992 *aptr = array.integer3 + offset;
2993 break;
2994 #endif
2995
2996 #if FFETARGET_okINTEGER4
2997 case FFEINFO_kindtypeINTEGER4:
2998 *aptr = array.integer4 + offset;
2999 break;
3000 #endif
3001
3002 #if FFETARGET_okINTEGER5
3003 case FFEINFO_kindtypeINTEGER5:
3004 *aptr = array.integer5 + offset;
3005 break;
3006 #endif
3007
3008 #if FFETARGET_okINTEGER6
3009 case FFEINFO_kindtypeINTEGER6:
3010 *aptr = array.integer6 + offset;
3011 break;
3012 #endif
3013
3014 #if FFETARGET_okINTEGER7
3015 case FFEINFO_kindtypeINTEGER7:
3016 *aptr = array.integer7 + offset;
3017 break;
3018 #endif
3019
3020 #if FFETARGET_okINTEGER8
3021 case FFEINFO_kindtypeINTEGER8:
3022 *aptr = array.integer8 + offset;
3023 break;
3024 #endif
3025
3026 default:
3027 assert ("bad INTEGER akindtype" == NULL);
3028 break;
3029 }
3030 break;
3031
3032 case FFEINFO_basictypeLOGICAL:
3033 switch (akt)
3034 {
3035 #if FFETARGET_okLOGICAL1
3036 case FFEINFO_kindtypeLOGICAL1:
3037 *aptr = array.logical1 + offset;
3038 break;
3039 #endif
3040
3041 #if FFETARGET_okLOGICAL2
3042 case FFEINFO_kindtypeLOGICAL2:
3043 *aptr = array.logical2 + offset;
3044 break;
3045 #endif
3046
3047 #if FFETARGET_okLOGICAL3
3048 case FFEINFO_kindtypeLOGICAL3:
3049 *aptr = array.logical3 + offset;
3050 break;
3051 #endif
3052
3053 #if FFETARGET_okLOGICAL4
3054 case FFEINFO_kindtypeLOGICAL4:
3055 *aptr = array.logical4 + offset;
3056 break;
3057 #endif
3058
3059 #if FFETARGET_okLOGICAL5
3060 case FFEINFO_kindtypeLOGICAL5:
3061 *aptr = array.logical5 + offset;
3062 break;
3063 #endif
3064
3065 #if FFETARGET_okLOGICAL6
3066 case FFEINFO_kindtypeLOGICAL6:
3067 *aptr = array.logical6 + offset;
3068 break;
3069 #endif
3070
3071 #if FFETARGET_okLOGICAL7
3072 case FFEINFO_kindtypeLOGICAL7:
3073 *aptr = array.logical7 + offset;
3074 break;
3075 #endif
3076
3077 #if FFETARGET_okLOGICAL8
3078 case FFEINFO_kindtypeLOGICAL8:
3079 *aptr = array.logical8 + offset;
3080 break;
3081 #endif
3082
3083 default:
3084 assert ("bad LOGICAL akindtype" == NULL);
3085 break;
3086 }
3087 break;
3088
3089 case FFEINFO_basictypeREAL:
3090 switch (akt)
3091 {
3092 #if FFETARGET_okREAL1
3093 case FFEINFO_kindtypeREAL1:
3094 *aptr = array.real1 + offset;
3095 break;
3096 #endif
3097
3098 #if FFETARGET_okREAL2
3099 case FFEINFO_kindtypeREAL2:
3100 *aptr = array.real2 + offset;
3101 break;
3102 #endif
3103
3104 #if FFETARGET_okREAL3
3105 case FFEINFO_kindtypeREAL3:
3106 *aptr = array.real3 + offset;
3107 break;
3108 #endif
3109
3110 #if FFETARGET_okREAL4
3111 case FFEINFO_kindtypeREAL4:
3112 *aptr = array.real4 + offset;
3113 break;
3114 #endif
3115
3116 #if FFETARGET_okREAL5
3117 case FFEINFO_kindtypeREAL5:
3118 *aptr = array.real5 + offset;
3119 break;
3120 #endif
3121
3122 #if FFETARGET_okREAL6
3123 case FFEINFO_kindtypeREAL6:
3124 *aptr = array.real6 + offset;
3125 break;
3126 #endif
3127
3128 #if FFETARGET_okREAL7
3129 case FFEINFO_kindtypeREAL7:
3130 *aptr = array.real7 + offset;
3131 break;
3132 #endif
3133
3134 #if FFETARGET_okREAL8
3135 case FFEINFO_kindtypeREAL8:
3136 *aptr = array.real8 + offset;
3137 break;
3138 #endif
3139
3140 default:
3141 assert ("bad REAL akindtype" == NULL);
3142 break;
3143 }
3144 break;
3145
3146 case FFEINFO_basictypeCOMPLEX:
3147 switch (akt)
3148 {
3149 #if FFETARGET_okCOMPLEX1
3150 case FFEINFO_kindtypeREAL1:
3151 *aptr = array.complex1 + offset;
3152 break;
3153 #endif
3154
3155 #if FFETARGET_okCOMPLEX2
3156 case FFEINFO_kindtypeREAL2:
3157 *aptr = array.complex2 + offset;
3158 break;
3159 #endif
3160
3161 #if FFETARGET_okCOMPLEX3
3162 case FFEINFO_kindtypeREAL3:
3163 *aptr = array.complex3 + offset;
3164 break;
3165 #endif
3166
3167 #if FFETARGET_okCOMPLEX4
3168 case FFEINFO_kindtypeREAL4:
3169 *aptr = array.complex4 + offset;
3170 break;
3171 #endif
3172
3173 #if FFETARGET_okCOMPLEX5
3174 case FFEINFO_kindtypeREAL5:
3175 *aptr = array.complex5 + offset;
3176 break;
3177 #endif
3178
3179 #if FFETARGET_okCOMPLEX6
3180 case FFEINFO_kindtypeREAL6:
3181 *aptr = array.complex6 + offset;
3182 break;
3183 #endif
3184
3185 #if FFETARGET_okCOMPLEX7
3186 case FFEINFO_kindtypeREAL7:
3187 *aptr = array.complex7 + offset;
3188 break;
3189 #endif
3190
3191 #if FFETARGET_okCOMPLEX8
3192 case FFEINFO_kindtypeREAL8:
3193 *aptr = array.complex8 + offset;
3194 break;
3195 #endif
3196
3197 default:
3198 assert ("bad COMPLEX akindtype" == NULL);
3199 break;
3200 }
3201 break;
3202
3203 case FFEINFO_basictypeCHARACTER:
3204 switch (akt)
3205 {
3206 #if FFETARGET_okCHARACTER1
3207 case FFEINFO_kindtypeCHARACTER1:
3208 *aptr = array.character1 + offset;
3209 break;
3210 #endif
3211
3212 #if FFETARGET_okCHARACTER2
3213 case FFEINFO_kindtypeCHARACTER2:
3214 *aptr = array.character2 + offset;
3215 break;
3216 #endif
3217
3218 #if FFETARGET_okCHARACTER3
3219 case FFEINFO_kindtypeCHARACTER3:
3220 *aptr = array.character3 + offset;
3221 break;
3222 #endif
3223
3224 #if FFETARGET_okCHARACTER4
3225 case FFEINFO_kindtypeCHARACTER4:
3226 *aptr = array.character4 + offset;
3227 break;
3228 #endif
3229
3230 #if FFETARGET_okCHARACTER5
3231 case FFEINFO_kindtypeCHARACTER5:
3232 *aptr = array.character5 + offset;
3233 break;
3234 #endif
3235
3236 #if FFETARGET_okCHARACTER6
3237 case FFEINFO_kindtypeCHARACTER6:
3238 *aptr = array.character6 + offset;
3239 break;
3240 #endif
3241
3242 #if FFETARGET_okCHARACTER7
3243 case FFEINFO_kindtypeCHARACTER7:
3244 *aptr = array.character7 + offset;
3245 break;
3246 #endif
3247
3248 #if FFETARGET_okCHARACTER8
3249 case FFEINFO_kindtypeCHARACTER8:
3250 *aptr = array.character8 + offset;
3251 break;
3252 #endif
3253
3254 default:
3255 assert ("bad CHARACTER akindtype" == NULL);
3256 break;
3257 }
3258 break;
3259
3260 default:
3261 assert ("bad abasictype" == NULL);
3262 break;
3263 }
3264
3265 switch (cbt)
3266 {
3267 case FFEINFO_basictypeINTEGER:
3268 switch (ckt)
3269 {
3270 #if FFETARGET_okINTEGER1
3271 case FFEINFO_kindtypeINTEGER1:
3272 *cptr = &constant->integer1;
3273 *size = sizeof (constant->integer1);
3274 break;
3275 #endif
3276
3277 #if FFETARGET_okINTEGER2
3278 case FFEINFO_kindtypeINTEGER2:
3279 *cptr = &constant->integer2;
3280 *size = sizeof (constant->integer2);
3281 break;
3282 #endif
3283
3284 #if FFETARGET_okINTEGER3
3285 case FFEINFO_kindtypeINTEGER3:
3286 *cptr = &constant->integer3;
3287 *size = sizeof (constant->integer3);
3288 break;
3289 #endif
3290
3291 #if FFETARGET_okINTEGER4
3292 case FFEINFO_kindtypeINTEGER4:
3293 *cptr = &constant->integer4;
3294 *size = sizeof (constant->integer4);
3295 break;
3296 #endif
3297
3298 #if FFETARGET_okINTEGER5
3299 case FFEINFO_kindtypeINTEGER5:
3300 *cptr = &constant->integer5;
3301 *size = sizeof (constant->integer5);
3302 break;
3303 #endif
3304
3305 #if FFETARGET_okINTEGER6
3306 case FFEINFO_kindtypeINTEGER6:
3307 *cptr = &constant->integer6;
3308 *size = sizeof (constant->integer6);
3309 break;
3310 #endif
3311
3312 #if FFETARGET_okINTEGER7
3313 case FFEINFO_kindtypeINTEGER7:
3314 *cptr = &constant->integer7;
3315 *size = sizeof (constant->integer7);
3316 break;
3317 #endif
3318
3319 #if FFETARGET_okINTEGER8
3320 case FFEINFO_kindtypeINTEGER8:
3321 *cptr = &constant->integer8;
3322 *size = sizeof (constant->integer8);
3323 break;
3324 #endif
3325
3326 default:
3327 assert ("bad INTEGER ckindtype" == NULL);
3328 break;
3329 }
3330 break;
3331
3332 case FFEINFO_basictypeLOGICAL:
3333 switch (ckt)
3334 {
3335 #if FFETARGET_okLOGICAL1
3336 case FFEINFO_kindtypeLOGICAL1:
3337 *cptr = &constant->logical1;
3338 *size = sizeof (constant->logical1);
3339 break;
3340 #endif
3341
3342 #if FFETARGET_okLOGICAL2
3343 case FFEINFO_kindtypeLOGICAL2:
3344 *cptr = &constant->logical2;
3345 *size = sizeof (constant->logical2);
3346 break;
3347 #endif
3348
3349 #if FFETARGET_okLOGICAL3
3350 case FFEINFO_kindtypeLOGICAL3:
3351 *cptr = &constant->logical3;
3352 *size = sizeof (constant->logical3);
3353 break;
3354 #endif
3355
3356 #if FFETARGET_okLOGICAL4
3357 case FFEINFO_kindtypeLOGICAL4:
3358 *cptr = &constant->logical4;
3359 *size = sizeof (constant->logical4);
3360 break;
3361 #endif
3362
3363 #if FFETARGET_okLOGICAL5
3364 case FFEINFO_kindtypeLOGICAL5:
3365 *cptr = &constant->logical5;
3366 *size = sizeof (constant->logical5);
3367 break;
3368 #endif
3369
3370 #if FFETARGET_okLOGICAL6
3371 case FFEINFO_kindtypeLOGICAL6:
3372 *cptr = &constant->logical6;
3373 *size = sizeof (constant->logical6);
3374 break;
3375 #endif
3376
3377 #if FFETARGET_okLOGICAL7
3378 case FFEINFO_kindtypeLOGICAL7:
3379 *cptr = &constant->logical7;
3380 *size = sizeof (constant->logical7);
3381 break;
3382 #endif
3383
3384 #if FFETARGET_okLOGICAL8
3385 case FFEINFO_kindtypeLOGICAL8:
3386 *cptr = &constant->logical8;
3387 *size = sizeof (constant->logical8);
3388 break;
3389 #endif
3390
3391 default:
3392 assert ("bad LOGICAL ckindtype" == NULL);
3393 break;
3394 }
3395 break;
3396
3397 case FFEINFO_basictypeREAL:
3398 switch (ckt)
3399 {
3400 #if FFETARGET_okREAL1
3401 case FFEINFO_kindtypeREAL1:
3402 *cptr = &constant->real1;
3403 *size = sizeof (constant->real1);
3404 break;
3405 #endif
3406
3407 #if FFETARGET_okREAL2
3408 case FFEINFO_kindtypeREAL2:
3409 *cptr = &constant->real2;
3410 *size = sizeof (constant->real2);
3411 break;
3412 #endif
3413
3414 #if FFETARGET_okREAL3
3415 case FFEINFO_kindtypeREAL3:
3416 *cptr = &constant->real3;
3417 *size = sizeof (constant->real3);
3418 break;
3419 #endif
3420
3421 #if FFETARGET_okREAL4
3422 case FFEINFO_kindtypeREAL4:
3423 *cptr = &constant->real4;
3424 *size = sizeof (constant->real4);
3425 break;
3426 #endif
3427
3428 #if FFETARGET_okREAL5
3429 case FFEINFO_kindtypeREAL5:
3430 *cptr = &constant->real5;
3431 *size = sizeof (constant->real5);
3432 break;
3433 #endif
3434
3435 #if FFETARGET_okREAL6
3436 case FFEINFO_kindtypeREAL6:
3437 *cptr = &constant->real6;
3438 *size = sizeof (constant->real6);
3439 break;
3440 #endif
3441
3442 #if FFETARGET_okREAL7
3443 case FFEINFO_kindtypeREAL7:
3444 *cptr = &constant->real7;
3445 *size = sizeof (constant->real7);
3446 break;
3447 #endif
3448
3449 #if FFETARGET_okREAL8
3450 case FFEINFO_kindtypeREAL8:
3451 *cptr = &constant->real8;
3452 *size = sizeof (constant->real8);
3453 break;
3454 #endif
3455
3456 default:
3457 assert ("bad REAL ckindtype" == NULL);
3458 break;
3459 }
3460 break;
3461
3462 case FFEINFO_basictypeCOMPLEX:
3463 switch (ckt)
3464 {
3465 #if FFETARGET_okCOMPLEX1
3466 case FFEINFO_kindtypeREAL1:
3467 *cptr = &constant->complex1;
3468 *size = sizeof (constant->complex1);
3469 break;
3470 #endif
3471
3472 #if FFETARGET_okCOMPLEX2
3473 case FFEINFO_kindtypeREAL2:
3474 *cptr = &constant->complex2;
3475 *size = sizeof (constant->complex2);
3476 break;
3477 #endif
3478
3479 #if FFETARGET_okCOMPLEX3
3480 case FFEINFO_kindtypeREAL3:
3481 *cptr = &constant->complex3;
3482 *size = sizeof (constant->complex3);
3483 break;
3484 #endif
3485
3486 #if FFETARGET_okCOMPLEX4
3487 case FFEINFO_kindtypeREAL4:
3488 *cptr = &constant->complex4;
3489 *size = sizeof (constant->complex4);
3490 break;
3491 #endif
3492
3493 #if FFETARGET_okCOMPLEX5
3494 case FFEINFO_kindtypeREAL5:
3495 *cptr = &constant->complex5;
3496 *size = sizeof (constant->complex5);
3497 break;
3498 #endif
3499
3500 #if FFETARGET_okCOMPLEX6
3501 case FFEINFO_kindtypeREAL6:
3502 *cptr = &constant->complex6;
3503 *size = sizeof (constant->complex6);
3504 break;
3505 #endif
3506
3507 #if FFETARGET_okCOMPLEX7
3508 case FFEINFO_kindtypeREAL7:
3509 *cptr = &constant->complex7;
3510 *size = sizeof (constant->complex7);
3511 break;
3512 #endif
3513
3514 #if FFETARGET_okCOMPLEX8
3515 case FFEINFO_kindtypeREAL8:
3516 *cptr = &constant->complex8;
3517 *size = sizeof (constant->complex8);
3518 break;
3519 #endif
3520
3521 default:
3522 assert ("bad COMPLEX ckindtype" == NULL);
3523 break;
3524 }
3525 break;
3526
3527 case FFEINFO_basictypeCHARACTER:
3528 switch (ckt)
3529 {
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
3536
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
3543
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
3550
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
3557
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
3564
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
3571
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
3578
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
3585
3586 default:
3587 assert ("bad CHARACTER ckindtype" == NULL);
3588 break;
3589 }
3590 break;
3591
3592 default:
3593 assert ("bad cbasictype" == NULL);
3594 break;
3595 }
3596 }
3597
3598 /* ffebld_constantarray_put -- Put a value into an array of constants
3599
3600 See prototype. */
3601
3602 void
ffebld_constantarray_put(ffebldConstantArray array,ffeinfoBasictype bt,ffeinfoKindtype kt,ffetargetOffset offset,ffebldConstantUnion constant)3603 ffebld_constantarray_put (ffebldConstantArray array, ffeinfoBasictype bt,
3604 ffeinfoKindtype kt, ffetargetOffset offset, ffebldConstantUnion constant)
3605 {
3606 switch (bt)
3607 {
3608 case FFEINFO_basictypeINTEGER:
3609 switch (kt)
3610 {
3611 #if FFETARGET_okINTEGER1
3612 case FFEINFO_kindtypeINTEGER1:
3613 *(array.integer1 + offset) = constant.integer1;
3614 break;
3615 #endif
3616
3617 #if FFETARGET_okINTEGER2
3618 case FFEINFO_kindtypeINTEGER2:
3619 *(array.integer2 + offset) = constant.integer2;
3620 break;
3621 #endif
3622
3623 #if FFETARGET_okINTEGER3
3624 case FFEINFO_kindtypeINTEGER3:
3625 *(array.integer3 + offset) = constant.integer3;
3626 break;
3627 #endif
3628
3629 #if FFETARGET_okINTEGER4
3630 case FFEINFO_kindtypeINTEGER4:
3631 *(array.integer4 + offset) = constant.integer4;
3632 break;
3633 #endif
3634
3635 #if FFETARGET_okINTEGER5
3636 case FFEINFO_kindtypeINTEGER5:
3637 *(array.integer5 + offset) = constant.integer5;
3638 break;
3639 #endif
3640
3641 #if FFETARGET_okINTEGER6
3642 case FFEINFO_kindtypeINTEGER6:
3643 *(array.integer6 + offset) = constant.integer6;
3644 break;
3645 #endif
3646
3647 #if FFETARGET_okINTEGER7
3648 case FFEINFO_kindtypeINTEGER7:
3649 *(array.integer7 + offset) = constant.integer7;
3650 break;
3651 #endif
3652
3653 #if FFETARGET_okINTEGER8
3654 case FFEINFO_kindtypeINTEGER8:
3655 *(array.integer8 + offset) = constant.integer8;
3656 break;
3657 #endif
3658
3659 default:
3660 assert ("bad INTEGER kindtype" == NULL);
3661 break;
3662 }
3663 break;
3664
3665 case FFEINFO_basictypeLOGICAL:
3666 switch (kt)
3667 {
3668 #if FFETARGET_okLOGICAL1
3669 case FFEINFO_kindtypeLOGICAL1:
3670 *(array.logical1 + offset) = constant.logical1;
3671 break;
3672 #endif
3673
3674 #if FFETARGET_okLOGICAL2
3675 case FFEINFO_kindtypeLOGICAL2:
3676 *(array.logical2 + offset) = constant.logical2;
3677 break;
3678 #endif
3679
3680 #if FFETARGET_okLOGICAL3
3681 case FFEINFO_kindtypeLOGICAL3:
3682 *(array.logical3 + offset) = constant.logical3;
3683 break;
3684 #endif
3685
3686 #if FFETARGET_okLOGICAL4
3687 case FFEINFO_kindtypeLOGICAL4:
3688 *(array.logical4 + offset) = constant.logical4;
3689 break;
3690 #endif
3691
3692 #if FFETARGET_okLOGICAL5
3693 case FFEINFO_kindtypeLOGICAL5:
3694 *(array.logical5 + offset) = constant.logical5;
3695 break;
3696 #endif
3697
3698 #if FFETARGET_okLOGICAL6
3699 case FFEINFO_kindtypeLOGICAL6:
3700 *(array.logical6 + offset) = constant.logical6;
3701 break;
3702 #endif
3703
3704 #if FFETARGET_okLOGICAL7
3705 case FFEINFO_kindtypeLOGICAL7:
3706 *(array.logical7 + offset) = constant.logical7;
3707 break;
3708 #endif
3709
3710 #if FFETARGET_okLOGICAL8
3711 case FFEINFO_kindtypeLOGICAL8:
3712 *(array.logical8 + offset) = constant.logical8;
3713 break;
3714 #endif
3715
3716 default:
3717 assert ("bad LOGICAL kindtype" == NULL);
3718 break;
3719 }
3720 break;
3721
3722 case FFEINFO_basictypeREAL:
3723 switch (kt)
3724 {
3725 #if FFETARGET_okREAL1
3726 case FFEINFO_kindtypeREAL1:
3727 *(array.real1 + offset) = constant.real1;
3728 break;
3729 #endif
3730
3731 #if FFETARGET_okREAL2
3732 case FFEINFO_kindtypeREAL2:
3733 *(array.real2 + offset) = constant.real2;
3734 break;
3735 #endif
3736
3737 #if FFETARGET_okREAL3
3738 case FFEINFO_kindtypeREAL3:
3739 *(array.real3 + offset) = constant.real3;
3740 break;
3741 #endif
3742
3743 #if FFETARGET_okREAL4
3744 case FFEINFO_kindtypeREAL4:
3745 *(array.real4 + offset) = constant.real4;
3746 break;
3747 #endif
3748
3749 #if FFETARGET_okREAL5
3750 case FFEINFO_kindtypeREAL5:
3751 *(array.real5 + offset) = constant.real5;
3752 break;
3753 #endif
3754
3755 #if FFETARGET_okREAL6
3756 case FFEINFO_kindtypeREAL6:
3757 *(array.real6 + offset) = constant.real6;
3758 break;
3759 #endif
3760
3761 #if FFETARGET_okREAL7
3762 case FFEINFO_kindtypeREAL7:
3763 *(array.real7 + offset) = constant.real7;
3764 break;
3765 #endif
3766
3767 #if FFETARGET_okREAL8
3768 case FFEINFO_kindtypeREAL8:
3769 *(array.real8 + offset) = constant.real8;
3770 break;
3771 #endif
3772
3773 default:
3774 assert ("bad REAL kindtype" == NULL);
3775 break;
3776 }
3777 break;
3778
3779 case FFEINFO_basictypeCOMPLEX:
3780 switch (kt)
3781 {
3782 #if FFETARGET_okCOMPLEX1
3783 case FFEINFO_kindtypeREAL1:
3784 *(array.complex1 + offset) = constant.complex1;
3785 break;
3786 #endif
3787
3788 #if FFETARGET_okCOMPLEX2
3789 case FFEINFO_kindtypeREAL2:
3790 *(array.complex2 + offset) = constant.complex2;
3791 break;
3792 #endif
3793
3794 #if FFETARGET_okCOMPLEX3
3795 case FFEINFO_kindtypeREAL3:
3796 *(array.complex3 + offset) = constant.complex3;
3797 break;
3798 #endif
3799
3800 #if FFETARGET_okCOMPLEX4
3801 case FFEINFO_kindtypeREAL4:
3802 *(array.complex4 + offset) = constant.complex4;
3803 break;
3804 #endif
3805
3806 #if FFETARGET_okCOMPLEX5
3807 case FFEINFO_kindtypeREAL5:
3808 *(array.complex5 + offset) = constant.complex5;
3809 break;
3810 #endif
3811
3812 #if FFETARGET_okCOMPLEX6
3813 case FFEINFO_kindtypeREAL6:
3814 *(array.complex6 + offset) = constant.complex6;
3815 break;
3816 #endif
3817
3818 #if FFETARGET_okCOMPLEX7
3819 case FFEINFO_kindtypeREAL7:
3820 *(array.complex7 + offset) = constant.complex7;
3821 break;
3822 #endif
3823
3824 #if FFETARGET_okCOMPLEX8
3825 case FFEINFO_kindtypeREAL8:
3826 *(array.complex8 + offset) = constant.complex8;
3827 break;
3828 #endif
3829
3830 default:
3831 assert ("bad COMPLEX kindtype" == NULL);
3832 break;
3833 }
3834 break;
3835
3836 case FFEINFO_basictypeCHARACTER:
3837 switch (kt)
3838 {
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
3846
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
3854
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
3862
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
3870
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
3878
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
3886
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
3894
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
3902
3903 default:
3904 assert ("bad CHARACTER kindtype" == NULL);
3905 break;
3906 }
3907 break;
3908
3909 default:
3910 assert ("bad basictype" == NULL);
3911 break;
3912 }
3913 }
3914
3915 /* ffebld_init_0 -- Initialize the module
3916
3917 ffebld_init_0(); */
3918
3919 void
ffebld_init_0()3920 ffebld_init_0 ()
3921 {
3922 assert (FFEBLD_op == ARRAY_SIZE (ffebld_op_string_));
3923 assert (FFEBLD_op == ARRAY_SIZE (ffebld_arity_op_));
3924 }
3925
3926 /* ffebld_init_1 -- Initialize the module for a file
3927
3928 ffebld_init_1(); */
3929
3930 void
ffebld_init_1()3931 ffebld_init_1 ()
3932 {
3933 #if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstFILE_
3934 int i;
3935
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
4060 }
4061
4062 /* ffebld_init_2 -- Initialize the module
4063
4064 ffebld_init_2(); */
4065
4066 void
ffebld_init_2()4067 ffebld_init_2 ()
4068 {
4069 #if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstPROGUNIT_
4070 int i;
4071 #endif
4072
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
4200 }
4201
4202 /* ffebld_list_length -- Return # of opITEMs in list
4203
4204 ffebld list; // Must be NULL or opITEM
4205 ffebldListLength length;
4206 length = ffebld_list_length(list);
4207
4208 Returns 0 if list is NULL, 1 if it's ffebld_trail is NULL, and so on. */
4209
4210 ffebldListLength
ffebld_list_length(ffebld list)4211 ffebld_list_length (ffebld list)
4212 {
4213 ffebldListLength length;
4214
4215 for (length = 0; list != NULL; ++length, list = ffebld_trail (list))
4216 ;
4217
4218 return length;
4219 }
4220
4221 /* ffebld_new_accter -- Create an ffebld object that is an array
4222
4223 ffebld x;
4224 ffebldConstantArray a;
4225 ffebit b;
4226 x = ffebld_new_accter(a,b); */
4227
4228 ffebld
ffebld_new_accter(ffebldConstantArray a,ffebit b)4229 ffebld_new_accter (ffebldConstantArray a, ffebit b)
4230 {
4231 ffebld x;
4232
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;
4242 }
4243
4244 /* ffebld_new_arrter -- Create an ffebld object that is an array
4245
4246 ffebld x;
4247 ffebldConstantArray a;
4248 ffetargetOffset size;
4249 x = ffebld_new_arrter(a,size); */
4250
4251 ffebld
ffebld_new_arrter(ffebldConstantArray a,ffetargetOffset size)4252 ffebld_new_arrter (ffebldConstantArray a, ffetargetOffset size)
4253 {
4254 ffebld x;
4255
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;
4265 }
4266
4267 /* ffebld_new_conter_with_orig -- Create an ffebld object that is a constant
4268
4269 ffebld x;
4270 ffebldConstant c;
4271 x = ffebld_new_conter_with_orig(c,NULL); */
4272
4273 ffebld
ffebld_new_conter_with_orig(ffebldConstant c,ffebld o)4274 ffebld_new_conter_with_orig (ffebldConstant c, ffebld o)
4275 {
4276 ffebld x;
4277
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;
4287 }
4288
4289 /* ffebld_new_item -- Create an ffebld item object
4290
4291 ffebld x,y,z;
4292 x = ffebld_new_item(y,z); */
4293
4294 ffebld
ffebld_new_item(ffebld head,ffebld trail)4295 ffebld_new_item (ffebld head, ffebld trail)
4296 {
4297 ffebld x;
4298
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;
4310 }
4311
4312 /* ffebld_new_labter -- Create an ffebld object that is a label
4313
4314 ffebld x;
4315 ffelab l;
4316 x = ffebld_new_labter(c); */
4317
4318 ffebld
ffebld_new_labter(ffelab l)4319 ffebld_new_labter (ffelab l)
4320 {
4321 ffebld x;
4322
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;
4330 }
4331
4332 /* ffebld_new_labtok -- Create object that is a label's NUMBER token
4333
4334 ffebld x;
4335 ffelexToken t;
4336 x = ffebld_new_labter(c);
4337
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). */
4342
4343 ffebld
ffebld_new_labtok(ffelexToken t)4344 ffebld_new_labtok (ffelexToken t)
4345 {
4346 ffebld x;
4347
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;
4355 }
4356
4357 /* ffebld_new_none -- Create an ffebld object with no arguments
4358
4359 ffebld x;
4360 x = ffebld_new_none(FFEBLD_opWHATEVER); */
4361
4362 ffebld
ffebld_new_none(ffebldOp o)4363 ffebld_new_none (ffebldOp o)
4364 {
4365 ffebld x;
4366
4367 x = ffebld_new ();
4368 #if FFEBLD_BLANK_
4369 *x = ffebld_blank_;
4370 #endif
4371 x->op = o;
4372 return x;
4373 }
4374
4375 /* ffebld_new_one -- Create an ffebld object with one argument
4376
4377 ffebld x,y;
4378 x = ffebld_new_one(FFEBLD_opWHATEVER,y); */
4379
4380 ffebld
ffebld_new_one(ffebldOp o,ffebld left)4381 ffebld_new_one (ffebldOp o, ffebld left)
4382 {
4383 ffebld x;
4384
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;
4395 }
4396
4397 /* ffebld_new_symter -- Create an ffebld object that is a symbol
4398
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); */
4405
4406 ffebld
ffebld_new_symter(ffesymbol s,ffeintrinGen gen,ffeintrinSpec spec,ffeintrinImp imp)4407 ffebld_new_symter (ffesymbol s, ffeintrinGen gen, ffeintrinSpec spec,
4408 ffeintrinImp imp)
4409 {
4410 ffebld x;
4411
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;
4423 }
4424
4425 /* ffebld_new_two -- Create an ffebld object with two arguments
4426
4427 ffebld x,y,z;
4428 x = ffebld_new_two(FFEBLD_opWHATEVER,y,z); */
4429
4430 ffebld
ffebld_new_two(ffebldOp o,ffebld left,ffebld right)4431 ffebld_new_two (ffebldOp o, ffebld left, ffebld right)
4432 {
4433 ffebld x;
4434
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;
4446 }
4447
4448 /* ffebld_pool_pop -- Pop ffebld's pool stack
4449
4450 ffebld_pool_pop(); */
4451
4452 void
ffebld_pool_pop()4453 ffebld_pool_pop ()
4454 {
4455 ffebldPoolstack_ ps;
4456
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));
4462 }
4463
4464 /* ffebld_pool_push -- Push ffebld's pool stack
4465
4466 ffebld_pool_push(); */
4467
4468 void
ffebld_pool_push(mallocPool pool)4469 ffebld_pool_push (mallocPool pool)
4470 {
4471 ffebldPoolstack_ ps;
4472
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;
4478 }
4479
4480 /* ffebld_op_string -- Return short string describing op
4481
4482 ffebldOp o;
4483 ffebld_op_string(o);
4484
4485 Returns a short string (uppercase) containing the name of the op. */
4486
4487 const char *
ffebld_op_string(ffebldOp o)4488 ffebld_op_string (ffebldOp o)
4489 {
4490 if (o >= ARRAY_SIZE (ffebld_op_string_))
4491 return "?\?\?";
4492 return ffebld_op_string_[o];
4493 }
4494
4495 /* ffebld_size_max -- Return maximum possible size of CHARACTER-type expr
4496
4497 ffetargetCharacterSize sz;
4498 ffebld b;
4499 sz = ffebld_size_max (b);
4500
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). */
4504
4505 ffetargetCharacterSize
ffebld_size_max(ffebld b)4506 ffebld_size_max (ffebld b)
4507 {
4508 ffetargetCharacterSize sz;
4509
4510 recurse: /* :::::::::::::::::::: */
4511
4512 sz = ffebld_size_known (b);
4513
4514 if (sz != FFETARGET_charactersizeNONE)
4515 return sz;
4516
4517 switch (ffebld_op (b))
4518 {
4519 case FFEBLD_opSUBSTR:
4520 case FFEBLD_opCONVERT:
4521 case FFEBLD_opPAREN:
4522 b = ffebld_left (b);
4523 goto recurse; /* :::::::::::::::::::: */
4524
4525 case FFEBLD_opCONCATENATE:
4526 sz = ffebld_size_max (ffebld_left (b))
4527 + ffebld_size_max (ffebld_right (b));
4528 return sz;
4529
4530 default:
4531 return sz;
4532 }
4533 }
4534