1 /* bld.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 2003, 2004 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 P = ffebld_constant_character1_;
393 /* make this node the root */
394 nc = malloc_new_kp (ffebld_constant_pool(),
395 "FFEBLD_constCHARACTER1",
397 nc->consttype = FFEBLD_constCHARACTER1;
398 nc->u.character1 = val;
399 nc->hook = FFECOM_constantNULL;
402 ffebld_constant_character1_ = nc;
409 cmp = ffetarget_cmp_character1 (val, ffebld_constant_character1 (P));
418 nc = malloc_new_kp (ffebld_constant_pool(),
419 "FFEBLD_constCHARACTER1",
421 nc->consttype = FFEBLD_constCHARACTER1;
422 nc->u.character1 = val;
423 nc->hook = FFECOM_constantNULL;
435 /* ffebld_constant_new_complex1 -- Return complex1 constant object from token
439 #if FFETARGET_okCOMPLEX1
441 ffebld_constant_new_complex1 (ffebldConstant real,
442 ffebldConstant imaginary)
444 ffetargetComplex1 val;
446 val.real = ffebld_constant_real1 (real);
447 val.imaginary = ffebld_constant_real1 (imaginary);
448 return ffebld_constant_new_complex1_val (val);
452 /* ffebld_constant_new_complex1_val -- Return a complex1 constant object
456 #if FFETARGET_okCOMPLEX1
458 ffebld_constant_new_complex1_val (ffetargetComplex1 val)
464 P = ffebld_constant_complex1_;
468 /* make this node the root */
469 nc = malloc_new_kp (ffebld_constant_pool(),
470 "FFEBLD_constCOMPLEX1",
472 nc->consttype = FFEBLD_constCOMPLEX1;
473 nc->u.complex1 = val;
474 nc->hook = FFECOM_constantNULL;
477 ffebld_constant_complex1_ = nc;
484 cmp = ffetarget_cmp_real1 (val.real,
485 ffebld_constant_complex1 (P).real);
487 cmp = ffetarget_cmp_real1 (val.imaginary,
488 ffebld_constant_complex1 (P).imaginary);
497 nc = malloc_new_kp (ffebld_constant_pool(),
498 "FFEBLD_constCOMPLEX1",
500 nc->consttype = FFEBLD_constCOMPLEX1;
501 nc->u.complex1 = val;
502 nc->hook = FFECOM_constantNULL;
514 /* ffebld_constant_new_complex2 -- Return complex2 constant object from token
518 #if FFETARGET_okCOMPLEX2
520 ffebld_constant_new_complex2 (ffebldConstant real,
521 ffebldConstant imaginary)
523 ffetargetComplex2 val;
525 val.real = ffebld_constant_real2 (real);
526 val.imaginary = ffebld_constant_real2 (imaginary);
527 return ffebld_constant_new_complex2_val (val);
531 /* ffebld_constant_new_complex2_val -- Return a complex2 constant object
535 #if FFETARGET_okCOMPLEX2
537 ffebld_constant_new_complex2_val (ffetargetComplex2 val)
543 P = ffebld_constant_complex2_;
547 /* make this node the root */
548 nc = malloc_new_kp (ffebld_constant_pool(),
549 "FFEBLD_constCOMPLEX2",
551 nc->consttype = FFEBLD_constCOMPLEX2;
552 nc->u.complex2 = val;
553 nc->hook = FFECOM_constantNULL;
556 ffebld_constant_complex2_ = nc;
563 cmp = ffetarget_cmp_real2 (val.real,
564 ffebld_constant_complex2 (P).real);
566 cmp = ffetarget_cmp_real2 (val.imaginary,
567 ffebld_constant_complex2 (P).imaginary);
576 nc = malloc_new_kp (ffebld_constant_pool(),
577 "FFEBLD_constCOMPLEX2",
579 nc->consttype = FFEBLD_constCOMPLEX2;
580 nc->u.complex2 = val;
581 nc->hook = FFECOM_constantNULL;
593 /* ffebld_constant_new_hollerith -- Return hollerith constant object from token
598 ffebld_constant_new_hollerith (ffelexToken t)
600 ffetargetHollerith val;
602 ffetarget_hollerith (&val, t, ffebld_constant_pool());
603 return ffebld_constant_new_hollerith_val (val);
606 /* ffebld_constant_new_hollerith_val -- Return an hollerith constant object
611 ffebld_constant_new_hollerith_val (ffetargetHollerith val)
617 P = ffebld_constant_hollerith_;
621 /* make this node the root */
622 nc = malloc_new_kp (ffebld_constant_pool(),
623 "FFEBLD_constHOLLERITH",
625 nc->consttype = FFEBLD_constHOLLERITH;
626 nc->u.hollerith = val;
627 nc->hook = FFECOM_constantNULL;
630 ffebld_constant_hollerith_ = nc;
637 cmp = ffetarget_cmp_hollerith (val, ffebld_constant_hollerith (P));
646 nc = malloc_new_kp (ffebld_constant_pool(),
647 "FFEBLD_constHOLLERITH",
649 nc->consttype = FFEBLD_constHOLLERITH;
650 nc->u.hollerith = val;
651 nc->hook = FFECOM_constantNULL;
662 /* ffebld_constant_new_integer1 -- Return integer1 constant object from token
666 Parses the token as a decimal integer constant, thus it must be an
667 FFELEX_typeNUMBER. */
669 #if FFETARGET_okINTEGER1
671 ffebld_constant_new_integer1 (ffelexToken t)
673 ffetargetInteger1 val;
675 assert (ffelex_token_type (t) == FFELEX_typeNUMBER);
677 ffetarget_integer1 (&val, t);
678 return ffebld_constant_new_integer1_val (val);
682 /* ffebld_constant_new_integer1_val -- Return an integer1 constant object
686 #if FFETARGET_okINTEGER1
688 ffebld_constant_new_integer1_val (ffetargetInteger1 val)
695 P = ffebld_constant_integer1_;
699 /* make this node the root */
700 nc = malloc_new_kp (ffebld_constant_pool(),
701 "FFEBLD_constINTEGER1",
703 nc->consttype = FFEBLD_constINTEGER1;
704 nc->u.integer1 = val;
705 nc->hook = FFECOM_constantNULL;
708 ffebld_constant_integer1_ = nc;
715 cmp = ffetarget_cmp_integer1 (val, ffebld_constant_integer1 (P));
724 nc = malloc_new_kp (ffebld_constant_pool(),
725 "FFEBLD_constINTEGER1",
727 nc->consttype = FFEBLD_constINTEGER1;
728 nc->u.integer1 = val;
729 nc->hook = FFECOM_constantNULL;
741 /* ffebld_constant_new_integer2_val -- Return an integer2 constant object
745 #if FFETARGET_okINTEGER2
747 ffebld_constant_new_integer2_val (ffetargetInteger2 val)
753 P = ffebld_constant_integer2_;
757 /* make this node the root */
758 nc = malloc_new_kp (ffebld_constant_pool(),
759 "FFEBLD_constINTEGER2",
761 nc->consttype = FFEBLD_constINTEGER2;
762 nc->u.integer2 = val;
763 nc->hook = FFECOM_constantNULL;
766 ffebld_constant_integer2_ = nc;
773 cmp = ffetarget_cmp_integer2 (val, ffebld_constant_integer2 (P));
782 nc = malloc_new_kp (ffebld_constant_pool(),
783 "FFEBLD_constINTEGER2",
785 nc->consttype = FFEBLD_constINTEGER2;
786 nc->u.integer2 = val;
787 nc->hook = FFECOM_constantNULL;
799 /* ffebld_constant_new_integer3_val -- Return an integer3 constant object
803 #if FFETARGET_okINTEGER3
805 ffebld_constant_new_integer3_val (ffetargetInteger3 val)
811 P = ffebld_constant_integer3_;
815 /* make this node the root */
816 nc = malloc_new_kp (ffebld_constant_pool(),
817 "FFEBLD_constINTEGER3",
819 nc->consttype = FFEBLD_constINTEGER3;
820 nc->u.integer3 = val;
821 nc->hook = FFECOM_constantNULL;
824 ffebld_constant_integer3_ = nc;
831 cmp = ffetarget_cmp_integer3 (val, ffebld_constant_integer3 (P));
840 nc = malloc_new_kp (ffebld_constant_pool(),
841 "FFEBLD_constINTEGER3",
843 nc->consttype = FFEBLD_constINTEGER3;
844 nc->u.integer3 = val;
845 nc->hook = FFECOM_constantNULL;
857 /* ffebld_constant_new_integer4_val -- Return an integer4 constant object
861 #if FFETARGET_okINTEGER4
863 ffebld_constant_new_integer4_val (ffetargetInteger4 val)
869 P = ffebld_constant_integer4_;
873 /* make this node the root */
874 nc = malloc_new_kp (ffebld_constant_pool(),
875 "FFEBLD_constINTEGER4",
877 nc->consttype = FFEBLD_constINTEGER4;
878 nc->u.integer4 = val;
879 nc->hook = FFECOM_constantNULL;
882 ffebld_constant_integer4_ = nc;
889 cmp = ffetarget_cmp_integer4 (val, ffebld_constant_integer4 (P));
898 nc = malloc_new_kp (ffebld_constant_pool(),
899 "FFEBLD_constINTEGER4",
901 nc->consttype = FFEBLD_constINTEGER4;
902 nc->u.integer4 = val;
903 nc->hook = FFECOM_constantNULL;
915 /* ffebld_constant_new_integerbinary -- Return binary constant object from token
919 Parses the token as a binary integer constant, thus it must be an
920 FFELEX_typeNUMBER. */
923 ffebld_constant_new_integerbinary (ffelexToken t)
925 ffetargetIntegerDefault val;
927 assert ((ffelex_token_type (t) == FFELEX_typeNAME)
928 || (ffelex_token_type (t) == FFELEX_typeNUMBER));
930 ffetarget_integerbinary (&val, t);
931 return ffebld_constant_new_integerdefault_val (val);
934 /* ffebld_constant_new_integerhex -- Return hex constant object from token
938 Parses the token as a hex integer constant, thus it must be an
939 FFELEX_typeNUMBER. */
942 ffebld_constant_new_integerhex (ffelexToken t)
944 ffetargetIntegerDefault val;
946 assert ((ffelex_token_type (t) == FFELEX_typeNAME)
947 || (ffelex_token_type (t) == FFELEX_typeNUMBER));
949 ffetarget_integerhex (&val, t);
950 return ffebld_constant_new_integerdefault_val (val);
953 /* ffebld_constant_new_integeroctal -- Return octal constant object from token
957 Parses the token as a octal integer constant, thus it must be an
958 FFELEX_typeNUMBER. */
961 ffebld_constant_new_integeroctal (ffelexToken t)
963 ffetargetIntegerDefault val;
965 assert ((ffelex_token_type (t) == FFELEX_typeNAME)
966 || (ffelex_token_type (t) == FFELEX_typeNUMBER));
968 ffetarget_integeroctal (&val, t);
969 return ffebld_constant_new_integerdefault_val (val);
972 /* ffebld_constant_new_logical1 -- Return logical1 constant object from token
976 Parses the token as a decimal logical constant, thus it must be an
977 FFELEX_typeNUMBER. */
979 #if FFETARGET_okLOGICAL1
981 ffebld_constant_new_logical1 (bool truth)
983 ffetargetLogical1 val;
985 ffetarget_logical1 (&val, truth);
986 return ffebld_constant_new_logical1_val (val);
990 /* ffebld_constant_new_logical1_val -- Return a logical1 constant object
994 #if FFETARGET_okLOGICAL1
996 ffebld_constant_new_logical1_val (ffetargetLogical1 val)
1002 P = ffebld_constant_logical1_;
1006 /* make this node the root */
1007 nc = malloc_new_kp (ffebld_constant_pool(),
1008 "FFEBLD_constLOGICAL1",
1010 nc->consttype = FFEBLD_constLOGICAL1;
1011 nc->u.logical1 = val;
1012 nc->hook = FFECOM_constantNULL;
1015 ffebld_constant_logical1_ = nc;
1022 cmp = ffetarget_cmp_logical1 (val, ffebld_constant_logical1 (P));
1031 nc = malloc_new_kp (ffebld_constant_pool(),
1032 "FFEBLD_constLOGICAL1",
1034 nc->consttype = FFEBLD_constLOGICAL1;
1035 nc->u.logical1 = val;
1036 nc->hook = FFECOM_constantNULL;
1048 /* ffebld_constant_new_logical2_val -- Return a logical2 constant object
1052 #if FFETARGET_okLOGICAL2
1054 ffebld_constant_new_logical2_val (ffetargetLogical2 val)
1060 P = ffebld_constant_logical2_;
1064 /* make this node the root */
1065 nc = malloc_new_kp (ffebld_constant_pool(),
1066 "FFEBLD_constLOGICAL2",
1068 nc->consttype = FFEBLD_constLOGICAL2;
1069 nc->u.logical2 = val;
1070 nc->hook = FFECOM_constantNULL;
1073 ffebld_constant_logical2_ = nc;
1080 cmp = ffetarget_cmp_logical2 (val, ffebld_constant_logical2 (P));
1089 nc = malloc_new_kp (ffebld_constant_pool(),
1090 "FFEBLD_constLOGICAL2",
1092 nc->consttype = FFEBLD_constLOGICAL2;
1093 nc->u.logical2 = val;
1094 nc->hook = FFECOM_constantNULL;
1106 /* ffebld_constant_new_logical3_val -- Return a logical3 constant object
1110 #if FFETARGET_okLOGICAL3
1112 ffebld_constant_new_logical3_val (ffetargetLogical3 val)
1118 P = ffebld_constant_logical3_;
1122 /* make this node the root */
1123 nc = malloc_new_kp (ffebld_constant_pool(),
1124 "FFEBLD_constLOGICAL3",
1126 nc->consttype = FFEBLD_constLOGICAL3;
1127 nc->u.logical3 = val;
1128 nc->hook = FFECOM_constantNULL;
1131 ffebld_constant_logical3_ = nc;
1138 cmp = ffetarget_cmp_logical3 (val, ffebld_constant_logical3 (P));
1147 nc = malloc_new_kp (ffebld_constant_pool(),
1148 "FFEBLD_constLOGICAL3",
1150 nc->consttype = FFEBLD_constLOGICAL3;
1151 nc->u.logical3 = val;
1152 nc->hook = FFECOM_constantNULL;
1164 /* ffebld_constant_new_logical4_val -- Return a logical4 constant object
1168 #if FFETARGET_okLOGICAL4
1170 ffebld_constant_new_logical4_val (ffetargetLogical4 val)
1176 P = ffebld_constant_logical4_;
1180 /* make this node the root */
1181 nc = malloc_new_kp (ffebld_constant_pool(),
1182 "FFEBLD_constLOGICAL4",
1184 nc->consttype = FFEBLD_constLOGICAL4;
1185 nc->u.logical4 = val;
1186 nc->hook = FFECOM_constantNULL;
1189 ffebld_constant_logical4_ = nc;
1196 cmp = ffetarget_cmp_logical4 (val, ffebld_constant_logical4 (P));
1205 nc = malloc_new_kp (ffebld_constant_pool(),
1206 "FFEBLD_constLOGICAL4",
1208 nc->consttype = FFEBLD_constLOGICAL4;
1209 nc->u.logical4 = val;
1210 nc->hook = FFECOM_constantNULL;
1222 /* ffebld_constant_new_real1 -- Return real1 constant object from token
1226 #if FFETARGET_okREAL1
1228 ffebld_constant_new_real1 (ffelexToken integer, ffelexToken decimal,
1229 ffelexToken fraction, ffelexToken exponent, ffelexToken exponent_sign,
1230 ffelexToken exponent_digits)
1234 ffetarget_real1 (&val,
1235 integer, decimal, fraction, exponent, exponent_sign, exponent_digits);
1236 return ffebld_constant_new_real1_val (val);
1240 /* ffebld_constant_new_real1_val -- Return an real1 constant object
1244 #if FFETARGET_okREAL1
1246 ffebld_constant_new_real1_val (ffetargetReal1 val)
1252 P = ffebld_constant_real1_;
1256 /* make this node the root */
1257 nc = malloc_new_kp (ffebld_constant_pool(),
1258 "FFEBLD_constREAL1",
1260 nc->consttype = FFEBLD_constREAL1;
1262 nc->hook = FFECOM_constantNULL;
1265 ffebld_constant_real1_ = nc;
1272 cmp = ffetarget_cmp_real1 (val, ffebld_constant_real1 (P));
1281 nc = malloc_new_kp (ffebld_constant_pool(),
1282 "FFEBLD_constREAL1",
1284 nc->consttype = FFEBLD_constREAL1;
1286 nc->hook = FFECOM_constantNULL;
1298 /* ffebld_constant_new_real2 -- Return real2 constant object from token
1302 #if FFETARGET_okREAL2
1304 ffebld_constant_new_real2 (ffelexToken integer, ffelexToken decimal,
1305 ffelexToken fraction, ffelexToken exponent, ffelexToken exponent_sign,
1306 ffelexToken exponent_digits)
1310 ffetarget_real2 (&val,
1311 integer, decimal, fraction, exponent, exponent_sign, exponent_digits);
1312 return ffebld_constant_new_real2_val (val);
1316 /* ffebld_constant_new_real2_val -- Return an real2 constant object
1320 #if FFETARGET_okREAL2
1322 ffebld_constant_new_real2_val (ffetargetReal2 val)
1328 P = ffebld_constant_real2_;
1332 /* make this node the root */
1333 nc = malloc_new_kp (ffebld_constant_pool(),
1334 "FFEBLD_constREAL2",
1336 nc->consttype = FFEBLD_constREAL1;
1338 nc->hook = FFECOM_constantNULL;
1341 ffebld_constant_real2_ = nc;
1348 cmp = ffetarget_cmp_real2 (val, ffebld_constant_real2 (P));
1357 nc = malloc_new_kp (ffebld_constant_pool(),
1358 "FFEBLD_constREAL2",
1360 nc->consttype = FFEBLD_constREAL2;
1362 nc->hook = FFECOM_constantNULL;
1374 /* ffebld_constant_new_typeless_bm -- Return typeless constant object from token
1378 Parses the token as a decimal integer constant, thus it must be an
1379 FFELEX_typeNUMBER. */
1382 ffebld_constant_new_typeless_bm (ffelexToken t)
1384 ffetargetTypeless val;
1386 ffetarget_binarymil (&val, t);
1387 return ffebld_constant_new_typeless_val (FFEBLD_constBINARY_MIL, val);
1390 /* ffebld_constant_new_typeless_bv -- Return typeless constant object from token
1394 Parses the token as a decimal integer constant, thus it must be an
1395 FFELEX_typeNUMBER. */
1398 ffebld_constant_new_typeless_bv (ffelexToken t)
1400 ffetargetTypeless val;
1402 ffetarget_binaryvxt (&val, t);
1403 return ffebld_constant_new_typeless_val (FFEBLD_constBINARY_VXT, val);
1406 /* ffebld_constant_new_typeless_hxm -- Return typeless constant object from token
1410 Parses the token as a decimal integer constant, thus it must be an
1411 FFELEX_typeNUMBER. */
1414 ffebld_constant_new_typeless_hxm (ffelexToken t)
1416 ffetargetTypeless val;
1418 ffetarget_hexxmil (&val, t);
1419 return ffebld_constant_new_typeless_val (FFEBLD_constHEX_X_MIL, val);
1422 /* ffebld_constant_new_typeless_hxv -- Return typeless constant object from token
1426 Parses the token as a decimal integer constant, thus it must be an
1427 FFELEX_typeNUMBER. */
1430 ffebld_constant_new_typeless_hxv (ffelexToken t)
1432 ffetargetTypeless val;
1434 ffetarget_hexxvxt (&val, t);
1435 return ffebld_constant_new_typeless_val (FFEBLD_constHEX_X_VXT, val);
1438 /* ffebld_constant_new_typeless_hzm -- Return typeless constant object from token
1442 Parses the token as a decimal integer constant, thus it must be an
1443 FFELEX_typeNUMBER. */
1446 ffebld_constant_new_typeless_hzm (ffelexToken t)
1448 ffetargetTypeless val;
1450 ffetarget_hexzmil (&val, t);
1451 return ffebld_constant_new_typeless_val (FFEBLD_constHEX_Z_MIL, val);
1454 /* ffebld_constant_new_typeless_hzv -- Return typeless constant object from token
1458 Parses the token as a decimal integer constant, thus it must be an
1459 FFELEX_typeNUMBER. */
1462 ffebld_constant_new_typeless_hzv (ffelexToken t)
1464 ffetargetTypeless val;
1466 ffetarget_hexzvxt (&val, t);
1467 return ffebld_constant_new_typeless_val (FFEBLD_constHEX_Z_VXT, val);
1470 /* ffebld_constant_new_typeless_om -- Return typeless constant object from token
1474 Parses the token as a decimal integer constant, thus it must be an
1475 FFELEX_typeNUMBER. */
1478 ffebld_constant_new_typeless_om (ffelexToken t)
1480 ffetargetTypeless val;
1482 ffetarget_octalmil (&val, t);
1483 return ffebld_constant_new_typeless_val (FFEBLD_constOCTAL_MIL, val);
1486 /* ffebld_constant_new_typeless_ov -- Return typeless constant object from token
1490 Parses the token as a decimal integer constant, thus it must be an
1491 FFELEX_typeNUMBER. */
1494 ffebld_constant_new_typeless_ov (ffelexToken t)
1496 ffetargetTypeless val;
1498 ffetarget_octalvxt (&val, t);
1499 return ffebld_constant_new_typeless_val (FFEBLD_constOCTAL_VXT, val);
1502 /* ffebld_constant_new_typeless_val -- Return a typeless constant object
1507 ffebld_constant_new_typeless_val (ffebldConst type, ffetargetTypeless val)
1514 P = ffebld_constant_typeless_[type
1515 - FFEBLD_constTYPELESS_FIRST];
1519 /* make this node the root */
1520 nc = malloc_new_kp (ffebld_constant_pool(),
1521 "FFEBLD_constTYPELESS",
1523 nc->consttype = type;
1524 nc->u.typeless = val;
1525 nc->hook = FFECOM_constantNULL;
1528 ffebld_constant_typeless_[type- FFEBLD_constTYPELESS_FIRST] = nc;
1535 cmp = ffetarget_cmp_typeless (val, ffebld_constant_typeless (P));
1544 nc = malloc_new_kp (ffebld_constant_pool(),
1545 "FFEBLD_constTYPELESS",
1547 nc->consttype = type;
1548 nc->u.typeless = val;
1549 nc->hook = FFECOM_constantNULL;
1560 /* ffebld_constantarray_get -- Get a value from an array of constants
1565 ffebld_constantarray_get (ffebldConstantArray array, ffeinfoBasictype bt,
1566 ffeinfoKindtype kt, ffetargetOffset offset)
1568 ffebldConstantUnion u;
1572 case FFEINFO_basictypeINTEGER:
1575 #if FFETARGET_okINTEGER1
1576 case FFEINFO_kindtypeINTEGER1:
1577 u.integer1 = *(array.integer1 + offset);
1581 #if FFETARGET_okINTEGER2
1582 case FFEINFO_kindtypeINTEGER2:
1583 u.integer2 = *(array.integer2 + offset);
1587 #if FFETARGET_okINTEGER3
1588 case FFEINFO_kindtypeINTEGER3:
1589 u.integer3 = *(array.integer3 + offset);
1593 #if FFETARGET_okINTEGER4
1594 case FFEINFO_kindtypeINTEGER4:
1595 u.integer4 = *(array.integer4 + offset);
1600 assert ("bad INTEGER kindtype" == NULL);
1605 case FFEINFO_basictypeLOGICAL:
1608 #if FFETARGET_okLOGICAL1
1609 case FFEINFO_kindtypeLOGICAL1:
1610 u.logical1 = *(array.logical1 + offset);
1614 #if FFETARGET_okLOGICAL2
1615 case FFEINFO_kindtypeLOGICAL2:
1616 u.logical2 = *(array.logical2 + offset);
1620 #if FFETARGET_okLOGICAL3
1621 case FFEINFO_kindtypeLOGICAL3:
1622 u.logical3 = *(array.logical3 + offset);
1626 #if FFETARGET_okLOGICAL4
1627 case FFEINFO_kindtypeLOGICAL4:
1628 u.logical4 = *(array.logical4 + offset);
1633 assert ("bad LOGICAL kindtype" == NULL);
1638 case FFEINFO_basictypeREAL:
1641 #if FFETARGET_okREAL1
1642 case FFEINFO_kindtypeREAL1:
1643 u.real1 = *(array.real1 + offset);
1647 #if FFETARGET_okREAL2
1648 case FFEINFO_kindtypeREAL2:
1649 u.real2 = *(array.real2 + offset);
1653 #if FFETARGET_okREAL3
1654 case FFEINFO_kindtypeREAL3:
1655 u.real3 = *(array.real3 + offset);
1660 assert ("bad REAL kindtype" == NULL);
1665 case FFEINFO_basictypeCOMPLEX:
1668 #if FFETARGET_okCOMPLEX1
1669 case FFEINFO_kindtypeREAL1:
1670 u.complex1 = *(array.complex1 + offset);
1674 #if FFETARGET_okCOMPLEX2
1675 case FFEINFO_kindtypeREAL2:
1676 u.complex2 = *(array.complex2 + offset);
1680 #if FFETARGET_okCOMPLEX3
1681 case FFEINFO_kindtypeREAL3:
1682 u.complex3 = *(array.complex3 + offset);
1687 assert ("bad COMPLEX kindtype" == NULL);
1692 case FFEINFO_basictypeCHARACTER:
1695 #if FFETARGET_okCHARACTER1
1696 case FFEINFO_kindtypeCHARACTER1:
1697 u.character1.length = 1;
1698 u.character1.text = array.character1 + offset;
1703 assert ("bad CHARACTER kindtype" == NULL);
1709 assert ("bad basictype" == NULL);
1716 /* ffebld_constantarray_new -- Make an array of constants
1721 ffebld_constantarray_new (ffeinfoBasictype bt,
1722 ffeinfoKindtype kt, ffetargetOffset size)
1724 ffebldConstantArray ptr;
1728 case FFEINFO_basictypeINTEGER:
1731 #if FFETARGET_okINTEGER1
1732 case FFEINFO_kindtypeINTEGER1:
1733 ptr.integer1 = malloc_new_zkp (ffebld_constant_pool(),
1734 "ffebldConstantArray",
1735 size *= sizeof (ffetargetInteger1),
1740 #if FFETARGET_okINTEGER2
1741 case FFEINFO_kindtypeINTEGER2:
1742 ptr.integer2 = malloc_new_zkp (ffebld_constant_pool(),
1743 "ffebldConstantArray",
1744 size *= sizeof (ffetargetInteger2),
1749 #if FFETARGET_okINTEGER3
1750 case FFEINFO_kindtypeINTEGER3:
1751 ptr.integer3 = malloc_new_zkp (ffebld_constant_pool(),
1752 "ffebldConstantArray",
1753 size *= sizeof (ffetargetInteger3),
1758 #if FFETARGET_okINTEGER4
1759 case FFEINFO_kindtypeINTEGER4:
1760 ptr.integer4 = malloc_new_zkp (ffebld_constant_pool(),
1761 "ffebldConstantArray",
1762 size *= sizeof (ffetargetInteger4),
1768 assert ("bad INTEGER kindtype" == NULL);
1773 case FFEINFO_basictypeLOGICAL:
1776 #if FFETARGET_okLOGICAL1
1777 case FFEINFO_kindtypeLOGICAL1:
1778 ptr.logical1 = malloc_new_zkp (ffebld_constant_pool(),
1779 "ffebldConstantArray",
1780 size *= sizeof (ffetargetLogical1),
1785 #if FFETARGET_okLOGICAL2
1786 case FFEINFO_kindtypeLOGICAL2:
1787 ptr.logical2 = malloc_new_zkp (ffebld_constant_pool(),
1788 "ffebldConstantArray",
1789 size *= sizeof (ffetargetLogical2),
1794 #if FFETARGET_okLOGICAL3
1795 case FFEINFO_kindtypeLOGICAL3:
1796 ptr.logical3 = malloc_new_zkp (ffebld_constant_pool(),
1797 "ffebldConstantArray",
1798 size *= sizeof (ffetargetLogical3),
1803 #if FFETARGET_okLOGICAL4
1804 case FFEINFO_kindtypeLOGICAL4:
1805 ptr.logical4 = malloc_new_zkp (ffebld_constant_pool(),
1806 "ffebldConstantArray",
1807 size *= sizeof (ffetargetLogical4),
1813 assert ("bad LOGICAL kindtype" == NULL);
1818 case FFEINFO_basictypeREAL:
1821 #if FFETARGET_okREAL1
1822 case FFEINFO_kindtypeREAL1:
1823 ptr.real1 = malloc_new_zkp (ffebld_constant_pool(),
1824 "ffebldConstantArray",
1825 size *= sizeof (ffetargetReal1),
1830 #if FFETARGET_okREAL2
1831 case FFEINFO_kindtypeREAL2:
1832 ptr.real2 = malloc_new_zkp (ffebld_constant_pool(),
1833 "ffebldConstantArray",
1834 size *= sizeof (ffetargetReal2),
1839 #if FFETARGET_okREAL3
1840 case FFEINFO_kindtypeREAL3:
1841 ptr.real3 = malloc_new_zkp (ffebld_constant_pool(),
1842 "ffebldConstantArray",
1843 size *= sizeof (ffetargetReal3),
1849 assert ("bad REAL kindtype" == NULL);
1854 case FFEINFO_basictypeCOMPLEX:
1857 #if FFETARGET_okCOMPLEX1
1858 case FFEINFO_kindtypeREAL1:
1859 ptr.complex1 = malloc_new_zkp (ffebld_constant_pool(),
1860 "ffebldConstantArray",
1861 size *= sizeof (ffetargetComplex1),
1866 #if FFETARGET_okCOMPLEX2
1867 case FFEINFO_kindtypeREAL2:
1868 ptr.complex2 = malloc_new_zkp (ffebld_constant_pool(),
1869 "ffebldConstantArray",
1870 size *= sizeof (ffetargetComplex2),
1875 #if FFETARGET_okCOMPLEX3
1876 case FFEINFO_kindtypeREAL3:
1877 ptr.complex3 = malloc_new_zkp (ffebld_constant_pool(),
1878 "ffebldConstantArray",
1879 size *= sizeof (ffetargetComplex3),
1885 assert ("bad COMPLEX kindtype" == NULL);
1890 case FFEINFO_basictypeCHARACTER:
1893 #if FFETARGET_okCHARACTER1
1894 case FFEINFO_kindtypeCHARACTER1:
1895 ptr.character1 = malloc_new_zkp (ffebld_constant_pool(),
1896 "ffebldConstantArray",
1898 *= sizeof (ffetargetCharacterUnit1),
1904 assert ("bad CHARACTER kindtype" == NULL);
1910 assert ("bad basictype" == NULL);
1917 /* ffebld_constantarray_preparray -- Prepare for copy between arrays
1921 Like _prepare, but the source is an array instead of a single-value
1925 ffebld_constantarray_preparray (void **aptr, void **cptr, size_t *size,
1926 ffebldConstantArray array, ffeinfoBasictype abt, ffeinfoKindtype akt,
1927 ffetargetOffset offset, ffebldConstantArray source_array,
1928 ffeinfoBasictype cbt, ffeinfoKindtype ckt)
1932 case FFEINFO_basictypeINTEGER:
1935 #if FFETARGET_okINTEGER1
1936 case FFEINFO_kindtypeINTEGER1:
1937 *aptr = array.integer1 + offset;
1941 #if FFETARGET_okINTEGER2
1942 case FFEINFO_kindtypeINTEGER2:
1943 *aptr = array.integer2 + offset;
1947 #if FFETARGET_okINTEGER3
1948 case FFEINFO_kindtypeINTEGER3:
1949 *aptr = array.integer3 + offset;
1953 #if FFETARGET_okINTEGER4
1954 case FFEINFO_kindtypeINTEGER4:
1955 *aptr = array.integer4 + offset;
1960 assert ("bad INTEGER akindtype" == NULL);
1965 case FFEINFO_basictypeLOGICAL:
1968 #if FFETARGET_okLOGICAL1
1969 case FFEINFO_kindtypeLOGICAL1:
1970 *aptr = array.logical1 + offset;
1974 #if FFETARGET_okLOGICAL2
1975 case FFEINFO_kindtypeLOGICAL2:
1976 *aptr = array.logical2 + offset;
1980 #if FFETARGET_okLOGICAL3
1981 case FFEINFO_kindtypeLOGICAL3:
1982 *aptr = array.logical3 + offset;
1986 #if FFETARGET_okLOGICAL4
1987 case FFEINFO_kindtypeLOGICAL4:
1988 *aptr = array.logical4 + offset;
1993 assert ("bad LOGICAL akindtype" == NULL);
1998 case FFEINFO_basictypeREAL:
2001 #if FFETARGET_okREAL1
2002 case FFEINFO_kindtypeREAL1:
2003 *aptr = array.real1 + offset;
2007 #if FFETARGET_okREAL2
2008 case FFEINFO_kindtypeREAL2:
2009 *aptr = array.real2 + offset;
2013 #if FFETARGET_okREAL3
2014 case FFEINFO_kindtypeREAL3:
2015 *aptr = array.real3 + offset;
2020 assert ("bad REAL akindtype" == NULL);
2025 case FFEINFO_basictypeCOMPLEX:
2028 #if FFETARGET_okCOMPLEX1
2029 case FFEINFO_kindtypeREAL1:
2030 *aptr = array.complex1 + offset;
2034 #if FFETARGET_okCOMPLEX2
2035 case FFEINFO_kindtypeREAL2:
2036 *aptr = array.complex2 + offset;
2040 #if FFETARGET_okCOMPLEX3
2041 case FFEINFO_kindtypeREAL3:
2042 *aptr = array.complex3 + offset;
2047 assert ("bad COMPLEX akindtype" == NULL);
2052 case FFEINFO_basictypeCHARACTER:
2055 #if FFETARGET_okCHARACTER1
2056 case FFEINFO_kindtypeCHARACTER1:
2057 *aptr = array.character1 + offset;
2062 assert ("bad CHARACTER akindtype" == NULL);
2068 assert ("bad abasictype" == NULL);
2074 case FFEINFO_basictypeINTEGER:
2077 #if FFETARGET_okINTEGER1
2078 case FFEINFO_kindtypeINTEGER1:
2079 *cptr = source_array.integer1;
2080 *size = sizeof (*source_array.integer1);
2084 #if FFETARGET_okINTEGER2
2085 case FFEINFO_kindtypeINTEGER2:
2086 *cptr = source_array.integer2;
2087 *size = sizeof (*source_array.integer2);
2091 #if FFETARGET_okINTEGER3
2092 case FFEINFO_kindtypeINTEGER3:
2093 *cptr = source_array.integer3;
2094 *size = sizeof (*source_array.integer3);
2098 #if FFETARGET_okINTEGER4
2099 case FFEINFO_kindtypeINTEGER4:
2100 *cptr = source_array.integer4;
2101 *size = sizeof (*source_array.integer4);
2106 assert ("bad INTEGER ckindtype" == NULL);
2111 case FFEINFO_basictypeLOGICAL:
2114 #if FFETARGET_okLOGICAL1
2115 case FFEINFO_kindtypeLOGICAL1:
2116 *cptr = source_array.logical1;
2117 *size = sizeof (*source_array.logical1);
2121 #if FFETARGET_okLOGICAL2
2122 case FFEINFO_kindtypeLOGICAL2:
2123 *cptr = source_array.logical2;
2124 *size = sizeof (*source_array.logical2);
2128 #if FFETARGET_okLOGICAL3
2129 case FFEINFO_kindtypeLOGICAL3:
2130 *cptr = source_array.logical3;
2131 *size = sizeof (*source_array.logical3);
2135 #if FFETARGET_okLOGICAL4
2136 case FFEINFO_kindtypeLOGICAL4:
2137 *cptr = source_array.logical4;
2138 *size = sizeof (*source_array.logical4);
2143 assert ("bad LOGICAL ckindtype" == NULL);
2148 case FFEINFO_basictypeREAL:
2151 #if FFETARGET_okREAL1
2152 case FFEINFO_kindtypeREAL1:
2153 *cptr = source_array.real1;
2154 *size = sizeof (*source_array.real1);
2158 #if FFETARGET_okREAL2
2159 case FFEINFO_kindtypeREAL2:
2160 *cptr = source_array.real2;
2161 *size = sizeof (*source_array.real2);
2165 #if FFETARGET_okREAL3
2166 case FFEINFO_kindtypeREAL3:
2167 *cptr = source_array.real3;
2168 *size = sizeof (*source_array.real3);
2173 assert ("bad REAL ckindtype" == NULL);
2178 case FFEINFO_basictypeCOMPLEX:
2181 #if FFETARGET_okCOMPLEX1
2182 case FFEINFO_kindtypeREAL1:
2183 *cptr = source_array.complex1;
2184 *size = sizeof (*source_array.complex1);
2188 #if FFETARGET_okCOMPLEX2
2189 case FFEINFO_kindtypeREAL2:
2190 *cptr = source_array.complex2;
2191 *size = sizeof (*source_array.complex2);
2195 #if FFETARGET_okCOMPLEX3
2196 case FFEINFO_kindtypeREAL3:
2197 *cptr = source_array.complex3;
2198 *size = sizeof (*source_array.complex3);
2203 assert ("bad COMPLEX ckindtype" == NULL);
2208 case FFEINFO_basictypeCHARACTER:
2211 #if FFETARGET_okCHARACTER1
2212 case FFEINFO_kindtypeCHARACTER1:
2213 *cptr = source_array.character1;
2214 *size = sizeof (*source_array.character1);
2219 assert ("bad CHARACTER ckindtype" == NULL);
2225 assert ("bad cbasictype" == NULL);
2230 /* ffebld_constantarray_prepare -- Prepare for copy between value and array
2234 Like _put, but just returns the pointers to the beginnings of the
2235 array and the constant and returns the size (the amount of info to
2236 copy). The idea is that the caller can use memcpy to accomplish the
2237 same thing as _put (though slower), or the caller can use a different
2238 function that swaps bytes, words, etc for a different target machine.
2239 Also, the type of the array may be different from the type of the
2240 constant; the array type is used to determine the meaning (scale) of
2241 the offset field (to calculate the array pointer), the constant type is
2242 used to determine the constant pointer and the size (amount of info to
2246 ffebld_constantarray_prepare (void **aptr, void **cptr, size_t *size,
2247 ffebldConstantArray array, ffeinfoBasictype abt, ffeinfoKindtype akt,
2248 ffetargetOffset offset, ffebldConstantUnion *constant,
2249 ffeinfoBasictype cbt, ffeinfoKindtype ckt)
2253 case FFEINFO_basictypeINTEGER:
2256 #if FFETARGET_okINTEGER1
2257 case FFEINFO_kindtypeINTEGER1:
2258 *aptr = array.integer1 + offset;
2262 #if FFETARGET_okINTEGER2
2263 case FFEINFO_kindtypeINTEGER2:
2264 *aptr = array.integer2 + offset;
2268 #if FFETARGET_okINTEGER3
2269 case FFEINFO_kindtypeINTEGER3:
2270 *aptr = array.integer3 + offset;
2274 #if FFETARGET_okINTEGER4
2275 case FFEINFO_kindtypeINTEGER4:
2276 *aptr = array.integer4 + offset;
2281 assert ("bad INTEGER akindtype" == NULL);
2286 case FFEINFO_basictypeLOGICAL:
2289 #if FFETARGET_okLOGICAL1
2290 case FFEINFO_kindtypeLOGICAL1:
2291 *aptr = array.logical1 + offset;
2295 #if FFETARGET_okLOGICAL2
2296 case FFEINFO_kindtypeLOGICAL2:
2297 *aptr = array.logical2 + offset;
2301 #if FFETARGET_okLOGICAL3
2302 case FFEINFO_kindtypeLOGICAL3:
2303 *aptr = array.logical3 + offset;
2307 #if FFETARGET_okLOGICAL4
2308 case FFEINFO_kindtypeLOGICAL4:
2309 *aptr = array.logical4 + offset;
2314 assert ("bad LOGICAL akindtype" == NULL);
2319 case FFEINFO_basictypeREAL:
2322 #if FFETARGET_okREAL1
2323 case FFEINFO_kindtypeREAL1:
2324 *aptr = array.real1 + offset;
2328 #if FFETARGET_okREAL2
2329 case FFEINFO_kindtypeREAL2:
2330 *aptr = array.real2 + offset;
2334 #if FFETARGET_okREAL3
2335 case FFEINFO_kindtypeREAL3:
2336 *aptr = array.real3 + offset;
2341 assert ("bad REAL akindtype" == NULL);
2346 case FFEINFO_basictypeCOMPLEX:
2349 #if FFETARGET_okCOMPLEX1
2350 case FFEINFO_kindtypeREAL1:
2351 *aptr = array.complex1 + offset;
2355 #if FFETARGET_okCOMPLEX2
2356 case FFEINFO_kindtypeREAL2:
2357 *aptr = array.complex2 + offset;
2361 #if FFETARGET_okCOMPLEX3
2362 case FFEINFO_kindtypeREAL3:
2363 *aptr = array.complex3 + offset;
2368 assert ("bad COMPLEX akindtype" == NULL);
2373 case FFEINFO_basictypeCHARACTER:
2376 #if FFETARGET_okCHARACTER1
2377 case FFEINFO_kindtypeCHARACTER1:
2378 *aptr = array.character1 + offset;
2383 assert ("bad CHARACTER akindtype" == NULL);
2389 assert ("bad abasictype" == NULL);
2395 case FFEINFO_basictypeINTEGER:
2398 #if FFETARGET_okINTEGER1
2399 case FFEINFO_kindtypeINTEGER1:
2400 *cptr = &constant->integer1;
2401 *size = sizeof (constant->integer1);
2405 #if FFETARGET_okINTEGER2
2406 case FFEINFO_kindtypeINTEGER2:
2407 *cptr = &constant->integer2;
2408 *size = sizeof (constant->integer2);
2412 #if FFETARGET_okINTEGER3
2413 case FFEINFO_kindtypeINTEGER3:
2414 *cptr = &constant->integer3;
2415 *size = sizeof (constant->integer3);
2419 #if FFETARGET_okINTEGER4
2420 case FFEINFO_kindtypeINTEGER4:
2421 *cptr = &constant->integer4;
2422 *size = sizeof (constant->integer4);
2427 assert ("bad INTEGER ckindtype" == NULL);
2432 case FFEINFO_basictypeLOGICAL:
2435 #if FFETARGET_okLOGICAL1
2436 case FFEINFO_kindtypeLOGICAL1:
2437 *cptr = &constant->logical1;
2438 *size = sizeof (constant->logical1);
2442 #if FFETARGET_okLOGICAL2
2443 case FFEINFO_kindtypeLOGICAL2:
2444 *cptr = &constant->logical2;
2445 *size = sizeof (constant->logical2);
2449 #if FFETARGET_okLOGICAL3
2450 case FFEINFO_kindtypeLOGICAL3:
2451 *cptr = &constant->logical3;
2452 *size = sizeof (constant->logical3);
2456 #if FFETARGET_okLOGICAL4
2457 case FFEINFO_kindtypeLOGICAL4:
2458 *cptr = &constant->logical4;
2459 *size = sizeof (constant->logical4);
2464 assert ("bad LOGICAL ckindtype" == NULL);
2469 case FFEINFO_basictypeREAL:
2472 #if FFETARGET_okREAL1
2473 case FFEINFO_kindtypeREAL1:
2474 *cptr = &constant->real1;
2475 *size = sizeof (constant->real1);
2479 #if FFETARGET_okREAL2
2480 case FFEINFO_kindtypeREAL2:
2481 *cptr = &constant->real2;
2482 *size = sizeof (constant->real2);
2486 #if FFETARGET_okREAL3
2487 case FFEINFO_kindtypeREAL3:
2488 *cptr = &constant->real3;
2489 *size = sizeof (constant->real3);
2494 assert ("bad REAL ckindtype" == NULL);
2499 case FFEINFO_basictypeCOMPLEX:
2502 #if FFETARGET_okCOMPLEX1
2503 case FFEINFO_kindtypeREAL1:
2504 *cptr = &constant->complex1;
2505 *size = sizeof (constant->complex1);
2509 #if FFETARGET_okCOMPLEX2
2510 case FFEINFO_kindtypeREAL2:
2511 *cptr = &constant->complex2;
2512 *size = sizeof (constant->complex2);
2516 #if FFETARGET_okCOMPLEX3
2517 case FFEINFO_kindtypeREAL3:
2518 *cptr = &constant->complex3;
2519 *size = sizeof (constant->complex3);
2524 assert ("bad COMPLEX ckindtype" == NULL);
2529 case FFEINFO_basictypeCHARACTER:
2532 #if FFETARGET_okCHARACTER1
2533 case FFEINFO_kindtypeCHARACTER1:
2534 *cptr = ffetarget_text_character1 (constant->character1);
2535 *size = ffetarget_length_character1 (constant->character1);
2540 assert ("bad CHARACTER ckindtype" == NULL);
2546 assert ("bad cbasictype" == NULL);
2551 /* ffebld_constantarray_put -- Put a value into an array of constants
2556 ffebld_constantarray_put (ffebldConstantArray array, ffeinfoBasictype bt,
2557 ffeinfoKindtype kt, ffetargetOffset offset, ffebldConstantUnion constant)
2561 case FFEINFO_basictypeINTEGER:
2564 #if FFETARGET_okINTEGER1
2565 case FFEINFO_kindtypeINTEGER1:
2566 *(array.integer1 + offset) = constant.integer1;
2570 #if FFETARGET_okINTEGER2
2571 case FFEINFO_kindtypeINTEGER2:
2572 *(array.integer2 + offset) = constant.integer2;
2576 #if FFETARGET_okINTEGER3
2577 case FFEINFO_kindtypeINTEGER3:
2578 *(array.integer3 + offset) = constant.integer3;
2582 #if FFETARGET_okINTEGER4
2583 case FFEINFO_kindtypeINTEGER4:
2584 *(array.integer4 + offset) = constant.integer4;
2589 assert ("bad INTEGER kindtype" == NULL);
2594 case FFEINFO_basictypeLOGICAL:
2597 #if FFETARGET_okLOGICAL1
2598 case FFEINFO_kindtypeLOGICAL1:
2599 *(array.logical1 + offset) = constant.logical1;
2603 #if FFETARGET_okLOGICAL2
2604 case FFEINFO_kindtypeLOGICAL2:
2605 *(array.logical2 + offset) = constant.logical2;
2609 #if FFETARGET_okLOGICAL3
2610 case FFEINFO_kindtypeLOGICAL3:
2611 *(array.logical3 + offset) = constant.logical3;
2615 #if FFETARGET_okLOGICAL4
2616 case FFEINFO_kindtypeLOGICAL4:
2617 *(array.logical4 + offset) = constant.logical4;
2622 assert ("bad LOGICAL kindtype" == NULL);
2627 case FFEINFO_basictypeREAL:
2630 #if FFETARGET_okREAL1
2631 case FFEINFO_kindtypeREAL1:
2632 *(array.real1 + offset) = constant.real1;
2636 #if FFETARGET_okREAL2
2637 case FFEINFO_kindtypeREAL2:
2638 *(array.real2 + offset) = constant.real2;
2642 #if FFETARGET_okREAL3
2643 case FFEINFO_kindtypeREAL3:
2644 *(array.real3 + offset) = constant.real3;
2649 assert ("bad REAL kindtype" == NULL);
2654 case FFEINFO_basictypeCOMPLEX:
2657 #if FFETARGET_okCOMPLEX1
2658 case FFEINFO_kindtypeREAL1:
2659 *(array.complex1 + offset) = constant.complex1;
2663 #if FFETARGET_okCOMPLEX2
2664 case FFEINFO_kindtypeREAL2:
2665 *(array.complex2 + offset) = constant.complex2;
2669 #if FFETARGET_okCOMPLEX3
2670 case FFEINFO_kindtypeREAL3:
2671 *(array.complex3 + offset) = constant.complex3;
2676 assert ("bad COMPLEX kindtype" == NULL);
2681 case FFEINFO_basictypeCHARACTER:
2684 #if FFETARGET_okCHARACTER1
2685 case FFEINFO_kindtypeCHARACTER1:
2686 memcpy (array.character1 + offset,
2687 ffetarget_text_character1 (constant.character1),
2688 ffetarget_length_character1 (constant.character1));
2693 assert ("bad CHARACTER kindtype" == NULL);
2699 assert ("bad basictype" == NULL);
2704 /* ffebld_init_0 -- Initialize the module
2709 ffebld_init_0 (void)
2711 assert (FFEBLD_op == ARRAY_SIZE (ffebld_op_string_));
2712 assert (FFEBLD_op == ARRAY_SIZE (ffebld_arity_op_));
2715 /* ffebld_init_1 -- Initialize the module for a file
2720 ffebld_init_1 (void)
2722 #if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstFILE_
2725 #if FFETARGET_okCHARACTER1
2726 ffebld_constant_character1_ = NULL;
2728 #if FFETARGET_okCOMPLEX1
2729 ffebld_constant_complex1_ = NULL;
2731 #if FFETARGET_okCOMPLEX2
2732 ffebld_constant_complex2_ = NULL;
2734 #if FFETARGET_okCOMPLEX3
2735 ffebld_constant_complex3_ = NULL;
2737 #if FFETARGET_okINTEGER1
2738 ffebld_constant_integer1_ = NULL;
2740 #if FFETARGET_okINTEGER2
2741 ffebld_constant_integer2_ = NULL;
2743 #if FFETARGET_okINTEGER3
2744 ffebld_constant_integer3_ = NULL;
2746 #if FFETARGET_okINTEGER4
2747 ffebld_constant_integer4_ = NULL;
2749 #if FFETARGET_okLOGICAL1
2750 ffebld_constant_logical1_ = NULL;
2752 #if FFETARGET_okLOGICAL2
2753 ffebld_constant_logical2_ = NULL;
2755 #if FFETARGET_okLOGICAL3
2756 ffebld_constant_logical3_ = NULL;
2758 #if FFETARGET_okLOGICAL4
2759 ffebld_constant_logical4_ = NULL;
2761 #if FFETARGET_okREAL1
2762 ffebld_constant_real1_ = NULL;
2764 #if FFETARGET_okREAL2
2765 ffebld_constant_real2_ = NULL;
2767 #if FFETARGET_okREAL3
2768 ffebld_constant_real3_ = NULL;
2770 ffebld_constant_hollerith_ = NULL;
2771 for (i = FFEBLD_constTYPELESS_FIRST; i <= FFEBLD_constTYPELESS_LAST; ++i)
2772 ffebld_constant_typeless_[i - FFEBLD_constTYPELESS_FIRST] = NULL;
2776 /* ffebld_init_2 -- Initialize the module
2781 ffebld_init_2 (void)
2783 #if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstPROGUNIT_
2787 ffebld_pool_stack_.next = NULL;
2788 ffebld_pool_stack_.pool = ffe_pool_program_unit ();
2789 #if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstPROGUNIT_
2790 #if FFETARGET_okCHARACTER1
2791 ffebld_constant_character1_ = NULL;
2793 #if FFETARGET_okCOMPLEX1
2794 ffebld_constant_complex1_ = NULL;
2796 #if FFETARGET_okCOMPLEX2
2797 ffebld_constant_complex2_ = NULL;
2799 #if FFETARGET_okCOMPLEX3
2800 ffebld_constant_complex3_ = NULL;
2802 #if FFETARGET_okINTEGER1
2803 ffebld_constant_integer1_ = NULL;
2805 #if FFETARGET_okINTEGER2
2806 ffebld_constant_integer2_ = NULL;
2808 #if FFETARGET_okINTEGER3
2809 ffebld_constant_integer3_ = NULL;
2811 #if FFETARGET_okINTEGER4
2812 ffebld_constant_integer4_ = NULL;
2814 #if FFETARGET_okLOGICAL1
2815 ffebld_constant_logical1_ = NULL;
2817 #if FFETARGET_okLOGICAL2
2818 ffebld_constant_logical2_ = NULL;
2820 #if FFETARGET_okLOGICAL3
2821 ffebld_constant_logical3_ = NULL;
2823 #if FFETARGET_okLOGICAL4
2824 ffebld_constant_logical4_ = NULL;
2826 #if FFETARGET_okREAL1
2827 ffebld_constant_real1_ = NULL;
2829 #if FFETARGET_okREAL2
2830 ffebld_constant_real2_ = NULL;
2832 #if FFETARGET_okREAL3
2833 ffebld_constant_real3_ = NULL;
2835 ffebld_constant_hollerith_ = NULL;
2836 for (i = FFEBLD_constTYPELESS_FIRST; i <= FFEBLD_constTYPELESS_LAST; ++i)
2837 ffebld_constant_typeless_[i - FFEBLD_constTYPELESS_FIRST] = NULL;
2841 /* ffebld_list_length -- Return # of opITEMs in list
2843 ffebld list; // Must be NULL or opITEM
2844 ffebldListLength length;
2845 length = ffebld_list_length(list);
2847 Returns 0 if list is NULL, 1 if it's ffebld_trail is NULL, and so on. */
2850 ffebld_list_length (ffebld list)
2852 ffebldListLength length;
2854 for (length = 0; list != NULL; ++length, list = ffebld_trail (list))
2860 /* ffebld_new_accter -- Create an ffebld object that is an array
2863 ffebldConstantArray a;
2865 x = ffebld_new_accter(a,b); */
2868 ffebld_new_accter (ffebldConstantArray a, ffebit b)
2873 x->op = FFEBLD_opACCTER;
2874 x->u.accter.array = a;
2875 x->u.accter.bits = b;
2876 x->u.accter.pad = 0;
2880 /* ffebld_new_arrter -- Create an ffebld object that is an array
2883 ffebldConstantArray a;
2884 ffetargetOffset size;
2885 x = ffebld_new_arrter(a,size); */
2888 ffebld_new_arrter (ffebldConstantArray a, ffetargetOffset size)
2893 x->op = FFEBLD_opARRTER;
2894 x->u.arrter.array = a;
2895 x->u.arrter.size = size;
2896 x->u.arrter.pad = 0;
2900 /* ffebld_new_conter_with_orig -- Create an ffebld object that is a constant
2904 x = ffebld_new_conter_with_orig(c,NULL); */
2907 ffebld_new_conter_with_orig (ffebldConstant c, ffebld o)
2912 x->op = FFEBLD_opCONTER;
2913 x->u.conter.expr = c;
2914 x->u.conter.orig = o;
2915 x->u.conter.pad = 0;
2919 /* ffebld_new_item -- Create an ffebld item object
2922 x = ffebld_new_item(y,z); */
2925 ffebld_new_item (ffebld head, ffebld trail)
2930 x->op = FFEBLD_opITEM;
2931 x->u.item.head = head;
2932 x->u.item.trail = trail;
2936 /* ffebld_new_labter -- Create an ffebld object that is a label
2940 x = ffebld_new_labter(c); */
2943 ffebld_new_labter (ffelab l)
2948 x->op = FFEBLD_opLABTER;
2953 /* ffebld_new_labtok -- Create object that is a label's NUMBER token
2957 x = ffebld_new_labter(c);
2959 Like the other ffebld_new_ functions, the
2960 supplied argument is stored exactly as is: ffelex_token_use is NOT
2961 called, so the token is "consumed", if one is indeed supplied (it may
2965 ffebld_new_labtok (ffelexToken t)
2970 x->op = FFEBLD_opLABTOK;
2975 /* ffebld_new_none -- Create an ffebld object with no arguments
2978 x = ffebld_new_none(FFEBLD_opWHATEVER); */
2981 ffebld_new_none (ffebldOp o)
2990 /* ffebld_new_one -- Create an ffebld object with one argument
2993 x = ffebld_new_one(FFEBLD_opWHATEVER,y); */
2996 ffebld_new_one (ffebldOp o, ffebld left)
3002 x->u.nonter.left = left;
3003 x->u.nonter.hook = FFECOM_nonterNULL;
3007 /* ffebld_new_symter -- Create an ffebld object that is a symbol
3011 ffeintrinGen gen; // Generic intrinsic id, if any
3012 ffeintrinSpec spec; // Specific intrinsic id, if any
3013 ffeintrinImp imp; // Implementation intrinsic id, if any
3014 x = ffebld_new_symter (s, gen, spec, imp); */
3017 ffebld_new_symter (ffesymbol s, ffeintrinGen gen, ffeintrinSpec spec,
3023 x->op = FFEBLD_opSYMTER;
3024 x->u.symter.symbol = s;
3025 x->u.symter.generic = gen;
3026 x->u.symter.specific = spec;
3027 x->u.symter.implementation = imp;
3028 x->u.symter.do_iter = FALSE;
3032 /* ffebld_new_two -- Create an ffebld object with two arguments
3035 x = ffebld_new_two(FFEBLD_opWHATEVER,y,z); */
3038 ffebld_new_two (ffebldOp o, ffebld left, ffebld right)
3044 x->u.nonter.left = left;
3045 x->u.nonter.right = right;
3046 x->u.nonter.hook = FFECOM_nonterNULL;
3050 /* ffebld_pool_pop -- Pop ffebld's pool stack
3052 ffebld_pool_pop(); */
3055 ffebld_pool_pop (void)
3057 ffebldPoolstack_ ps;
3059 assert (ffebld_pool_stack_.next != NULL);
3060 ps = ffebld_pool_stack_.next;
3061 ffebld_pool_stack_.next = ps->next;
3062 ffebld_pool_stack_.pool = ps->pool;
3063 malloc_kill_ks (malloc_pool_image (), ps, sizeof (*ps));
3066 /* ffebld_pool_push -- Push ffebld's pool stack
3068 ffebld_pool_push(); */
3071 ffebld_pool_push (mallocPool pool)
3073 ffebldPoolstack_ ps;
3075 ps = malloc_new_ks (malloc_pool_image (), "Pool stack", sizeof (*ps));
3076 ps->next = ffebld_pool_stack_.next;
3077 ps->pool = ffebld_pool_stack_.pool;
3078 ffebld_pool_stack_.next = ps;
3079 ffebld_pool_stack_.pool = pool;
3082 /* ffebld_op_string -- Return short string describing op
3085 ffebld_op_string(o);
3087 Returns a short string (uppercase) containing the name of the op. */
3090 ffebld_op_string (ffebldOp o)
3092 if (o >= ARRAY_SIZE (ffebld_op_string_))
3094 return ffebld_op_string_[o];
3097 /* ffebld_size_max -- Return maximum possible size of CHARACTER-type expr
3099 ffetargetCharacterSize sz;
3101 sz = ffebld_size_max (b);
3103 Like ffebld_size_known, but if that would return NONE and the expression
3104 is opSUBSTR, opCONVERT, opPAREN, or opCONCATENATE, returns ffebld_size_max
3105 of the subexpression(s). */
3107 ffetargetCharacterSize
3108 ffebld_size_max (ffebld b)
3110 ffetargetCharacterSize sz;
3112 recurse: /* :::::::::::::::::::: */
3114 sz = ffebld_size_known (b);
3116 if (sz != FFETARGET_charactersizeNONE)
3119 switch (ffebld_op (b))
3121 case FFEBLD_opSUBSTR:
3122 case FFEBLD_opCONVERT:
3123 case FFEBLD_opPAREN:
3124 b = ffebld_left (b);
3125 goto recurse; /* :::::::::::::::::::: */
3127 case FFEBLD_opCONCATENATE:
3128 sz = ffebld_size_max (ffebld_left (b))
3129 + ffebld_size_max (ffebld_right (b));