1 /* bld.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 2003 Free Software Foundation, Inc.
3 Contributed by James Craig Burley.
5 This file is part of GNU Fortran.
7 GNU Fortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Fortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Fortran; see the file COPYING. If not, write to
19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
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
33 Change names of some things for consistency.
48 /* Externals defined here. */
50 const ffebldArity ffebld_arity_op_
[(int) FFEBLD_op
]
53 #define FFEBLD_OP(KWD,NAME,ARITY) ARITY,
57 struct _ffebld_pool_stack_ ffebld_pool_stack_
;
59 /* Simple definitions and enumerations. */
62 /* Internal typedefs. */
65 /* Private include files. */
68 /* Internal structure definitions. */
71 /* Static objects accessed by functions in this module. */
73 #if FFETARGET_okCHARACTER1
74 static ffebldConstant ffebld_constant_character1_
;
76 #if FFETARGET_okCOMPLEX1
77 static ffebldConstant ffebld_constant_complex1_
;
79 #if FFETARGET_okCOMPLEX2
80 static ffebldConstant ffebld_constant_complex2_
;
82 #if FFETARGET_okCOMPLEX3
83 static ffebldConstant ffebld_constant_complex3_
;
85 #if FFETARGET_okINTEGER1
86 static ffebldConstant ffebld_constant_integer1_
;
88 #if FFETARGET_okINTEGER2
89 static ffebldConstant ffebld_constant_integer2_
;
91 #if FFETARGET_okINTEGER3
92 static ffebldConstant ffebld_constant_integer3_
;
94 #if FFETARGET_okINTEGER4
95 static ffebldConstant ffebld_constant_integer4_
;
97 #if FFETARGET_okLOGICAL1
98 static ffebldConstant ffebld_constant_logical1_
;
100 #if FFETARGET_okLOGICAL2
101 static ffebldConstant ffebld_constant_logical2_
;
103 #if FFETARGET_okLOGICAL3
104 static ffebldConstant ffebld_constant_logical3_
;
106 #if FFETARGET_okLOGICAL4
107 static ffebldConstant ffebld_constant_logical4_
;
109 #if FFETARGET_okREAL1
110 static ffebldConstant ffebld_constant_real1_
;
112 #if FFETARGET_okREAL2
113 static ffebldConstant ffebld_constant_real2_
;
115 #if FFETARGET_okREAL3
116 static ffebldConstant ffebld_constant_real3_
;
118 static ffebldConstant ffebld_constant_hollerith_
;
119 static ffebldConstant ffebld_constant_typeless_
[FFEBLD_constTYPELESS_LAST
120 - FFEBLD_constTYPELESS_FIRST
+ 1];
122 static const char *const ffebld_op_string_
[]
125 #define FFEBLD_OP(KWD,NAME,ARITY) NAME,
126 #include "bld-op.def"
130 /* Static functions (internal). */
133 /* Internal macros. */
135 #define integerdefault_ CATX(integer,FFETARGET_ktINTEGERDEFAULT)
136 #define logicaldefault_ CATX(logical,FFETARGET_ktLOGICALDEFAULT)
137 #define realdefault_ CATX(real,FFETARGET_ktREALDEFAULT)
138 #define realdouble_ CATX(real,FFETARGET_ktREALDOUBLE)
139 #define realquad_ CATX(real,FFETARGET_ktREALQUAD)
141 /* ffebld_constant_cmp -- Compare two constants a la strcmp
143 ffebldConstant c1, c2;
144 if (ffebld_constant_cmp(c1,c2) == 0)
145 // they're equal, else they're not.
147 Returns -1 if c1 < c2, 0 if c1 == c2, +1 if c1 == c2. */
150 ffebld_constant_cmp (ffebldConstant c1
, ffebldConstant c2
)
155 assert (ffebld_constant_type (c1
) == ffebld_constant_type (c2
));
157 switch (ffebld_constant_type (c1
))
159 #if FFETARGET_okINTEGER1
160 case FFEBLD_constINTEGER1
:
161 return ffetarget_cmp_integer1 (ffebld_constant_integer1 (c1
),
162 ffebld_constant_integer1 (c2
));
165 #if FFETARGET_okINTEGER2
166 case FFEBLD_constINTEGER2
:
167 return ffetarget_cmp_integer2 (ffebld_constant_integer2 (c1
),
168 ffebld_constant_integer2 (c2
));
171 #if FFETARGET_okINTEGER3
172 case FFEBLD_constINTEGER3
:
173 return ffetarget_cmp_integer3 (ffebld_constant_integer3 (c1
),
174 ffebld_constant_integer3 (c2
));
177 #if FFETARGET_okINTEGER4
178 case FFEBLD_constINTEGER4
:
179 return ffetarget_cmp_integer4 (ffebld_constant_integer4 (c1
),
180 ffebld_constant_integer4 (c2
));
183 #if FFETARGET_okLOGICAL1
184 case FFEBLD_constLOGICAL1
:
185 return ffetarget_cmp_logical1 (ffebld_constant_logical1 (c1
),
186 ffebld_constant_logical1 (c2
));
189 #if FFETARGET_okLOGICAL2
190 case FFEBLD_constLOGICAL2
:
191 return ffetarget_cmp_logical2 (ffebld_constant_logical2 (c1
),
192 ffebld_constant_logical2 (c2
));
195 #if FFETARGET_okLOGICAL3
196 case FFEBLD_constLOGICAL3
:
197 return ffetarget_cmp_logical3 (ffebld_constant_logical3 (c1
),
198 ffebld_constant_logical3 (c2
));
201 #if FFETARGET_okLOGICAL4
202 case FFEBLD_constLOGICAL4
:
203 return ffetarget_cmp_logical4 (ffebld_constant_logical4 (c1
),
204 ffebld_constant_logical4 (c2
));
207 #if FFETARGET_okREAL1
208 case FFEBLD_constREAL1
:
209 return ffetarget_cmp_real1 (ffebld_constant_real1 (c1
),
210 ffebld_constant_real1 (c2
));
213 #if FFETARGET_okREAL2
214 case FFEBLD_constREAL2
:
215 return ffetarget_cmp_real2 (ffebld_constant_real2 (c1
),
216 ffebld_constant_real2 (c2
));
219 #if FFETARGET_okREAL3
220 case FFEBLD_constREAL3
:
221 return ffetarget_cmp_real3 (ffebld_constant_real3 (c1
),
222 ffebld_constant_real3 (c2
));
225 #if FFETARGET_okCHARACTER1
226 case FFEBLD_constCHARACTER1
:
227 return ffetarget_cmp_character1 (ffebld_constant_character1 (c1
),
228 ffebld_constant_character1 (c2
));
232 assert ("bad constant type" == NULL
);
237 /* ffebld_constant_is_magical -- Determine if integer is "magical"
240 if (ffebld_constant_is_magical(c))
241 // it is 2**(n-1), where n is # bits in ffetargetIntegerDefault type
242 // (this test is important for 2's-complement machines only). */
245 ffebld_constant_is_magical (ffebldConstant c
)
247 switch (ffebld_constant_type (c
))
249 case FFEBLD_constINTEGERDEFAULT
:
250 return ffetarget_integerdefault_is_magical (ffebld_constant_integer1 (c
));
257 /* Determine if constant is zero. Used to ensure step count
258 for DO loops isn't zero, also to determine if values will
259 be binary zeros, so not entirely portable at this point. */
262 ffebld_constant_is_zero (ffebldConstant c
)
264 switch (ffebld_constant_type (c
))
266 #if FFETARGET_okINTEGER1
267 case FFEBLD_constINTEGER1
:
268 return ffebld_constant_integer1 (c
) == 0;
271 #if FFETARGET_okINTEGER2
272 case FFEBLD_constINTEGER2
:
273 return ffebld_constant_integer2 (c
) == 0;
276 #if FFETARGET_okINTEGER3
277 case FFEBLD_constINTEGER3
:
278 return ffebld_constant_integer3 (c
) == 0;
281 #if FFETARGET_okINTEGER4
282 case FFEBLD_constINTEGER4
:
283 return ffebld_constant_integer4 (c
) == 0;
286 #if FFETARGET_okLOGICAL1
287 case FFEBLD_constLOGICAL1
:
288 return ffebld_constant_logical1 (c
) == 0;
291 #if FFETARGET_okLOGICAL2
292 case FFEBLD_constLOGICAL2
:
293 return ffebld_constant_logical2 (c
) == 0;
296 #if FFETARGET_okLOGICAL3
297 case FFEBLD_constLOGICAL3
:
298 return ffebld_constant_logical3 (c
) == 0;
301 #if FFETARGET_okLOGICAL4
302 case FFEBLD_constLOGICAL4
:
303 return ffebld_constant_logical4 (c
) == 0;
306 #if FFETARGET_okREAL1
307 case FFEBLD_constREAL1
:
308 return ffetarget_iszero_real1 (ffebld_constant_real1 (c
));
311 #if FFETARGET_okREAL2
312 case FFEBLD_constREAL2
:
313 return ffetarget_iszero_real2 (ffebld_constant_real2 (c
));
316 #if FFETARGET_okREAL3
317 case FFEBLD_constREAL3
:
318 return ffetarget_iszero_real3 (ffebld_constant_real3 (c
));
321 #if FFETARGET_okCOMPLEX1
322 case FFEBLD_constCOMPLEX1
:
323 return ffetarget_iszero_real1 (ffebld_constant_complex1 (c
).real
)
324 && ffetarget_iszero_real1 (ffebld_constant_complex1 (c
).imaginary
);
327 #if FFETARGET_okCOMPLEX2
328 case FFEBLD_constCOMPLEX2
:
329 return ffetarget_iszero_real2 (ffebld_constant_complex2 (c
).real
)
330 && ffetarget_iszero_real2 (ffebld_constant_complex2 (c
).imaginary
);
333 #if FFETARGET_okCOMPLEX3
334 case FFEBLD_constCOMPLEX3
:
335 return ffetarget_iszero_real3 (ffebld_constant_complex3 (c
).real
)
336 && ffetarget_iszero_real3 (ffebld_constant_complex3 (c
).imaginary
);
339 #if FFETARGET_okCHARACTER1
340 case FFEBLD_constCHARACTER1
:
341 return ffetarget_iszero_character1 (ffebld_constant_character1 (c
));
344 case FFEBLD_constHOLLERITH
:
345 return ffetarget_iszero_hollerith (ffebld_constant_hollerith (c
));
347 case FFEBLD_constBINARY_MIL
:
348 case FFEBLD_constBINARY_VXT
:
349 case FFEBLD_constOCTAL_MIL
:
350 case FFEBLD_constOCTAL_VXT
:
351 case FFEBLD_constHEX_X_MIL
:
352 case FFEBLD_constHEX_X_VXT
:
353 case FFEBLD_constHEX_Z_MIL
:
354 case FFEBLD_constHEX_Z_VXT
:
355 return ffetarget_iszero_typeless (ffebld_constant_typeless (c
));
362 /* ffebld_constant_new_character1 -- Return character1 constant object from token
366 #if FFETARGET_okCHARACTER1
368 ffebld_constant_new_character1 (ffelexToken t
)
370 ffetargetCharacter1 val
;
372 ffetarget_character1 (&val
, t
, ffebld_constant_pool());
373 return ffebld_constant_new_character1_val (val
);
377 /* ffebld_constant_new_character1_val -- Return an character1 constant object
381 #if FFETARGET_okCHARACTER1
383 ffebld_constant_new_character1_val (ffetargetCharacter1 val
)
389 ffetarget_verify_character1 (ffebld_constant_pool(), val
);
391 for (c
= (ffebldConstant
) &ffebld_constant_character1_
;
395 malloc_verify_kp (ffebld_constant_pool(),
397 sizeof (*(c
->next
)));
398 ffetarget_verify_character1 (ffebld_constant_pool(),
399 ffebld_constant_character1 (c
->next
));
400 cmp
= ffetarget_cmp_character1 (val
,
401 ffebld_constant_character1 (c
->next
));
408 nc
= malloc_new_kp (ffebld_constant_pool(),
409 "FFEBLD_constCHARACTER1",
412 nc
->consttype
= FFEBLD_constCHARACTER1
;
413 nc
->u
.character1
= val
;
414 nc
->hook
= FFECOM_constantNULL
;
421 /* ffebld_constant_new_complex1 -- Return complex1 constant object from token
425 #if FFETARGET_okCOMPLEX1
427 ffebld_constant_new_complex1 (ffebldConstant real
,
428 ffebldConstant imaginary
)
430 ffetargetComplex1 val
;
432 val
.real
= ffebld_constant_real1 (real
);
433 val
.imaginary
= ffebld_constant_real1 (imaginary
);
434 return ffebld_constant_new_complex1_val (val
);
438 /* ffebld_constant_new_complex1_val -- Return a complex1 constant object
442 #if FFETARGET_okCOMPLEX1
444 ffebld_constant_new_complex1_val (ffetargetComplex1 val
)
450 for (c
= (ffebldConstant
) &ffebld_constant_complex1_
;
454 cmp
= ffetarget_cmp_real1 (val
.real
, ffebld_constant_complex1 (c
->next
).real
);
456 cmp
= ffetarget_cmp_real1 (val
.imaginary
,
457 ffebld_constant_complex1 (c
->next
).imaginary
);
464 nc
= malloc_new_kp (ffebld_constant_pool(),
465 "FFEBLD_constCOMPLEX1",
468 nc
->consttype
= FFEBLD_constCOMPLEX1
;
469 nc
->u
.complex1
= val
;
470 nc
->hook
= FFECOM_constantNULL
;
477 /* ffebld_constant_new_complex2 -- Return complex2 constant object from token
481 #if FFETARGET_okCOMPLEX2
483 ffebld_constant_new_complex2 (ffebldConstant real
,
484 ffebldConstant imaginary
)
486 ffetargetComplex2 val
;
488 val
.real
= ffebld_constant_real2 (real
);
489 val
.imaginary
= ffebld_constant_real2 (imaginary
);
490 return ffebld_constant_new_complex2_val (val
);
494 /* ffebld_constant_new_complex2_val -- Return a complex2 constant object
498 #if FFETARGET_okCOMPLEX2
500 ffebld_constant_new_complex2_val (ffetargetComplex2 val
)
506 for (c
= (ffebldConstant
) &ffebld_constant_complex2_
;
510 cmp
= ffetarget_cmp_real2 (val
.real
, ffebld_constant_complex2 (c
->next
).real
);
512 cmp
= ffetarget_cmp_real2 (val
.imaginary
,
513 ffebld_constant_complex2 (c
->next
).imaginary
);
520 nc
= malloc_new_kp (ffebld_constant_pool(),
521 "FFEBLD_constCOMPLEX2",
524 nc
->consttype
= FFEBLD_constCOMPLEX2
;
525 nc
->u
.complex2
= val
;
526 nc
->hook
= FFECOM_constantNULL
;
533 /* ffebld_constant_new_hollerith -- Return hollerith constant object from token
538 ffebld_constant_new_hollerith (ffelexToken t
)
540 ffetargetHollerith val
;
542 ffetarget_hollerith (&val
, t
, ffebld_constant_pool());
543 return ffebld_constant_new_hollerith_val (val
);
546 /* ffebld_constant_new_hollerith_val -- Return an hollerith constant object
551 ffebld_constant_new_hollerith_val (ffetargetHollerith val
)
557 for (c
= (ffebldConstant
) &ffebld_constant_hollerith_
;
561 cmp
= ffetarget_cmp_hollerith (val
, ffebld_constant_hollerith (c
->next
));
568 nc
= malloc_new_kp (ffebld_constant_pool(),
569 "FFEBLD_constHOLLERITH",
572 nc
->consttype
= FFEBLD_constHOLLERITH
;
573 nc
->u
.hollerith
= val
;
574 nc
->hook
= FFECOM_constantNULL
;
580 /* ffebld_constant_new_integer1 -- Return integer1 constant object from token
584 Parses the token as a decimal integer constant, thus it must be an
585 FFELEX_typeNUMBER. */
587 #if FFETARGET_okINTEGER1
589 ffebld_constant_new_integer1 (ffelexToken t
)
591 ffetargetInteger1 val
;
593 assert (ffelex_token_type (t
) == FFELEX_typeNUMBER
);
595 ffetarget_integer1 (&val
, t
);
596 return ffebld_constant_new_integer1_val (val
);
600 /* ffebld_constant_new_integer1_val -- Return an integer1 constant object
604 #if FFETARGET_okINTEGER1
606 ffebld_constant_new_integer1_val (ffetargetInteger1 val
)
612 for (c
= (ffebldConstant
) &ffebld_constant_integer1_
;
616 cmp
= ffetarget_cmp_integer1 (val
, ffebld_constant_integer1 (c
->next
));
623 nc
= malloc_new_kp (ffebld_constant_pool(),
624 "FFEBLD_constINTEGER1",
627 nc
->consttype
= FFEBLD_constINTEGER1
;
628 nc
->u
.integer1
= val
;
629 nc
->hook
= FFECOM_constantNULL
;
636 /* ffebld_constant_new_integer2_val -- Return an integer2 constant object
640 #if FFETARGET_okINTEGER2
642 ffebld_constant_new_integer2_val (ffetargetInteger2 val
)
648 for (c
= (ffebldConstant
) &ffebld_constant_integer2_
;
652 cmp
= ffetarget_cmp_integer2 (val
, ffebld_constant_integer2 (c
->next
));
659 nc
= malloc_new_kp (ffebld_constant_pool(),
660 "FFEBLD_constINTEGER2",
663 nc
->consttype
= FFEBLD_constINTEGER2
;
664 nc
->u
.integer2
= val
;
665 nc
->hook
= FFECOM_constantNULL
;
672 /* ffebld_constant_new_integer3_val -- Return an integer3 constant object
676 #if FFETARGET_okINTEGER3
678 ffebld_constant_new_integer3_val (ffetargetInteger3 val
)
684 for (c
= (ffebldConstant
) &ffebld_constant_integer3_
;
688 cmp
= ffetarget_cmp_integer3 (val
, ffebld_constant_integer3 (c
->next
));
695 nc
= malloc_new_kp (ffebld_constant_pool(),
696 "FFEBLD_constINTEGER3",
699 nc
->consttype
= FFEBLD_constINTEGER3
;
700 nc
->u
.integer3
= val
;
701 nc
->hook
= FFECOM_constantNULL
;
708 /* ffebld_constant_new_integer4_val -- Return an integer4 constant object
712 #if FFETARGET_okINTEGER4
714 ffebld_constant_new_integer4_val (ffetargetInteger4 val
)
720 for (c
= (ffebldConstant
) &ffebld_constant_integer4_
;
724 cmp
= ffetarget_cmp_integer4 (val
, ffebld_constant_integer4 (c
->next
));
731 nc
= malloc_new_kp (ffebld_constant_pool(),
732 "FFEBLD_constINTEGER4",
735 nc
->consttype
= FFEBLD_constINTEGER4
;
736 nc
->u
.integer4
= val
;
737 nc
->hook
= FFECOM_constantNULL
;
744 /* ffebld_constant_new_integerbinary -- Return binary constant object from token
748 Parses the token as a binary integer constant, thus it must be an
749 FFELEX_typeNUMBER. */
752 ffebld_constant_new_integerbinary (ffelexToken t
)
754 ffetargetIntegerDefault val
;
756 assert ((ffelex_token_type (t
) == FFELEX_typeNAME
)
757 || (ffelex_token_type (t
) == FFELEX_typeNUMBER
));
759 ffetarget_integerbinary (&val
, t
);
760 return ffebld_constant_new_integerdefault_val (val
);
763 /* ffebld_constant_new_integerhex -- Return hex constant object from token
767 Parses the token as a hex integer constant, thus it must be an
768 FFELEX_typeNUMBER. */
771 ffebld_constant_new_integerhex (ffelexToken t
)
773 ffetargetIntegerDefault val
;
775 assert ((ffelex_token_type (t
) == FFELEX_typeNAME
)
776 || (ffelex_token_type (t
) == FFELEX_typeNUMBER
));
778 ffetarget_integerhex (&val
, t
);
779 return ffebld_constant_new_integerdefault_val (val
);
782 /* ffebld_constant_new_integeroctal -- Return octal constant object from token
786 Parses the token as a octal integer constant, thus it must be an
787 FFELEX_typeNUMBER. */
790 ffebld_constant_new_integeroctal (ffelexToken t
)
792 ffetargetIntegerDefault val
;
794 assert ((ffelex_token_type (t
) == FFELEX_typeNAME
)
795 || (ffelex_token_type (t
) == FFELEX_typeNUMBER
));
797 ffetarget_integeroctal (&val
, t
);
798 return ffebld_constant_new_integerdefault_val (val
);
801 /* ffebld_constant_new_logical1 -- Return logical1 constant object from token
805 Parses the token as a decimal logical constant, thus it must be an
806 FFELEX_typeNUMBER. */
808 #if FFETARGET_okLOGICAL1
810 ffebld_constant_new_logical1 (bool truth
)
812 ffetargetLogical1 val
;
814 ffetarget_logical1 (&val
, truth
);
815 return ffebld_constant_new_logical1_val (val
);
819 /* ffebld_constant_new_logical1_val -- Return a logical1 constant object
823 #if FFETARGET_okLOGICAL1
825 ffebld_constant_new_logical1_val (ffetargetLogical1 val
)
831 for (c
= (ffebldConstant
) &ffebld_constant_logical1_
;
835 cmp
= ffetarget_cmp_logical1 (val
, ffebld_constant_logical1 (c
->next
));
842 nc
= malloc_new_kp (ffebld_constant_pool(),
843 "FFEBLD_constLOGICAL1",
846 nc
->consttype
= FFEBLD_constLOGICAL1
;
847 nc
->u
.logical1
= val
;
848 nc
->hook
= FFECOM_constantNULL
;
855 /* ffebld_constant_new_logical2_val -- Return a logical2 constant object
859 #if FFETARGET_okLOGICAL2
861 ffebld_constant_new_logical2_val (ffetargetLogical2 val
)
867 for (c
= (ffebldConstant
) &ffebld_constant_logical2_
;
871 cmp
= ffetarget_cmp_logical2 (val
, ffebld_constant_logical2 (c
->next
));
878 nc
= malloc_new_kp (ffebld_constant_pool(),
879 "FFEBLD_constLOGICAL2",
882 nc
->consttype
= FFEBLD_constLOGICAL2
;
883 nc
->u
.logical2
= val
;
884 nc
->hook
= FFECOM_constantNULL
;
891 /* ffebld_constant_new_logical3_val -- Return a logical3 constant object
895 #if FFETARGET_okLOGICAL3
897 ffebld_constant_new_logical3_val (ffetargetLogical3 val
)
903 for (c
= (ffebldConstant
) &ffebld_constant_logical3_
;
907 cmp
= ffetarget_cmp_logical3 (val
, ffebld_constant_logical3 (c
->next
));
914 nc
= malloc_new_kp (ffebld_constant_pool(),
915 "FFEBLD_constLOGICAL3",
918 nc
->consttype
= FFEBLD_constLOGICAL3
;
919 nc
->u
.logical3
= val
;
920 nc
->hook
= FFECOM_constantNULL
;
927 /* ffebld_constant_new_logical4_val -- Return a logical4 constant object
931 #if FFETARGET_okLOGICAL4
933 ffebld_constant_new_logical4_val (ffetargetLogical4 val
)
939 for (c
= (ffebldConstant
) &ffebld_constant_logical4_
;
943 cmp
= ffetarget_cmp_logical4 (val
, ffebld_constant_logical4 (c
->next
));
950 nc
= malloc_new_kp (ffebld_constant_pool(),
951 "FFEBLD_constLOGICAL4",
954 nc
->consttype
= FFEBLD_constLOGICAL4
;
955 nc
->u
.logical4
= val
;
956 nc
->hook
= FFECOM_constantNULL
;
963 /* ffebld_constant_new_real1 -- Return real1 constant object from token
967 #if FFETARGET_okREAL1
969 ffebld_constant_new_real1 (ffelexToken integer
, ffelexToken decimal
,
970 ffelexToken fraction
, ffelexToken exponent
, ffelexToken exponent_sign
,
971 ffelexToken exponent_digits
)
975 ffetarget_real1 (&val
,
976 integer
, decimal
, fraction
, exponent
, exponent_sign
, exponent_digits
);
977 return ffebld_constant_new_real1_val (val
);
981 /* ffebld_constant_new_real1_val -- Return an real1 constant object
985 #if FFETARGET_okREAL1
987 ffebld_constant_new_real1_val (ffetargetReal1 val
)
993 for (c
= (ffebldConstant
) &ffebld_constant_real1_
;
997 cmp
= ffetarget_cmp_real1 (val
, ffebld_constant_real1 (c
->next
));
1004 nc
= malloc_new_kp (ffebld_constant_pool(),
1005 "FFEBLD_constREAL1",
1008 nc
->consttype
= FFEBLD_constREAL1
;
1010 nc
->hook
= FFECOM_constantNULL
;
1017 /* ffebld_constant_new_real2 -- Return real2 constant object from token
1021 #if FFETARGET_okREAL2
1023 ffebld_constant_new_real2 (ffelexToken integer
, ffelexToken decimal
,
1024 ffelexToken fraction
, ffelexToken exponent
, ffelexToken exponent_sign
,
1025 ffelexToken exponent_digits
)
1029 ffetarget_real2 (&val
,
1030 integer
, decimal
, fraction
, exponent
, exponent_sign
, exponent_digits
);
1031 return ffebld_constant_new_real2_val (val
);
1035 /* ffebld_constant_new_real2_val -- Return an real2 constant object
1039 #if FFETARGET_okREAL2
1041 ffebld_constant_new_real2_val (ffetargetReal2 val
)
1047 for (c
= (ffebldConstant
) &ffebld_constant_real2_
;
1051 cmp
= ffetarget_cmp_real2 (val
, ffebld_constant_real2 (c
->next
));
1058 nc
= malloc_new_kp (ffebld_constant_pool(),
1059 "FFEBLD_constREAL2",
1062 nc
->consttype
= FFEBLD_constREAL2
;
1064 nc
->hook
= FFECOM_constantNULL
;
1071 /* ffebld_constant_new_typeless_bm -- Return typeless constant object from token
1075 Parses the token as a decimal integer constant, thus it must be an
1076 FFELEX_typeNUMBER. */
1079 ffebld_constant_new_typeless_bm (ffelexToken t
)
1081 ffetargetTypeless val
;
1083 ffetarget_binarymil (&val
, t
);
1084 return ffebld_constant_new_typeless_val (FFEBLD_constBINARY_MIL
, val
);
1087 /* ffebld_constant_new_typeless_bv -- Return typeless constant object from token
1091 Parses the token as a decimal integer constant, thus it must be an
1092 FFELEX_typeNUMBER. */
1095 ffebld_constant_new_typeless_bv (ffelexToken t
)
1097 ffetargetTypeless val
;
1099 ffetarget_binaryvxt (&val
, t
);
1100 return ffebld_constant_new_typeless_val (FFEBLD_constBINARY_VXT
, val
);
1103 /* ffebld_constant_new_typeless_hxm -- Return typeless constant object from token
1107 Parses the token as a decimal integer constant, thus it must be an
1108 FFELEX_typeNUMBER. */
1111 ffebld_constant_new_typeless_hxm (ffelexToken t
)
1113 ffetargetTypeless val
;
1115 ffetarget_hexxmil (&val
, t
);
1116 return ffebld_constant_new_typeless_val (FFEBLD_constHEX_X_MIL
, val
);
1119 /* ffebld_constant_new_typeless_hxv -- Return typeless constant object from token
1123 Parses the token as a decimal integer constant, thus it must be an
1124 FFELEX_typeNUMBER. */
1127 ffebld_constant_new_typeless_hxv (ffelexToken t
)
1129 ffetargetTypeless val
;
1131 ffetarget_hexxvxt (&val
, t
);
1132 return ffebld_constant_new_typeless_val (FFEBLD_constHEX_X_VXT
, val
);
1135 /* ffebld_constant_new_typeless_hzm -- Return typeless constant object from token
1139 Parses the token as a decimal integer constant, thus it must be an
1140 FFELEX_typeNUMBER. */
1143 ffebld_constant_new_typeless_hzm (ffelexToken t
)
1145 ffetargetTypeless val
;
1147 ffetarget_hexzmil (&val
, t
);
1148 return ffebld_constant_new_typeless_val (FFEBLD_constHEX_Z_MIL
, val
);
1151 /* ffebld_constant_new_typeless_hzv -- Return typeless constant object from token
1155 Parses the token as a decimal integer constant, thus it must be an
1156 FFELEX_typeNUMBER. */
1159 ffebld_constant_new_typeless_hzv (ffelexToken t
)
1161 ffetargetTypeless val
;
1163 ffetarget_hexzvxt (&val
, t
);
1164 return ffebld_constant_new_typeless_val (FFEBLD_constHEX_Z_VXT
, val
);
1167 /* ffebld_constant_new_typeless_om -- Return typeless constant object from token
1171 Parses the token as a decimal integer constant, thus it must be an
1172 FFELEX_typeNUMBER. */
1175 ffebld_constant_new_typeless_om (ffelexToken t
)
1177 ffetargetTypeless val
;
1179 ffetarget_octalmil (&val
, t
);
1180 return ffebld_constant_new_typeless_val (FFEBLD_constOCTAL_MIL
, val
);
1183 /* ffebld_constant_new_typeless_ov -- Return typeless constant object from token
1187 Parses the token as a decimal integer constant, thus it must be an
1188 FFELEX_typeNUMBER. */
1191 ffebld_constant_new_typeless_ov (ffelexToken t
)
1193 ffetargetTypeless val
;
1195 ffetarget_octalvxt (&val
, t
);
1196 return ffebld_constant_new_typeless_val (FFEBLD_constOCTAL_VXT
, val
);
1199 /* ffebld_constant_new_typeless_val -- Return a typeless constant object
1204 ffebld_constant_new_typeless_val (ffebldConst type
, ffetargetTypeless val
)
1210 for (c
= (ffebldConstant
) &ffebld_constant_typeless_
[type
1211 - FFEBLD_constTYPELESS_FIRST
];
1215 cmp
= ffetarget_cmp_typeless (val
, ffebld_constant_typeless (c
->next
));
1222 nc
= malloc_new_kp (ffebld_constant_pool(),
1223 "FFEBLD_constTYPELESS",
1226 nc
->consttype
= type
;
1227 nc
->u
.typeless
= val
;
1228 nc
->hook
= FFECOM_constantNULL
;
1234 /* ffebld_constantarray_get -- Get a value from an array of constants
1239 ffebld_constantarray_get (ffebldConstantArray array
, ffeinfoBasictype bt
,
1240 ffeinfoKindtype kt
, ffetargetOffset offset
)
1242 ffebldConstantUnion u
;
1246 case FFEINFO_basictypeINTEGER
:
1249 #if FFETARGET_okINTEGER1
1250 case FFEINFO_kindtypeINTEGER1
:
1251 u
.integer1
= *(array
.integer1
+ offset
);
1255 #if FFETARGET_okINTEGER2
1256 case FFEINFO_kindtypeINTEGER2
:
1257 u
.integer2
= *(array
.integer2
+ offset
);
1261 #if FFETARGET_okINTEGER3
1262 case FFEINFO_kindtypeINTEGER3
:
1263 u
.integer3
= *(array
.integer3
+ offset
);
1267 #if FFETARGET_okINTEGER4
1268 case FFEINFO_kindtypeINTEGER4
:
1269 u
.integer4
= *(array
.integer4
+ offset
);
1274 assert ("bad INTEGER kindtype" == NULL
);
1279 case FFEINFO_basictypeLOGICAL
:
1282 #if FFETARGET_okLOGICAL1
1283 case FFEINFO_kindtypeLOGICAL1
:
1284 u
.logical1
= *(array
.logical1
+ offset
);
1288 #if FFETARGET_okLOGICAL2
1289 case FFEINFO_kindtypeLOGICAL2
:
1290 u
.logical2
= *(array
.logical2
+ offset
);
1294 #if FFETARGET_okLOGICAL3
1295 case FFEINFO_kindtypeLOGICAL3
:
1296 u
.logical3
= *(array
.logical3
+ offset
);
1300 #if FFETARGET_okLOGICAL4
1301 case FFEINFO_kindtypeLOGICAL4
:
1302 u
.logical4
= *(array
.logical4
+ offset
);
1307 assert ("bad LOGICAL kindtype" == NULL
);
1312 case FFEINFO_basictypeREAL
:
1315 #if FFETARGET_okREAL1
1316 case FFEINFO_kindtypeREAL1
:
1317 u
.real1
= *(array
.real1
+ offset
);
1321 #if FFETARGET_okREAL2
1322 case FFEINFO_kindtypeREAL2
:
1323 u
.real2
= *(array
.real2
+ offset
);
1327 #if FFETARGET_okREAL3
1328 case FFEINFO_kindtypeREAL3
:
1329 u
.real3
= *(array
.real3
+ offset
);
1334 assert ("bad REAL kindtype" == NULL
);
1339 case FFEINFO_basictypeCOMPLEX
:
1342 #if FFETARGET_okCOMPLEX1
1343 case FFEINFO_kindtypeREAL1
:
1344 u
.complex1
= *(array
.complex1
+ offset
);
1348 #if FFETARGET_okCOMPLEX2
1349 case FFEINFO_kindtypeREAL2
:
1350 u
.complex2
= *(array
.complex2
+ offset
);
1354 #if FFETARGET_okCOMPLEX3
1355 case FFEINFO_kindtypeREAL3
:
1356 u
.complex3
= *(array
.complex3
+ offset
);
1361 assert ("bad COMPLEX kindtype" == NULL
);
1366 case FFEINFO_basictypeCHARACTER
:
1369 #if FFETARGET_okCHARACTER1
1370 case FFEINFO_kindtypeCHARACTER1
:
1371 u
.character1
.length
= 1;
1372 u
.character1
.text
= array
.character1
+ offset
;
1377 assert ("bad CHARACTER kindtype" == NULL
);
1383 assert ("bad basictype" == NULL
);
1390 /* ffebld_constantarray_new -- Make an array of constants
1395 ffebld_constantarray_new (ffeinfoBasictype bt
,
1396 ffeinfoKindtype kt
, ffetargetOffset size
)
1398 ffebldConstantArray ptr
;
1402 case FFEINFO_basictypeINTEGER
:
1405 #if FFETARGET_okINTEGER1
1406 case FFEINFO_kindtypeINTEGER1
:
1407 ptr
.integer1
= malloc_new_zkp (ffebld_constant_pool(),
1408 "ffebldConstantArray",
1409 size
*= sizeof (ffetargetInteger1
),
1414 #if FFETARGET_okINTEGER2
1415 case FFEINFO_kindtypeINTEGER2
:
1416 ptr
.integer2
= malloc_new_zkp (ffebld_constant_pool(),
1417 "ffebldConstantArray",
1418 size
*= sizeof (ffetargetInteger2
),
1423 #if FFETARGET_okINTEGER3
1424 case FFEINFO_kindtypeINTEGER3
:
1425 ptr
.integer3
= malloc_new_zkp (ffebld_constant_pool(),
1426 "ffebldConstantArray",
1427 size
*= sizeof (ffetargetInteger3
),
1432 #if FFETARGET_okINTEGER4
1433 case FFEINFO_kindtypeINTEGER4
:
1434 ptr
.integer4
= malloc_new_zkp (ffebld_constant_pool(),
1435 "ffebldConstantArray",
1436 size
*= sizeof (ffetargetInteger4
),
1442 assert ("bad INTEGER kindtype" == NULL
);
1447 case FFEINFO_basictypeLOGICAL
:
1450 #if FFETARGET_okLOGICAL1
1451 case FFEINFO_kindtypeLOGICAL1
:
1452 ptr
.logical1
= malloc_new_zkp (ffebld_constant_pool(),
1453 "ffebldConstantArray",
1454 size
*= sizeof (ffetargetLogical1
),
1459 #if FFETARGET_okLOGICAL2
1460 case FFEINFO_kindtypeLOGICAL2
:
1461 ptr
.logical2
= malloc_new_zkp (ffebld_constant_pool(),
1462 "ffebldConstantArray",
1463 size
*= sizeof (ffetargetLogical2
),
1468 #if FFETARGET_okLOGICAL3
1469 case FFEINFO_kindtypeLOGICAL3
:
1470 ptr
.logical3
= malloc_new_zkp (ffebld_constant_pool(),
1471 "ffebldConstantArray",
1472 size
*= sizeof (ffetargetLogical3
),
1477 #if FFETARGET_okLOGICAL4
1478 case FFEINFO_kindtypeLOGICAL4
:
1479 ptr
.logical4
= malloc_new_zkp (ffebld_constant_pool(),
1480 "ffebldConstantArray",
1481 size
*= sizeof (ffetargetLogical4
),
1487 assert ("bad LOGICAL kindtype" == NULL
);
1492 case FFEINFO_basictypeREAL
:
1495 #if FFETARGET_okREAL1
1496 case FFEINFO_kindtypeREAL1
:
1497 ptr
.real1
= malloc_new_zkp (ffebld_constant_pool(),
1498 "ffebldConstantArray",
1499 size
*= sizeof (ffetargetReal1
),
1504 #if FFETARGET_okREAL2
1505 case FFEINFO_kindtypeREAL2
:
1506 ptr
.real2
= malloc_new_zkp (ffebld_constant_pool(),
1507 "ffebldConstantArray",
1508 size
*= sizeof (ffetargetReal2
),
1513 #if FFETARGET_okREAL3
1514 case FFEINFO_kindtypeREAL3
:
1515 ptr
.real3
= malloc_new_zkp (ffebld_constant_pool(),
1516 "ffebldConstantArray",
1517 size
*= sizeof (ffetargetReal3
),
1523 assert ("bad REAL kindtype" == NULL
);
1528 case FFEINFO_basictypeCOMPLEX
:
1531 #if FFETARGET_okCOMPLEX1
1532 case FFEINFO_kindtypeREAL1
:
1533 ptr
.complex1
= malloc_new_zkp (ffebld_constant_pool(),
1534 "ffebldConstantArray",
1535 size
*= sizeof (ffetargetComplex1
),
1540 #if FFETARGET_okCOMPLEX2
1541 case FFEINFO_kindtypeREAL2
:
1542 ptr
.complex2
= malloc_new_zkp (ffebld_constant_pool(),
1543 "ffebldConstantArray",
1544 size
*= sizeof (ffetargetComplex2
),
1549 #if FFETARGET_okCOMPLEX3
1550 case FFEINFO_kindtypeREAL3
:
1551 ptr
.complex3
= malloc_new_zkp (ffebld_constant_pool(),
1552 "ffebldConstantArray",
1553 size
*= sizeof (ffetargetComplex3
),
1559 assert ("bad COMPLEX kindtype" == NULL
);
1564 case FFEINFO_basictypeCHARACTER
:
1567 #if FFETARGET_okCHARACTER1
1568 case FFEINFO_kindtypeCHARACTER1
:
1569 ptr
.character1
= malloc_new_zkp (ffebld_constant_pool(),
1570 "ffebldConstantArray",
1572 *= sizeof (ffetargetCharacterUnit1
),
1578 assert ("bad CHARACTER kindtype" == NULL
);
1584 assert ("bad basictype" == NULL
);
1591 /* ffebld_constantarray_preparray -- Prepare for copy between arrays
1595 Like _prepare, but the source is an array instead of a single-value
1599 ffebld_constantarray_preparray (void **aptr
, void **cptr
, size_t *size
,
1600 ffebldConstantArray array
, ffeinfoBasictype abt
, ffeinfoKindtype akt
,
1601 ffetargetOffset offset
, ffebldConstantArray source_array
,
1602 ffeinfoBasictype cbt
, ffeinfoKindtype ckt
)
1606 case FFEINFO_basictypeINTEGER
:
1609 #if FFETARGET_okINTEGER1
1610 case FFEINFO_kindtypeINTEGER1
:
1611 *aptr
= array
.integer1
+ offset
;
1615 #if FFETARGET_okINTEGER2
1616 case FFEINFO_kindtypeINTEGER2
:
1617 *aptr
= array
.integer2
+ offset
;
1621 #if FFETARGET_okINTEGER3
1622 case FFEINFO_kindtypeINTEGER3
:
1623 *aptr
= array
.integer3
+ offset
;
1627 #if FFETARGET_okINTEGER4
1628 case FFEINFO_kindtypeINTEGER4
:
1629 *aptr
= array
.integer4
+ offset
;
1634 assert ("bad INTEGER akindtype" == NULL
);
1639 case FFEINFO_basictypeLOGICAL
:
1642 #if FFETARGET_okLOGICAL1
1643 case FFEINFO_kindtypeLOGICAL1
:
1644 *aptr
= array
.logical1
+ offset
;
1648 #if FFETARGET_okLOGICAL2
1649 case FFEINFO_kindtypeLOGICAL2
:
1650 *aptr
= array
.logical2
+ offset
;
1654 #if FFETARGET_okLOGICAL3
1655 case FFEINFO_kindtypeLOGICAL3
:
1656 *aptr
= array
.logical3
+ offset
;
1660 #if FFETARGET_okLOGICAL4
1661 case FFEINFO_kindtypeLOGICAL4
:
1662 *aptr
= array
.logical4
+ offset
;
1667 assert ("bad LOGICAL akindtype" == NULL
);
1672 case FFEINFO_basictypeREAL
:
1675 #if FFETARGET_okREAL1
1676 case FFEINFO_kindtypeREAL1
:
1677 *aptr
= array
.real1
+ offset
;
1681 #if FFETARGET_okREAL2
1682 case FFEINFO_kindtypeREAL2
:
1683 *aptr
= array
.real2
+ offset
;
1687 #if FFETARGET_okREAL3
1688 case FFEINFO_kindtypeREAL3
:
1689 *aptr
= array
.real3
+ offset
;
1694 assert ("bad REAL akindtype" == NULL
);
1699 case FFEINFO_basictypeCOMPLEX
:
1702 #if FFETARGET_okCOMPLEX1
1703 case FFEINFO_kindtypeREAL1
:
1704 *aptr
= array
.complex1
+ offset
;
1708 #if FFETARGET_okCOMPLEX2
1709 case FFEINFO_kindtypeREAL2
:
1710 *aptr
= array
.complex2
+ offset
;
1714 #if FFETARGET_okCOMPLEX3
1715 case FFEINFO_kindtypeREAL3
:
1716 *aptr
= array
.complex3
+ offset
;
1721 assert ("bad COMPLEX akindtype" == NULL
);
1726 case FFEINFO_basictypeCHARACTER
:
1729 #if FFETARGET_okCHARACTER1
1730 case FFEINFO_kindtypeCHARACTER1
:
1731 *aptr
= array
.character1
+ offset
;
1736 assert ("bad CHARACTER akindtype" == NULL
);
1742 assert ("bad abasictype" == NULL
);
1748 case FFEINFO_basictypeINTEGER
:
1751 #if FFETARGET_okINTEGER1
1752 case FFEINFO_kindtypeINTEGER1
:
1753 *cptr
= source_array
.integer1
;
1754 *size
= sizeof (*source_array
.integer1
);
1758 #if FFETARGET_okINTEGER2
1759 case FFEINFO_kindtypeINTEGER2
:
1760 *cptr
= source_array
.integer2
;
1761 *size
= sizeof (*source_array
.integer2
);
1765 #if FFETARGET_okINTEGER3
1766 case FFEINFO_kindtypeINTEGER3
:
1767 *cptr
= source_array
.integer3
;
1768 *size
= sizeof (*source_array
.integer3
);
1772 #if FFETARGET_okINTEGER4
1773 case FFEINFO_kindtypeINTEGER4
:
1774 *cptr
= source_array
.integer4
;
1775 *size
= sizeof (*source_array
.integer4
);
1780 assert ("bad INTEGER ckindtype" == NULL
);
1785 case FFEINFO_basictypeLOGICAL
:
1788 #if FFETARGET_okLOGICAL1
1789 case FFEINFO_kindtypeLOGICAL1
:
1790 *cptr
= source_array
.logical1
;
1791 *size
= sizeof (*source_array
.logical1
);
1795 #if FFETARGET_okLOGICAL2
1796 case FFEINFO_kindtypeLOGICAL2
:
1797 *cptr
= source_array
.logical2
;
1798 *size
= sizeof (*source_array
.logical2
);
1802 #if FFETARGET_okLOGICAL3
1803 case FFEINFO_kindtypeLOGICAL3
:
1804 *cptr
= source_array
.logical3
;
1805 *size
= sizeof (*source_array
.logical3
);
1809 #if FFETARGET_okLOGICAL4
1810 case FFEINFO_kindtypeLOGICAL4
:
1811 *cptr
= source_array
.logical4
;
1812 *size
= sizeof (*source_array
.logical4
);
1817 assert ("bad LOGICAL ckindtype" == NULL
);
1822 case FFEINFO_basictypeREAL
:
1825 #if FFETARGET_okREAL1
1826 case FFEINFO_kindtypeREAL1
:
1827 *cptr
= source_array
.real1
;
1828 *size
= sizeof (*source_array
.real1
);
1832 #if FFETARGET_okREAL2
1833 case FFEINFO_kindtypeREAL2
:
1834 *cptr
= source_array
.real2
;
1835 *size
= sizeof (*source_array
.real2
);
1839 #if FFETARGET_okREAL3
1840 case FFEINFO_kindtypeREAL3
:
1841 *cptr
= source_array
.real3
;
1842 *size
= sizeof (*source_array
.real3
);
1847 assert ("bad REAL ckindtype" == NULL
);
1852 case FFEINFO_basictypeCOMPLEX
:
1855 #if FFETARGET_okCOMPLEX1
1856 case FFEINFO_kindtypeREAL1
:
1857 *cptr
= source_array
.complex1
;
1858 *size
= sizeof (*source_array
.complex1
);
1862 #if FFETARGET_okCOMPLEX2
1863 case FFEINFO_kindtypeREAL2
:
1864 *cptr
= source_array
.complex2
;
1865 *size
= sizeof (*source_array
.complex2
);
1869 #if FFETARGET_okCOMPLEX3
1870 case FFEINFO_kindtypeREAL3
:
1871 *cptr
= source_array
.complex3
;
1872 *size
= sizeof (*source_array
.complex3
);
1877 assert ("bad COMPLEX ckindtype" == NULL
);
1882 case FFEINFO_basictypeCHARACTER
:
1885 #if FFETARGET_okCHARACTER1
1886 case FFEINFO_kindtypeCHARACTER1
:
1887 *cptr
= source_array
.character1
;
1888 *size
= sizeof (*source_array
.character1
);
1893 assert ("bad CHARACTER ckindtype" == NULL
);
1899 assert ("bad cbasictype" == NULL
);
1904 /* ffebld_constantarray_prepare -- Prepare for copy between value and array
1908 Like _put, but just returns the pointers to the beginnings of the
1909 array and the constant and returns the size (the amount of info to
1910 copy). The idea is that the caller can use memcpy to accomplish the
1911 same thing as _put (though slower), or the caller can use a different
1912 function that swaps bytes, words, etc for a different target machine.
1913 Also, the type of the array may be different from the type of the
1914 constant; the array type is used to determine the meaning (scale) of
1915 the offset field (to calculate the array pointer), the constant type is
1916 used to determine the constant pointer and the size (amount of info to
1920 ffebld_constantarray_prepare (void **aptr
, void **cptr
, size_t *size
,
1921 ffebldConstantArray array
, ffeinfoBasictype abt
, ffeinfoKindtype akt
,
1922 ffetargetOffset offset
, ffebldConstantUnion
*constant
,
1923 ffeinfoBasictype cbt
, ffeinfoKindtype ckt
)
1927 case FFEINFO_basictypeINTEGER
:
1930 #if FFETARGET_okINTEGER1
1931 case FFEINFO_kindtypeINTEGER1
:
1932 *aptr
= array
.integer1
+ offset
;
1936 #if FFETARGET_okINTEGER2
1937 case FFEINFO_kindtypeINTEGER2
:
1938 *aptr
= array
.integer2
+ offset
;
1942 #if FFETARGET_okINTEGER3
1943 case FFEINFO_kindtypeINTEGER3
:
1944 *aptr
= array
.integer3
+ offset
;
1948 #if FFETARGET_okINTEGER4
1949 case FFEINFO_kindtypeINTEGER4
:
1950 *aptr
= array
.integer4
+ offset
;
1955 assert ("bad INTEGER akindtype" == NULL
);
1960 case FFEINFO_basictypeLOGICAL
:
1963 #if FFETARGET_okLOGICAL1
1964 case FFEINFO_kindtypeLOGICAL1
:
1965 *aptr
= array
.logical1
+ offset
;
1969 #if FFETARGET_okLOGICAL2
1970 case FFEINFO_kindtypeLOGICAL2
:
1971 *aptr
= array
.logical2
+ offset
;
1975 #if FFETARGET_okLOGICAL3
1976 case FFEINFO_kindtypeLOGICAL3
:
1977 *aptr
= array
.logical3
+ offset
;
1981 #if FFETARGET_okLOGICAL4
1982 case FFEINFO_kindtypeLOGICAL4
:
1983 *aptr
= array
.logical4
+ offset
;
1988 assert ("bad LOGICAL akindtype" == NULL
);
1993 case FFEINFO_basictypeREAL
:
1996 #if FFETARGET_okREAL1
1997 case FFEINFO_kindtypeREAL1
:
1998 *aptr
= array
.real1
+ offset
;
2002 #if FFETARGET_okREAL2
2003 case FFEINFO_kindtypeREAL2
:
2004 *aptr
= array
.real2
+ offset
;
2008 #if FFETARGET_okREAL3
2009 case FFEINFO_kindtypeREAL3
:
2010 *aptr
= array
.real3
+ offset
;
2015 assert ("bad REAL akindtype" == NULL
);
2020 case FFEINFO_basictypeCOMPLEX
:
2023 #if FFETARGET_okCOMPLEX1
2024 case FFEINFO_kindtypeREAL1
:
2025 *aptr
= array
.complex1
+ offset
;
2029 #if FFETARGET_okCOMPLEX2
2030 case FFEINFO_kindtypeREAL2
:
2031 *aptr
= array
.complex2
+ offset
;
2035 #if FFETARGET_okCOMPLEX3
2036 case FFEINFO_kindtypeREAL3
:
2037 *aptr
= array
.complex3
+ offset
;
2042 assert ("bad COMPLEX akindtype" == NULL
);
2047 case FFEINFO_basictypeCHARACTER
:
2050 #if FFETARGET_okCHARACTER1
2051 case FFEINFO_kindtypeCHARACTER1
:
2052 *aptr
= array
.character1
+ offset
;
2057 assert ("bad CHARACTER akindtype" == NULL
);
2063 assert ("bad abasictype" == NULL
);
2069 case FFEINFO_basictypeINTEGER
:
2072 #if FFETARGET_okINTEGER1
2073 case FFEINFO_kindtypeINTEGER1
:
2074 *cptr
= &constant
->integer1
;
2075 *size
= sizeof (constant
->integer1
);
2079 #if FFETARGET_okINTEGER2
2080 case FFEINFO_kindtypeINTEGER2
:
2081 *cptr
= &constant
->integer2
;
2082 *size
= sizeof (constant
->integer2
);
2086 #if FFETARGET_okINTEGER3
2087 case FFEINFO_kindtypeINTEGER3
:
2088 *cptr
= &constant
->integer3
;
2089 *size
= sizeof (constant
->integer3
);
2093 #if FFETARGET_okINTEGER4
2094 case FFEINFO_kindtypeINTEGER4
:
2095 *cptr
= &constant
->integer4
;
2096 *size
= sizeof (constant
->integer4
);
2101 assert ("bad INTEGER ckindtype" == NULL
);
2106 case FFEINFO_basictypeLOGICAL
:
2109 #if FFETARGET_okLOGICAL1
2110 case FFEINFO_kindtypeLOGICAL1
:
2111 *cptr
= &constant
->logical1
;
2112 *size
= sizeof (constant
->logical1
);
2116 #if FFETARGET_okLOGICAL2
2117 case FFEINFO_kindtypeLOGICAL2
:
2118 *cptr
= &constant
->logical2
;
2119 *size
= sizeof (constant
->logical2
);
2123 #if FFETARGET_okLOGICAL3
2124 case FFEINFO_kindtypeLOGICAL3
:
2125 *cptr
= &constant
->logical3
;
2126 *size
= sizeof (constant
->logical3
);
2130 #if FFETARGET_okLOGICAL4
2131 case FFEINFO_kindtypeLOGICAL4
:
2132 *cptr
= &constant
->logical4
;
2133 *size
= sizeof (constant
->logical4
);
2138 assert ("bad LOGICAL ckindtype" == NULL
);
2143 case FFEINFO_basictypeREAL
:
2146 #if FFETARGET_okREAL1
2147 case FFEINFO_kindtypeREAL1
:
2148 *cptr
= &constant
->real1
;
2149 *size
= sizeof (constant
->real1
);
2153 #if FFETARGET_okREAL2
2154 case FFEINFO_kindtypeREAL2
:
2155 *cptr
= &constant
->real2
;
2156 *size
= sizeof (constant
->real2
);
2160 #if FFETARGET_okREAL3
2161 case FFEINFO_kindtypeREAL3
:
2162 *cptr
= &constant
->real3
;
2163 *size
= sizeof (constant
->real3
);
2168 assert ("bad REAL ckindtype" == NULL
);
2173 case FFEINFO_basictypeCOMPLEX
:
2176 #if FFETARGET_okCOMPLEX1
2177 case FFEINFO_kindtypeREAL1
:
2178 *cptr
= &constant
->complex1
;
2179 *size
= sizeof (constant
->complex1
);
2183 #if FFETARGET_okCOMPLEX2
2184 case FFEINFO_kindtypeREAL2
:
2185 *cptr
= &constant
->complex2
;
2186 *size
= sizeof (constant
->complex2
);
2190 #if FFETARGET_okCOMPLEX3
2191 case FFEINFO_kindtypeREAL3
:
2192 *cptr
= &constant
->complex3
;
2193 *size
= sizeof (constant
->complex3
);
2198 assert ("bad COMPLEX ckindtype" == NULL
);
2203 case FFEINFO_basictypeCHARACTER
:
2206 #if FFETARGET_okCHARACTER1
2207 case FFEINFO_kindtypeCHARACTER1
:
2208 *cptr
= ffetarget_text_character1 (constant
->character1
);
2209 *size
= ffetarget_length_character1 (constant
->character1
);
2214 assert ("bad CHARACTER ckindtype" == NULL
);
2220 assert ("bad cbasictype" == NULL
);
2225 /* ffebld_constantarray_put -- Put a value into an array of constants
2230 ffebld_constantarray_put (ffebldConstantArray array
, ffeinfoBasictype bt
,
2231 ffeinfoKindtype kt
, ffetargetOffset offset
, ffebldConstantUnion constant
)
2235 case FFEINFO_basictypeINTEGER
:
2238 #if FFETARGET_okINTEGER1
2239 case FFEINFO_kindtypeINTEGER1
:
2240 *(array
.integer1
+ offset
) = constant
.integer1
;
2244 #if FFETARGET_okINTEGER2
2245 case FFEINFO_kindtypeINTEGER2
:
2246 *(array
.integer2
+ offset
) = constant
.integer2
;
2250 #if FFETARGET_okINTEGER3
2251 case FFEINFO_kindtypeINTEGER3
:
2252 *(array
.integer3
+ offset
) = constant
.integer3
;
2256 #if FFETARGET_okINTEGER4
2257 case FFEINFO_kindtypeINTEGER4
:
2258 *(array
.integer4
+ offset
) = constant
.integer4
;
2263 assert ("bad INTEGER kindtype" == NULL
);
2268 case FFEINFO_basictypeLOGICAL
:
2271 #if FFETARGET_okLOGICAL1
2272 case FFEINFO_kindtypeLOGICAL1
:
2273 *(array
.logical1
+ offset
) = constant
.logical1
;
2277 #if FFETARGET_okLOGICAL2
2278 case FFEINFO_kindtypeLOGICAL2
:
2279 *(array
.logical2
+ offset
) = constant
.logical2
;
2283 #if FFETARGET_okLOGICAL3
2284 case FFEINFO_kindtypeLOGICAL3
:
2285 *(array
.logical3
+ offset
) = constant
.logical3
;
2289 #if FFETARGET_okLOGICAL4
2290 case FFEINFO_kindtypeLOGICAL4
:
2291 *(array
.logical4
+ offset
) = constant
.logical4
;
2296 assert ("bad LOGICAL kindtype" == NULL
);
2301 case FFEINFO_basictypeREAL
:
2304 #if FFETARGET_okREAL1
2305 case FFEINFO_kindtypeREAL1
:
2306 *(array
.real1
+ offset
) = constant
.real1
;
2310 #if FFETARGET_okREAL2
2311 case FFEINFO_kindtypeREAL2
:
2312 *(array
.real2
+ offset
) = constant
.real2
;
2316 #if FFETARGET_okREAL3
2317 case FFEINFO_kindtypeREAL3
:
2318 *(array
.real3
+ offset
) = constant
.real3
;
2323 assert ("bad REAL kindtype" == NULL
);
2328 case FFEINFO_basictypeCOMPLEX
:
2331 #if FFETARGET_okCOMPLEX1
2332 case FFEINFO_kindtypeREAL1
:
2333 *(array
.complex1
+ offset
) = constant
.complex1
;
2337 #if FFETARGET_okCOMPLEX2
2338 case FFEINFO_kindtypeREAL2
:
2339 *(array
.complex2
+ offset
) = constant
.complex2
;
2343 #if FFETARGET_okCOMPLEX3
2344 case FFEINFO_kindtypeREAL3
:
2345 *(array
.complex3
+ offset
) = constant
.complex3
;
2350 assert ("bad COMPLEX kindtype" == NULL
);
2355 case FFEINFO_basictypeCHARACTER
:
2358 #if FFETARGET_okCHARACTER1
2359 case FFEINFO_kindtypeCHARACTER1
:
2360 memcpy (array
.character1
+ offset
,
2361 ffetarget_text_character1 (constant
.character1
),
2362 ffetarget_length_character1 (constant
.character1
));
2367 assert ("bad CHARACTER kindtype" == NULL
);
2373 assert ("bad basictype" == NULL
);
2378 /* ffebld_init_0 -- Initialize the module
2383 ffebld_init_0 (void)
2385 assert (FFEBLD_op
== ARRAY_SIZE (ffebld_op_string_
));
2386 assert (FFEBLD_op
== ARRAY_SIZE (ffebld_arity_op_
));
2389 /* ffebld_init_1 -- Initialize the module for a file
2394 ffebld_init_1 (void)
2396 #if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstFILE_
2399 #if FFETARGET_okCHARACTER1
2400 ffebld_constant_character1_
= NULL
;
2402 #if FFETARGET_okCOMPLEX1
2403 ffebld_constant_complex1_
= NULL
;
2405 #if FFETARGET_okCOMPLEX2
2406 ffebld_constant_complex2_
= NULL
;
2408 #if FFETARGET_okCOMPLEX3
2409 ffebld_constant_complex3_
= NULL
;
2411 #if FFETARGET_okINTEGER1
2412 ffebld_constant_integer1_
= NULL
;
2414 #if FFETARGET_okINTEGER2
2415 ffebld_constant_integer2_
= NULL
;
2417 #if FFETARGET_okINTEGER3
2418 ffebld_constant_integer3_
= NULL
;
2420 #if FFETARGET_okINTEGER4
2421 ffebld_constant_integer4_
= NULL
;
2423 #if FFETARGET_okLOGICAL1
2424 ffebld_constant_logical1_
= NULL
;
2426 #if FFETARGET_okLOGICAL2
2427 ffebld_constant_logical2_
= NULL
;
2429 #if FFETARGET_okLOGICAL3
2430 ffebld_constant_logical3_
= NULL
;
2432 #if FFETARGET_okLOGICAL4
2433 ffebld_constant_logical4_
= NULL
;
2435 #if FFETARGET_okREAL1
2436 ffebld_constant_real1_
= NULL
;
2438 #if FFETARGET_okREAL2
2439 ffebld_constant_real2_
= NULL
;
2441 #if FFETARGET_okREAL3
2442 ffebld_constant_real3_
= NULL
;
2444 ffebld_constant_hollerith_
= NULL
;
2445 for (i
= FFEBLD_constTYPELESS_FIRST
; i
<= FFEBLD_constTYPELESS_LAST
; ++i
)
2446 ffebld_constant_typeless_
[i
- FFEBLD_constTYPELESS_FIRST
] = NULL
;
2450 /* ffebld_init_2 -- Initialize the module
2455 ffebld_init_2 (void)
2457 #if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstPROGUNIT_
2461 ffebld_pool_stack_
.next
= NULL
;
2462 ffebld_pool_stack_
.pool
= ffe_pool_program_unit ();
2463 #if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstPROGUNIT_
2464 #if FFETARGET_okCHARACTER1
2465 ffebld_constant_character1_
= NULL
;
2467 #if FFETARGET_okCOMPLEX1
2468 ffebld_constant_complex1_
= NULL
;
2470 #if FFETARGET_okCOMPLEX2
2471 ffebld_constant_complex2_
= NULL
;
2473 #if FFETARGET_okCOMPLEX3
2474 ffebld_constant_complex3_
= NULL
;
2476 #if FFETARGET_okINTEGER1
2477 ffebld_constant_integer1_
= NULL
;
2479 #if FFETARGET_okINTEGER2
2480 ffebld_constant_integer2_
= NULL
;
2482 #if FFETARGET_okINTEGER3
2483 ffebld_constant_integer3_
= NULL
;
2485 #if FFETARGET_okINTEGER4
2486 ffebld_constant_integer4_
= NULL
;
2488 #if FFETARGET_okLOGICAL1
2489 ffebld_constant_logical1_
= NULL
;
2491 #if FFETARGET_okLOGICAL2
2492 ffebld_constant_logical2_
= NULL
;
2494 #if FFETARGET_okLOGICAL3
2495 ffebld_constant_logical3_
= NULL
;
2497 #if FFETARGET_okLOGICAL4
2498 ffebld_constant_logical4_
= NULL
;
2500 #if FFETARGET_okREAL1
2501 ffebld_constant_real1_
= NULL
;
2503 #if FFETARGET_okREAL2
2504 ffebld_constant_real2_
= NULL
;
2506 #if FFETARGET_okREAL3
2507 ffebld_constant_real3_
= NULL
;
2509 ffebld_constant_hollerith_
= NULL
;
2510 for (i
= FFEBLD_constTYPELESS_FIRST
; i
<= FFEBLD_constTYPELESS_LAST
; ++i
)
2511 ffebld_constant_typeless_
[i
- FFEBLD_constTYPELESS_FIRST
] = NULL
;
2515 /* ffebld_list_length -- Return # of opITEMs in list
2517 ffebld list; // Must be NULL or opITEM
2518 ffebldListLength length;
2519 length = ffebld_list_length(list);
2521 Returns 0 if list is NULL, 1 if it's ffebld_trail is NULL, and so on. */
2524 ffebld_list_length (ffebld list
)
2526 ffebldListLength length
;
2528 for (length
= 0; list
!= NULL
; ++length
, list
= ffebld_trail (list
))
2534 /* ffebld_new_accter -- Create an ffebld object that is an array
2537 ffebldConstantArray a;
2539 x = ffebld_new_accter(a,b); */
2542 ffebld_new_accter (ffebldConstantArray a
, ffebit b
)
2547 x
->op
= FFEBLD_opACCTER
;
2548 x
->u
.accter
.array
= a
;
2549 x
->u
.accter
.bits
= b
;
2550 x
->u
.accter
.pad
= 0;
2554 /* ffebld_new_arrter -- Create an ffebld object that is an array
2557 ffebldConstantArray a;
2558 ffetargetOffset size;
2559 x = ffebld_new_arrter(a,size); */
2562 ffebld_new_arrter (ffebldConstantArray a
, ffetargetOffset size
)
2567 x
->op
= FFEBLD_opARRTER
;
2568 x
->u
.arrter
.array
= a
;
2569 x
->u
.arrter
.size
= size
;
2570 x
->u
.arrter
.pad
= 0;
2574 /* ffebld_new_conter_with_orig -- Create an ffebld object that is a constant
2578 x = ffebld_new_conter_with_orig(c,NULL); */
2581 ffebld_new_conter_with_orig (ffebldConstant c
, ffebld o
)
2586 x
->op
= FFEBLD_opCONTER
;
2587 x
->u
.conter
.expr
= c
;
2588 x
->u
.conter
.orig
= o
;
2589 x
->u
.conter
.pad
= 0;
2593 /* ffebld_new_item -- Create an ffebld item object
2596 x = ffebld_new_item(y,z); */
2599 ffebld_new_item (ffebld head
, ffebld trail
)
2604 x
->op
= FFEBLD_opITEM
;
2605 x
->u
.item
.head
= head
;
2606 x
->u
.item
.trail
= trail
;
2610 /* ffebld_new_labter -- Create an ffebld object that is a label
2614 x = ffebld_new_labter(c); */
2617 ffebld_new_labter (ffelab l
)
2622 x
->op
= FFEBLD_opLABTER
;
2627 /* ffebld_new_labtok -- Create object that is a label's NUMBER token
2631 x = ffebld_new_labter(c);
2633 Like the other ffebld_new_ functions, the
2634 supplied argument is stored exactly as is: ffelex_token_use is NOT
2635 called, so the token is "consumed", if one is indeed supplied (it may
2639 ffebld_new_labtok (ffelexToken t
)
2644 x
->op
= FFEBLD_opLABTOK
;
2649 /* ffebld_new_none -- Create an ffebld object with no arguments
2652 x = ffebld_new_none(FFEBLD_opWHATEVER); */
2655 ffebld_new_none (ffebldOp o
)
2664 /* ffebld_new_one -- Create an ffebld object with one argument
2667 x = ffebld_new_one(FFEBLD_opWHATEVER,y); */
2670 ffebld_new_one (ffebldOp o
, ffebld left
)
2676 x
->u
.nonter
.left
= left
;
2677 x
->u
.nonter
.hook
= FFECOM_nonterNULL
;
2681 /* ffebld_new_symter -- Create an ffebld object that is a symbol
2685 ffeintrinGen gen; // Generic intrinsic id, if any
2686 ffeintrinSpec spec; // Specific intrinsic id, if any
2687 ffeintrinImp imp; // Implementation intrinsic id, if any
2688 x = ffebld_new_symter (s, gen, spec, imp); */
2691 ffebld_new_symter (ffesymbol s
, ffeintrinGen gen
, ffeintrinSpec spec
,
2697 x
->op
= FFEBLD_opSYMTER
;
2698 x
->u
.symter
.symbol
= s
;
2699 x
->u
.symter
.generic
= gen
;
2700 x
->u
.symter
.specific
= spec
;
2701 x
->u
.symter
.implementation
= imp
;
2702 x
->u
.symter
.do_iter
= FALSE
;
2706 /* ffebld_new_two -- Create an ffebld object with two arguments
2709 x = ffebld_new_two(FFEBLD_opWHATEVER,y,z); */
2712 ffebld_new_two (ffebldOp o
, ffebld left
, ffebld right
)
2718 x
->u
.nonter
.left
= left
;
2719 x
->u
.nonter
.right
= right
;
2720 x
->u
.nonter
.hook
= FFECOM_nonterNULL
;
2724 /* ffebld_pool_pop -- Pop ffebld's pool stack
2726 ffebld_pool_pop(); */
2729 ffebld_pool_pop (void)
2731 ffebldPoolstack_ ps
;
2733 assert (ffebld_pool_stack_
.next
!= NULL
);
2734 ps
= ffebld_pool_stack_
.next
;
2735 ffebld_pool_stack_
.next
= ps
->next
;
2736 ffebld_pool_stack_
.pool
= ps
->pool
;
2737 malloc_kill_ks (malloc_pool_image (), ps
, sizeof (*ps
));
2740 /* ffebld_pool_push -- Push ffebld's pool stack
2742 ffebld_pool_push(); */
2745 ffebld_pool_push (mallocPool pool
)
2747 ffebldPoolstack_ ps
;
2749 ps
= malloc_new_ks (malloc_pool_image (), "Pool stack", sizeof (*ps
));
2750 ps
->next
= ffebld_pool_stack_
.next
;
2751 ps
->pool
= ffebld_pool_stack_
.pool
;
2752 ffebld_pool_stack_
.next
= ps
;
2753 ffebld_pool_stack_
.pool
= pool
;
2756 /* ffebld_op_string -- Return short string describing op
2759 ffebld_op_string(o);
2761 Returns a short string (uppercase) containing the name of the op. */
2764 ffebld_op_string (ffebldOp o
)
2766 if (o
>= ARRAY_SIZE (ffebld_op_string_
))
2768 return ffebld_op_string_
[o
];
2771 /* ffebld_size_max -- Return maximum possible size of CHARACTER-type expr
2773 ffetargetCharacterSize sz;
2775 sz = ffebld_size_max (b);
2777 Like ffebld_size_known, but if that would return NONE and the expression
2778 is opSUBSTR, opCONVERT, opPAREN, or opCONCATENATE, returns ffebld_size_max
2779 of the subexpression(s). */
2781 ffetargetCharacterSize
2782 ffebld_size_max (ffebld b
)
2784 ffetargetCharacterSize sz
;
2786 recurse
: /* :::::::::::::::::::: */
2788 sz
= ffebld_size_known (b
);
2790 if (sz
!= FFETARGET_charactersizeNONE
)
2793 switch (ffebld_op (b
))
2795 case FFEBLD_opSUBSTR
:
2796 case FFEBLD_opCONVERT
:
2797 case FFEBLD_opPAREN
:
2798 b
= ffebld_left (b
);
2799 goto recurse
; /* :::::::::::::::::::: */
2801 case FFEBLD_opCONCATENATE
:
2802 sz
= ffebld_size_max (ffebld_left (b
))
2803 + ffebld_size_max (ffebld_right (b
));