1 /* target.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 1997, 1998, 2002 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 Implements conversion of lexer tokens to machine-dependent numerical
27 form and accordingly issues diagnostic messages when necessary.
29 Also, this module, especially its .h file, provides nearly all of the
30 information on the target machine's data type, kind type, and length
31 type capabilities. The idea is that by carefully going through
32 target.h and changing things properly, one can accomplish much
33 towards the porting of the FFE to a new machine. There are limits
34 to how much this can accomplish towards that end, however. For one
35 thing, the ffeexpr_collapse_convert function doesn't contain all the
36 conversion cases necessary, because the text file would be
37 enormous (even though most of the function would be cut during the
38 cpp phase because of the absence of the types), so when adding to
39 the number of supported kind types for a given type, one must look
40 to see if ffeexpr_collapse_convert needs modification in this area,
41 in addition to providing the appropriate macros and functions in
42 ffetarget. Note that if combinatorial explosion actually becomes a
43 problem for a given machine, one might have to modify the way conversion
44 expressions are built so that instead of just one conversion expr, a
45 series of conversion exprs are built to make a path from one type to
46 another that is not a "near neighbor". For now, however, with a handful
47 of each of the numeric types and only one character type, things appear
50 A nonobvious change to ffetarget would be if the target machine was
51 not a 2's-complement machine. Any item with the word "magical" (case-
52 insensitive) in the FFE's source code (at least) indicates an assumption
53 that a 2's-complement machine is the target, and thus that there exists
54 a magnitude that can be represented as a negative number but not as
55 a positive number. It is possible that this situation can be dealt
56 with by changing only ffetarget, for example, on a 1's-complement
57 machine, perhaps #defineing ffetarget_constant_is_magical to simply
58 FALSE along with making the appropriate changes in ffetarget's number
59 parsing functions would be sufficient to effectively "comment out" code
60 in places like ffeexpr that do certain magical checks. But it is
61 possible there are other 2's-complement dependencies lurking in the
62 FFE (as possibly is true of any large program); if you find any, please
63 report them so we can replace them with dependencies on ffetarget
73 #include "diagnostic.h"
81 /* Externals defined here. */
83 char ffetarget_string_
[40]; /* Temp for ascii-to-double (atof). */
84 HOST_WIDE_INT ffetarget_long_val_
;
85 HOST_WIDE_INT ffetarget_long_junk_
;
87 /* Simple definitions and enumerations. */
90 /* Internal typedefs. */
93 /* Private include files. */
96 /* Internal structure definitions. */
99 /* Static objects accessed by functions in this module. */
102 /* Static functions (internal). */
104 static void ffetarget_print_char_ (FILE *f
, unsigned char c
);
106 /* Internal macros. */
108 #ifdef REAL_VALUE_ATOF
109 #define FFETARGET_ATOF_(p,m) REAL_VALUE_ATOF ((p),(m))
111 #define FFETARGET_ATOF_(p,m) atof ((p))
115 /* ffetarget_print_char_ -- Print a single character (in apostrophe context)
119 Outputs char so it prints or is escaped C style. */
122 ffetarget_print_char_ (FILE *f
, unsigned char c
)
138 fprintf (f
, "\\%03o", (unsigned int) c
);
143 /* ffetarget_aggregate_info -- Determine type for aggregate storage area
147 If aggregate type is distinct, just return it. Else return a type
148 representing a common denominator for the nondistinct type (for now,
149 just return default character, since that'll work on almost all target
152 The rules for abt/akt are (as implemented by ffestorag_update):
154 abt == FFEINFO_basictypeANY (akt == FFEINFO_kindtypeANY also, by
155 definition): CHARACTER and non-CHARACTER types mixed.
157 abt == FFEINFO_basictypeNONE (akt == FFEINFO_kindtypeNONE also, by
158 definition): More than one non-CHARACTER type mixed, but no CHARACTER
161 abt some other value, akt == FFEINFO_kindtypeNONE: abt indicates the
162 only basic type mixed in, but more than one kind type is mixed in.
164 abt some other value, akt some other value: abt and akt indicate the
165 only type represented in the aggregation. */
168 ffetarget_aggregate_info (ffeinfoBasictype
*ebt
, ffeinfoKindtype
*ekt
,
169 ffetargetAlign
*units
, ffeinfoBasictype abt
,
174 if ((abt
== FFEINFO_basictypeNONE
) || (abt
== FFEINFO_basictypeANY
)
175 || (akt
== FFEINFO_kindtypeNONE
))
177 *ebt
= FFEINFO_basictypeCHARACTER
;
178 *ekt
= FFEINFO_kindtypeCHARACTERDEFAULT
;
186 type
= ffeinfo_type (*ebt
, *ekt
);
187 assert (type
!= NULL
);
189 *units
= ffetype_size (type
);
192 /* ffetarget_align -- Align one storage area to superordinate, update super
196 updated_alignment/updated_modulo contain the already existing
197 alignment requirements for the storage area at whose offset the
198 object with alignment requirements alignment/modulo is to be placed.
199 Find the smallest pad such that the requirements are maintained and
200 return it, but only after updating the updated_alignment/_modulo
201 requirements as necessary to indicate the placement of the new object. */
204 ffetarget_align (ffetargetAlign
*updated_alignment
,
205 ffetargetAlign
*updated_modulo
, ffetargetOffset offset
,
206 ffetargetAlign alignment
, ffetargetAlign modulo
)
209 ffetargetAlign min_pad
; /* Minimum amount of padding needed. */
210 ffetargetAlign min_m
= 0; /* Minimum-padding m. */
211 ffetargetAlign ua
; /* Updated alignment. */
212 ffetargetAlign um
; /* Updated modulo. */
213 ffetargetAlign ucnt
; /* Multiplier applied to ua. */
214 ffetargetAlign m
; /* Copy of modulo. */
215 ffetargetAlign cnt
; /* Multiplier applied to alignment. */
219 assert (alignment
> 0);
220 assert (*updated_alignment
> 0);
222 assert (*updated_modulo
< *updated_alignment
);
223 assert (modulo
< alignment
);
225 /* The easy case: similar alignment requirements. */
226 if (*updated_alignment
== alignment
)
228 if (modulo
> *updated_modulo
)
229 pad
= alignment
- (modulo
- *updated_modulo
);
231 pad
= *updated_modulo
- modulo
;
233 /* De-negatize offset, since % wouldn't do the expected thing. */
234 offset
= alignment
- ((- offset
) % alignment
);
235 pad
= (offset
+ pad
) % alignment
;
237 pad
= alignment
- pad
;
241 /* Sigh, find LCM (Least Common Multiple) for the two alignment factors. */
243 for (ua
= *updated_alignment
, ucnt
= 1;
245 ua
+= *updated_alignment
)
248 cnt
= ua
/ alignment
;
251 /* De-negatize offset, since % wouldn't do the expected thing. */
252 offset
= ua
- ((- offset
) % ua
);
254 /* Set to largest value. */
255 min_pad
= ~(ffetargetAlign
) 0;
257 /* Find all combinations of modulo values the two alignment requirements
258 have; pick the combination that results in the smallest padding
259 requirement. Of course, if a zero-pad requirement is encountered, just
262 for (um
= *updated_modulo
, i
= 0; i
< ucnt
; um
+= *updated_alignment
, ++i
)
264 for (m
= modulo
, j
= 0; j
< cnt
; m
+= alignment
, ++j
)
266 /* This code is similar to the "easy case" code above. */
271 pad
= (offset
+ pad
) % ua
;
274 /* A zero pad means we've got something useful. */
275 *updated_alignment
= ua
;
276 *updated_modulo
= um
;
281 { /* New minimum padding value. */
288 *updated_alignment
= ua
;
289 *updated_modulo
= min_m
;
293 /* Always append a null byte to the end, in case this is wanted in
294 a special case such as passing a string as a FORMAT or %REF.
295 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
296 because it isn't a "feature" that is self-documenting. Use the
297 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
300 #if FFETARGET_okCHARACTER1
302 ffetarget_character1 (ffetargetCharacter1
*val
, ffelexToken character
,
305 val
->length
= ffelex_token_length (character
);
306 if (val
->length
== 0)
310 val
->text
= malloc_new_kp (pool
, "ffetargetCharacter1", val
->length
+ 1);
311 memcpy (val
->text
, ffelex_token_text (character
), val
->length
);
312 val
->text
[val
->length
] = '\0';
319 /* Produce orderable comparison between two constants
321 Compare lengths, if equal then use memcmp. */
323 #if FFETARGET_okCHARACTER1
325 ffetarget_cmp_character1 (ffetargetCharacter1 l
, ffetargetCharacter1 r
)
327 if (l
.length
< r
.length
)
329 if (l
.length
> r
.length
)
333 return memcmp (l
.text
, r
.text
, l
.length
);
337 /* ffetarget_concatenate_character1 -- Perform CONCAT op on two constants
339 Always append a null byte to the end, in case this is wanted in
340 a special case such as passing a string as a FORMAT or %REF.
341 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
342 because it isn't a "feature" that is self-documenting. Use the
343 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
346 #if FFETARGET_okCHARACTER1
348 ffetarget_concatenate_character1 (ffetargetCharacter1
*res
,
349 ffetargetCharacter1 l
, ffetargetCharacter1 r
, mallocPool pool
,
350 ffetargetCharacterSize
*len
)
352 res
->length
= *len
= l
.length
+ r
.length
;
357 res
->text
= malloc_new_kp (pool
, "ffetargetCharacter1(CONCAT)", *len
+ 1);
359 memcpy (res
->text
, l
.text
, l
.length
);
361 memcpy (res
->text
+ l
.length
, r
.text
, r
.length
);
362 res
->text
[*len
] = '\0';
369 /* ffetarget_eq_character1 -- Perform relational comparison on char constants
371 Compare lengths, if equal then use memcmp. */
373 #if FFETARGET_okCHARACTER1
375 ffetarget_eq_character1 (bool *res
, ffetargetCharacter1 l
,
376 ffetargetCharacter1 r
)
378 assert (l
.length
== r
.length
);
379 *res
= (memcmp (l
.text
, r
.text
, l
.length
) == 0);
384 /* ffetarget_le_character1 -- Perform relational comparison on char constants
386 Compare lengths, if equal then use memcmp. */
388 #if FFETARGET_okCHARACTER1
390 ffetarget_le_character1 (bool *res
, ffetargetCharacter1 l
,
391 ffetargetCharacter1 r
)
393 assert (l
.length
== r
.length
);
394 *res
= (memcmp (l
.text
, r
.text
, l
.length
) <= 0);
399 /* ffetarget_lt_character1 -- Perform relational comparison on char constants
401 Compare lengths, if equal then use memcmp. */
403 #if FFETARGET_okCHARACTER1
405 ffetarget_lt_character1 (bool *res
, ffetargetCharacter1 l
,
406 ffetargetCharacter1 r
)
408 assert (l
.length
== r
.length
);
409 *res
= (memcmp (l
.text
, r
.text
, l
.length
) < 0);
414 /* ffetarget_ge_character1 -- Perform relational comparison on char constants
416 Compare lengths, if equal then use memcmp. */
418 #if FFETARGET_okCHARACTER1
420 ffetarget_ge_character1 (bool *res
, ffetargetCharacter1 l
,
421 ffetargetCharacter1 r
)
423 assert (l
.length
== r
.length
);
424 *res
= (memcmp (l
.text
, r
.text
, l
.length
) >= 0);
429 /* ffetarget_gt_character1 -- Perform relational comparison on char constants
431 Compare lengths, if equal then use memcmp. */
433 #if FFETARGET_okCHARACTER1
435 ffetarget_gt_character1 (bool *res
, ffetargetCharacter1 l
,
436 ffetargetCharacter1 r
)
438 assert (l
.length
== r
.length
);
439 *res
= (memcmp (l
.text
, r
.text
, l
.length
) > 0);
444 #if FFETARGET_okCHARACTER1
446 ffetarget_iszero_character1 (ffetargetCharacter1 constant
)
448 ffetargetCharacterSize i
;
450 for (i
= 0; i
< constant
.length
; ++i
)
451 if (constant
.text
[i
] != 0)
458 ffetarget_iszero_hollerith (ffetargetHollerith constant
)
460 ffetargetHollerithSize i
;
462 for (i
= 0; i
< constant
.length
; ++i
)
463 if (constant
.text
[i
] != 0)
468 /* ffetarget_layout -- Do storage requirement analysis for entity
470 Return the alignment/modulo requirements along with the size, given the
471 data type info and the number of elements an array (1 for a scalar). */
474 ffetarget_layout (const char *error_text UNUSED
, ffetargetAlign
*alignment
,
475 ffetargetAlign
*modulo
, ffetargetOffset
*size
,
476 ffeinfoBasictype bt
, ffeinfoKindtype kt
,
477 ffetargetCharacterSize charsize
,
478 ffetargetIntegerDefault num_elements
)
480 bool ok
; /* For character type. */
481 ffetargetOffset numele
; /* Converted from num_elements. */
484 type
= ffeinfo_type (bt
, kt
);
485 assert (type
!= NULL
);
487 *alignment
= ffetype_alignment (type
);
488 *modulo
= ffetype_modulo (type
);
489 if (bt
== FFEINFO_basictypeCHARACTER
)
491 ok
= ffetarget_offset_charsize (size
, charsize
, ffetype_size (type
));
492 #ifdef ffetarget_offset_overflow
494 ffetarget_offset_overflow (error_text
);
498 *size
= ffetype_size (type
);
500 if ((num_elements
< 0)
501 || !ffetarget_offset (&numele
, num_elements
)
502 || !ffetarget_offset_multiply (size
, *size
, numele
))
504 ffetarget_offset_overflow (error_text
);
511 /* ffetarget_ne_character1 -- Perform relational comparison on char constants
513 Compare lengths, if equal then use memcmp. */
515 #if FFETARGET_okCHARACTER1
517 ffetarget_ne_character1 (bool *res
, ffetargetCharacter1 l
,
518 ffetargetCharacter1 r
)
520 assert (l
.length
== r
.length
);
521 *res
= (memcmp (l
.text
, r
.text
, l
.length
) != 0);
526 /* ffetarget_substr_character1 -- Perform SUBSTR op on three constants
528 Always append a null byte to the end, in case this is wanted in
529 a special case such as passing a string as a FORMAT or %REF.
530 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
531 because it isn't a "feature" that is self-documenting. Use the
532 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
535 #if FFETARGET_okCHARACTER1
537 ffetarget_substr_character1 (ffetargetCharacter1
*res
,
538 ffetargetCharacter1 l
,
539 ffetargetCharacterSize first
,
540 ffetargetCharacterSize last
, mallocPool pool
,
541 ffetargetCharacterSize
*len
)
545 res
->length
= *len
= 0;
550 res
->length
= *len
= last
- first
+ 1;
551 res
->text
= malloc_new_kp (pool
, "ffetargetCharacter1(SUBSTR)", *len
+ 1);
552 memcpy (res
->text
, l
.text
+ first
- 1, *len
);
553 res
->text
[*len
] = '\0';
560 /* ffetarget_cmp_hollerith -- Produce orderable comparison between two
563 Compare lengths, if equal then use memcmp. */
566 ffetarget_cmp_hollerith (ffetargetHollerith l
, ffetargetHollerith r
)
568 if (l
.length
< r
.length
)
570 if (l
.length
> r
.length
)
572 return memcmp (l
.text
, r
.text
, l
.length
);
576 ffetarget_convert_any_character1_ (char *res
, size_t size
,
577 ffetargetCharacter1 l
)
579 if (size
<= (size_t) l
.length
)
582 ffetargetCharacterSize i
;
584 memcpy (res
, l
.text
, size
);
585 for (p
= &l
.text
[0] + size
, i
= l
.length
- size
;
589 return FFEBAD_TRUNCATING_CHARACTER
;
593 memcpy (res
, l
.text
, size
);
594 memset (res
+ l
.length
, ' ', size
- l
.length
);
601 ffetarget_convert_any_hollerith_ (char *res
, size_t size
,
602 ffetargetHollerith l
)
604 if (size
<= (size_t) l
.length
)
607 ffetargetCharacterSize i
;
609 memcpy (res
, l
.text
, size
);
610 for (p
= &l
.text
[0] + size
, i
= l
.length
- size
;
614 return FFEBAD_TRUNCATING_HOLLERITH
;
618 memcpy (res
, l
.text
, size
);
619 memset (res
+ l
.length
, ' ', size
- l
.length
);
626 ffetarget_convert_any_typeless_ (char *res
, size_t size
,
629 unsigned long long int l1
;
630 unsigned long int l2
;
632 unsigned short int l4
;
637 if (size
>= sizeof (l1
))
641 size_of
= sizeof (l1
);
643 else if (size
>= sizeof (l2
))
647 size_of
= sizeof (l2
);
650 else if (size
>= sizeof (l3
))
654 size_of
= sizeof (l3
);
657 else if (size
>= sizeof (l4
))
661 size_of
= sizeof (l4
);
664 else if (size
>= sizeof (l5
))
668 size_of
= sizeof (l5
);
673 assert ("stumped by conversion from typeless!" == NULL
);
679 int i
= size_of
- size
;
681 memcpy (res
, p
+ i
, size
);
682 for (; i
> 0; ++p
, --i
)
684 return FFEBAD_TRUNCATING_TYPELESS
;
688 int i
= size
- size_of
;
691 memcpy (res
+ i
, p
, size_of
);
695 return FFEBAD_TRUNCATING_TYPELESS
;
699 /* Always append a null byte to the end, in case this is wanted in
700 a special case such as passing a string as a FORMAT or %REF.
701 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
702 because it isn't a "feature" that is self-documenting. Use the
703 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
706 #if FFETARGET_okCHARACTER1
708 ffetarget_convert_character1_character1 (ffetargetCharacter1
*res
,
709 ffetargetCharacterSize size
,
710 ffetargetCharacter1 l
,
718 res
->text
= malloc_new_kp (pool
, "FFETARGET cvt char1", size
+ 1);
719 if (size
<= l
.length
)
720 memcpy (res
->text
, l
.text
, size
);
723 memcpy (res
->text
, l
.text
, l
.length
);
724 memset (res
->text
+ l
.length
, ' ', size
- l
.length
);
726 res
->text
[size
] = '\0';
734 /* Always append a null byte to the end, in case this is wanted in
735 a special case such as passing a string as a FORMAT or %REF.
736 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
737 because it isn't a "feature" that is self-documenting. Use the
738 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
741 #if FFETARGET_okCHARACTER1
743 ffetarget_convert_character1_hollerith (ffetargetCharacter1
*res
,
744 ffetargetCharacterSize size
,
745 ffetargetHollerith l
, mallocPool pool
)
752 res
->text
= malloc_new_kp (pool
, "FFETARGET cvt char1", size
+ 1);
753 res
->text
[size
] = '\0';
754 if (size
<= l
.length
)
757 ffetargetCharacterSize i
;
759 memcpy (res
->text
, l
.text
, size
);
760 for (p
= &l
.text
[0] + size
, i
= l
.length
- size
;
764 return FFEBAD_TRUNCATING_HOLLERITH
;
768 memcpy (res
->text
, l
.text
, l
.length
);
769 memset (res
->text
+ l
.length
, ' ', size
- l
.length
);
777 /* ffetarget_convert_character1_integer4 -- Raw conversion.
779 Always append a null byte to the end, in case this is wanted in
780 a special case such as passing a string as a FORMAT or %REF.
781 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
782 because it isn't a "feature" that is self-documenting. Use the
783 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
786 #if FFETARGET_okCHARACTER1
788 ffetarget_convert_character1_integer4 (ffetargetCharacter1
*res
,
789 ffetargetCharacterSize size
,
790 ffetargetInteger4 l
, mallocPool pool
)
800 if (((size_t) size
) >= sizeof (l1
))
804 size_of
= sizeof (l1
);
806 else if (((size_t) size
) >= sizeof (l2
))
810 size_of
= sizeof (l2
);
813 else if (((size_t) size
) >= sizeof (l3
))
817 size_of
= sizeof (l3
);
820 else if (((size_t) size
) >= sizeof (l4
))
824 size_of
= sizeof (l4
);
827 else if (((size_t) size
) >= sizeof (l5
))
831 size_of
= sizeof (l5
);
836 assert ("stumped by conversion from integer1!" == NULL
);
845 res
->text
= malloc_new_kp (pool
, "FFETARGET cvt char1", size
+ 1);
846 res
->text
[size
] = '\0';
847 if (((size_t) size
) <= size_of
)
849 int i
= size_of
- size
;
851 memcpy (res
->text
, p
+ i
, size
);
852 for (; i
> 0; ++p
, --i
)
854 return FFEBAD_TRUNCATING_NUMERIC
;
858 int i
= size
- size_of
;
860 memset (res
->text
, 0, i
);
861 memcpy (res
->text
+ i
, p
, size_of
);
866 return FFEBAD_TRUNCATING_NUMERIC
;
871 /* ffetarget_convert_character1_logical4 -- Raw conversion.
873 Always append a null byte to the end, in case this is wanted in
874 a special case such as passing a string as a FORMAT or %REF.
875 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
876 because it isn't a "feature" that is self-documenting. Use the
877 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
880 #if FFETARGET_okCHARACTER1
882 ffetarget_convert_character1_logical4 (ffetargetCharacter1
*res
,
883 ffetargetCharacterSize size
,
884 ffetargetLogical4 l
, mallocPool pool
)
894 if (((size_t) size
) >= sizeof (l1
))
898 size_of
= sizeof (l1
);
900 else if (((size_t) size
) >= sizeof (l2
))
904 size_of
= sizeof (l2
);
907 else if (((size_t) size
) >= sizeof (l3
))
911 size_of
= sizeof (l3
);
914 else if (((size_t) size
) >= sizeof (l4
))
918 size_of
= sizeof (l4
);
921 else if (((size_t) size
) >= sizeof (l5
))
925 size_of
= sizeof (l5
);
930 assert ("stumped by conversion from logical1!" == NULL
);
939 res
->text
= malloc_new_kp (pool
, "FFETARGET cvt char1", size
+ 1);
940 res
->text
[size
] = '\0';
941 if (((size_t) size
) <= size_of
)
943 int i
= size_of
- size
;
945 memcpy (res
->text
, p
+ i
, size
);
946 for (; i
> 0; ++p
, --i
)
948 return FFEBAD_TRUNCATING_NUMERIC
;
952 int i
= size
- size_of
;
954 memset (res
->text
, 0, i
);
955 memcpy (res
->text
+ i
, p
, size_of
);
960 return FFEBAD_TRUNCATING_NUMERIC
;
965 /* ffetarget_convert_character1_typeless -- Raw conversion.
967 Always append a null byte to the end, in case this is wanted in
968 a special case such as passing a string as a FORMAT or %REF.
969 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
970 because it isn't a "feature" that is self-documenting. Use the
971 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
974 #if FFETARGET_okCHARACTER1
976 ffetarget_convert_character1_typeless (ffetargetCharacter1
*res
,
977 ffetargetCharacterSize size
,
978 ffetargetTypeless l
, mallocPool pool
)
980 unsigned long long int l1
;
981 unsigned long int l2
;
983 unsigned short int l4
;
988 if (((size_t) size
) >= sizeof (l1
))
992 size_of
= sizeof (l1
);
994 else if (((size_t) size
) >= sizeof (l2
))
998 size_of
= sizeof (l2
);
1001 else if (((size_t) size
) >= sizeof (l3
))
1005 size_of
= sizeof (l3
);
1008 else if (((size_t) size
) >= sizeof (l4
))
1012 size_of
= sizeof (l4
);
1015 else if (((size_t) size
) >= sizeof (l5
))
1019 size_of
= sizeof (l5
);
1024 assert ("stumped by conversion from typeless!" == NULL
);
1033 res
->text
= malloc_new_kp (pool
, "FFETARGET cvt char1", size
+ 1);
1034 res
->text
[size
] = '\0';
1035 if (((size_t) size
) <= size_of
)
1037 int i
= size_of
- size
;
1039 memcpy (res
->text
, p
+ i
, size
);
1040 for (; i
> 0; ++p
, --i
)
1042 return FFEBAD_TRUNCATING_TYPELESS
;
1046 int i
= size
- size_of
;
1048 memset (res
->text
, 0, i
);
1049 memcpy (res
->text
+ i
, p
, size_of
);
1054 return FFEBAD_TRUNCATING_TYPELESS
;
1059 /* ffetarget_divide_complex1 -- Divide function
1063 #if FFETARGET_okCOMPLEX1
1065 ffetarget_divide_complex1 (ffetargetComplex1
*res
, ffetargetComplex1 l
,
1066 ffetargetComplex1 r
)
1069 ffetargetReal1 tmp1
, tmp2
, tmp3
, tmp4
;
1071 bad
= ffetarget_multiply_real1 (&tmp1
, r
.real
, r
.real
);
1074 bad
= ffetarget_multiply_real1 (&tmp2
, r
.imaginary
, r
.imaginary
);
1077 bad
= ffetarget_add_real1 (&tmp3
, tmp1
, tmp2
);
1081 if (ffetarget_iszero_real1 (tmp3
))
1083 ffetarget_real1_zero (&(res
)->real
);
1084 ffetarget_real1_zero (&(res
)->imaginary
);
1085 return FFEBAD_DIV_BY_ZERO
;
1088 bad
= ffetarget_multiply_real1 (&tmp1
, l
.real
, r
.real
);
1091 bad
= ffetarget_multiply_real1 (&tmp2
, l
.imaginary
, r
.imaginary
);
1094 bad
= ffetarget_add_real1 (&tmp4
, tmp1
, tmp2
);
1097 bad
= ffetarget_divide_real1 (&res
->real
, tmp4
, tmp3
);
1101 bad
= ffetarget_multiply_real1 (&tmp1
, r
.real
, l
.imaginary
);
1104 bad
= ffetarget_multiply_real1 (&tmp2
, l
.real
, r
.imaginary
);
1107 bad
= ffetarget_subtract_real1 (&tmp4
, tmp1
, tmp2
);
1110 bad
= ffetarget_divide_real1 (&res
->imaginary
, tmp4
, tmp3
);
1116 /* ffetarget_divide_complex2 -- Divide function
1120 #if FFETARGET_okCOMPLEX2
1122 ffetarget_divide_complex2 (ffetargetComplex2
*res
, ffetargetComplex2 l
,
1123 ffetargetComplex2 r
)
1126 ffetargetReal2 tmp1
, tmp2
, tmp3
, tmp4
;
1128 bad
= ffetarget_multiply_real2 (&tmp1
, r
.real
, r
.real
);
1131 bad
= ffetarget_multiply_real2 (&tmp2
, r
.imaginary
, r
.imaginary
);
1134 bad
= ffetarget_add_real2 (&tmp3
, tmp1
, tmp2
);
1138 if (ffetarget_iszero_real2 (tmp3
))
1140 ffetarget_real2_zero (&(res
)->real
);
1141 ffetarget_real2_zero (&(res
)->imaginary
);
1142 return FFEBAD_DIV_BY_ZERO
;
1145 bad
= ffetarget_multiply_real2 (&tmp1
, l
.real
, r
.real
);
1148 bad
= ffetarget_multiply_real2 (&tmp2
, l
.imaginary
, r
.imaginary
);
1151 bad
= ffetarget_add_real2 (&tmp4
, tmp1
, tmp2
);
1154 bad
= ffetarget_divide_real2 (&res
->real
, tmp4
, tmp3
);
1158 bad
= ffetarget_multiply_real2 (&tmp1
, r
.real
, l
.imaginary
);
1161 bad
= ffetarget_multiply_real2 (&tmp2
, l
.real
, r
.imaginary
);
1164 bad
= ffetarget_subtract_real2 (&tmp4
, tmp1
, tmp2
);
1167 bad
= ffetarget_divide_real2 (&res
->imaginary
, tmp4
, tmp3
);
1173 /* ffetarget_hollerith -- Convert token to a hollerith constant
1175 Always append a null byte to the end, in case this is wanted in
1176 a special case such as passing a string as a FORMAT or %REF.
1177 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
1178 because it isn't a "feature" that is self-documenting. Use the
1179 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
1183 ffetarget_hollerith (ffetargetHollerith
*val
, ffelexToken integer
,
1186 val
->length
= ffelex_token_length (integer
);
1187 val
->text
= malloc_new_kp (pool
, "ffetargetHollerith", val
->length
+ 1);
1188 memcpy (val
->text
, ffelex_token_text (integer
), val
->length
);
1189 val
->text
[val
->length
] = '\0';
1194 /* ffetarget_integer_bad_magical -- Complain about a magical number
1196 Just calls ffebad with the arguments. */
1199 ffetarget_integer_bad_magical (ffelexToken t
)
1201 ffebad_start (FFEBAD_BAD_MAGICAL
);
1202 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
1206 /* ffetarget_integer_bad_magical_binary -- Complain about a magical number
1208 Just calls ffebad with the arguments. */
1211 ffetarget_integer_bad_magical_binary (ffelexToken integer
,
1214 ffebad_start (FFEBAD_BAD_MAGICAL_BINARY
);
1215 ffebad_here (0, ffelex_token_where_line (integer
),
1216 ffelex_token_where_column (integer
));
1217 ffebad_here (1, ffelex_token_where_line (minus
),
1218 ffelex_token_where_column (minus
));
1222 /* ffetarget_integer_bad_magical_precedence -- Complain about a magical
1225 Just calls ffebad with the arguments. */
1228 ffetarget_integer_bad_magical_precedence (ffelexToken integer
,
1230 ffelexToken higher_op
)
1232 ffebad_start (FFEBAD_BAD_MAGICAL_PRECEDENCE
);
1233 ffebad_here (0, ffelex_token_where_line (integer
),
1234 ffelex_token_where_column (integer
));
1235 ffebad_here (1, ffelex_token_where_line (uminus
),
1236 ffelex_token_where_column (uminus
));
1237 ffebad_here (2, ffelex_token_where_line (higher_op
),
1238 ffelex_token_where_column (higher_op
));
1242 /* ffetarget_integer_bad_magical_precedence_binary -- Complain...
1244 Just calls ffebad with the arguments. */
1247 ffetarget_integer_bad_magical_precedence_binary (ffelexToken integer
,
1249 ffelexToken higher_op
)
1251 ffebad_start (FFEBAD_BAD_MAGICAL_PRECEDENCE_BINARY
);
1252 ffebad_here (0, ffelex_token_where_line (integer
),
1253 ffelex_token_where_column (integer
));
1254 ffebad_here (1, ffelex_token_where_line (minus
),
1255 ffelex_token_where_column (minus
));
1256 ffebad_here (2, ffelex_token_where_line (higher_op
),
1257 ffelex_token_where_column (higher_op
));
1261 /* ffetarget_integer1 -- Convert token to an integer
1265 Token use count not affected overall. */
1267 #if FFETARGET_okINTEGER1
1269 ffetarget_integer1 (ffetargetInteger1
*val
, ffelexToken integer
)
1271 ffetargetInteger1 x
;
1275 assert (ffelex_token_type (integer
) == FFELEX_typeNUMBER
);
1277 p
= ffelex_token_text (integer
);
1280 /* Skip past leading zeros. */
1282 while (((c
= *p
) != '\0') && (c
== '0'))
1285 /* Interpret rest of number. */
1289 if ((x
== FFETARGET_integerALMOST_BIG_MAGICAL
)
1290 && (c
== '0' + FFETARGET_integerFINISH_BIG_MAGICAL
)
1291 && (*(p
+ 1) == '\0'))
1293 *val
= (ffetargetInteger1
) FFETARGET_integerBIG_MAGICAL
;
1296 else if (x
== FFETARGET_integerALMOST_BIG_MAGICAL
)
1298 if ((c
> '0' + FFETARGET_integerFINISH_BIG_MAGICAL
)
1299 || (*(p
+ 1) != '\0'))
1301 ffebad_start (FFEBAD_INTEGER_TOO_LARGE
);
1302 ffebad_here (0, ffelex_token_where_line (integer
),
1303 ffelex_token_where_column (integer
));
1309 else if (x
> FFETARGET_integerALMOST_BIG_MAGICAL
)
1311 ffebad_start (FFEBAD_INTEGER_TOO_LARGE
);
1312 ffebad_here (0, ffelex_token_where_line (integer
),
1313 ffelex_token_where_column (integer
));
1318 x
= x
* 10 + c
- '0';
1327 /* ffetarget_integerbinary -- Convert token to a binary integer
1329 ffetarget_integerbinary x;
1330 if (ffetarget_integerdefault_8(&x,integer_token))
1333 Token use count not affected overall. */
1336 ffetarget_integerbinary (ffetargetIntegerDefault
*val
, ffelexToken integer
)
1338 ffetargetIntegerDefault x
;
1343 assert ((ffelex_token_type (integer
) == FFELEX_typeNAME
)
1344 || (ffelex_token_type (integer
) == FFELEX_typeNUMBER
));
1346 p
= ffelex_token_text (integer
);
1349 /* Skip past leading zeros. */
1351 while (((c
= *p
) != '\0') && (c
== '0'))
1354 /* Interpret rest of number. */
1359 if ((c
>= '0') && (c
<= '1'))
1367 #if 0 /* Don't complain about signed overflow; just
1368 unsigned overflow. */
1369 if ((x
== FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY
)
1370 && (c
== FFETARGET_integerFINISH_BIG_OVERFLOW_BINARY
)
1371 && (*(p
+ 1) == '\0'))
1373 *val
= FFETARGET_integerBIG_OVERFLOW_BINARY
;
1378 #if FFETARGET_integerFINISH_BIG_OVERFLOW_BINARY == 0
1379 if ((x
& FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY
) != 0)
1381 if (x
== FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY
)
1383 if ((c
> FFETARGET_integerFINISH_BIG_OVERFLOW_BINARY
)
1384 || (*(p
+ 1) != '\0'))
1386 ffebad_start (FFEBAD_INTEGER_TOO_LARGE
);
1387 ffebad_here (0, ffelex_token_where_line (integer
),
1388 ffelex_token_where_column (integer
));
1394 else if (x
> FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY
)
1397 ffebad_start (FFEBAD_INTEGER_TOO_LARGE
);
1398 ffebad_here (0, ffelex_token_where_line (integer
),
1399 ffelex_token_where_column (integer
));
1410 ffebad_start (FFEBAD_INVALID_BINARY_DIGIT
);
1411 ffebad_here (0, ffelex_token_where_line (integer
),
1412 ffelex_token_where_column (integer
));
1420 /* ffetarget_integerhex -- Convert token to a hex integer
1422 ffetarget_integerhex x;
1423 if (ffetarget_integerdefault_8(&x,integer_token))
1426 Token use count not affected overall. */
1429 ffetarget_integerhex (ffetargetIntegerDefault
*val
, ffelexToken integer
)
1431 ffetargetIntegerDefault x
;
1436 assert ((ffelex_token_type (integer
) == FFELEX_typeNAME
)
1437 || (ffelex_token_type (integer
) == FFELEX_typeNUMBER
));
1439 p
= ffelex_token_text (integer
);
1442 /* Skip past leading zeros. */
1444 while (((c
= *p
) != '\0') && (c
== '0'))
1447 /* Interpret rest of number. */
1460 #if 0 /* Don't complain about signed overflow; just
1461 unsigned overflow. */
1462 if ((x
== FFETARGET_integerALMOST_BIG_OVERFLOW_HEX
)
1463 && (c
== FFETARGET_integerFINISH_BIG_OVERFLOW_HEX
)
1464 && (*(p
+ 1) == '\0'))
1466 *val
= FFETARGET_integerBIG_OVERFLOW_HEX
;
1471 #if FFETARGET_integerFINISH_BIG_OVERFLOW_HEX == 0
1472 if (x
>= FFETARGET_integerALMOST_BIG_OVERFLOW_HEX
)
1474 if (x
== FFETARGET_integerALMOST_BIG_OVERFLOW_HEX
)
1476 if ((c
> FFETARGET_integerFINISH_BIG_OVERFLOW_HEX
)
1477 || (*(p
+ 1) != '\0'))
1479 ffebad_start (FFEBAD_INTEGER_TOO_LARGE
);
1480 ffebad_here (0, ffelex_token_where_line (integer
),
1481 ffelex_token_where_column (integer
));
1487 else if (x
> FFETARGET_integerALMOST_BIG_OVERFLOW_HEX
)
1490 ffebad_start (FFEBAD_INTEGER_TOO_LARGE
);
1491 ffebad_here (0, ffelex_token_where_line (integer
),
1492 ffelex_token_where_column (integer
));
1503 ffebad_start (FFEBAD_INVALID_HEX_DIGIT
);
1504 ffebad_here (0, ffelex_token_where_line (integer
),
1505 ffelex_token_where_column (integer
));
1513 /* ffetarget_integeroctal -- Convert token to an octal integer
1515 ffetarget_integeroctal x;
1516 if (ffetarget_integerdefault_8(&x,integer_token))
1519 Token use count not affected overall. */
1522 ffetarget_integeroctal (ffetargetIntegerDefault
*val
, ffelexToken integer
)
1524 ffetargetIntegerDefault x
;
1529 assert ((ffelex_token_type (integer
) == FFELEX_typeNAME
)
1530 || (ffelex_token_type (integer
) == FFELEX_typeNUMBER
));
1532 p
= ffelex_token_text (integer
);
1535 /* Skip past leading zeros. */
1537 while (((c
= *p
) != '\0') && (c
== '0'))
1540 /* Interpret rest of number. */
1545 if ((c
>= '0') && (c
<= '7'))
1553 #if 0 /* Don't complain about signed overflow; just
1554 unsigned overflow. */
1555 if ((x
== FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL
)
1556 && (c
== FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL
)
1557 && (*(p
+ 1) == '\0'))
1559 *val
= FFETARGET_integerBIG_OVERFLOW_OCTAL
;
1564 #if FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL == 0
1565 if (x
>= FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL
)
1567 if (x
== FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL
)
1569 if ((c
> FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL
)
1570 || (*(p
+ 1) != '\0'))
1572 ffebad_start (FFEBAD_INTEGER_TOO_LARGE
);
1573 ffebad_here (0, ffelex_token_where_line (integer
),
1574 ffelex_token_where_column (integer
));
1580 else if (x
> FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL
)
1583 ffebad_start (FFEBAD_INTEGER_TOO_LARGE
);
1584 ffebad_here (0, ffelex_token_where_line (integer
),
1585 ffelex_token_where_column (integer
));
1596 ffebad_start (FFEBAD_INVALID_OCTAL_DIGIT
);
1597 ffebad_here (0, ffelex_token_where_line (integer
),
1598 ffelex_token_where_column (integer
));
1606 /* ffetarget_multiply_complex1 -- Multiply function
1610 #if FFETARGET_okCOMPLEX1
1612 ffetarget_multiply_complex1 (ffetargetComplex1
*res
, ffetargetComplex1 l
,
1613 ffetargetComplex1 r
)
1616 ffetargetReal1 tmp1
, tmp2
;
1618 bad
= ffetarget_multiply_real1 (&tmp1
, l
.real
, r
.real
);
1621 bad
= ffetarget_multiply_real1 (&tmp2
, l
.imaginary
, r
.imaginary
);
1624 bad
= ffetarget_subtract_real1 (&res
->real
, tmp1
, tmp2
);
1627 bad
= ffetarget_multiply_real1 (&tmp1
, l
.imaginary
, r
.real
);
1630 bad
= ffetarget_multiply_real1 (&tmp2
, l
.real
, r
.imaginary
);
1633 bad
= ffetarget_add_real1 (&res
->imaginary
, tmp1
, tmp2
);
1639 /* ffetarget_multiply_complex2 -- Multiply function
1643 #if FFETARGET_okCOMPLEX2
1645 ffetarget_multiply_complex2 (ffetargetComplex2
*res
, ffetargetComplex2 l
,
1646 ffetargetComplex2 r
)
1649 ffetargetReal2 tmp1
, tmp2
;
1651 bad
= ffetarget_multiply_real2 (&tmp1
, l
.real
, r
.real
);
1654 bad
= ffetarget_multiply_real2 (&tmp2
, l
.imaginary
, r
.imaginary
);
1657 bad
= ffetarget_subtract_real2 (&res
->real
, tmp1
, tmp2
);
1660 bad
= ffetarget_multiply_real2 (&tmp1
, l
.imaginary
, r
.real
);
1663 bad
= ffetarget_multiply_real2 (&tmp2
, l
.real
, r
.imaginary
);
1666 bad
= ffetarget_add_real2 (&res
->imaginary
, tmp1
, tmp2
);
1672 /* ffetarget_power_complexdefault_integerdefault -- Power function
1677 ffetarget_power_complexdefault_integerdefault (ffetargetComplexDefault
*res
,
1678 ffetargetComplexDefault l
,
1679 ffetargetIntegerDefault r
)
1682 ffetargetRealDefault tmp
;
1683 ffetargetRealDefault tmp1
;
1684 ffetargetRealDefault tmp2
;
1685 ffetargetRealDefault two
;
1687 if (ffetarget_iszero_real1 (l
.real
)
1688 && ffetarget_iszero_real1 (l
.imaginary
))
1690 ffetarget_real1_zero (&res
->real
);
1691 ffetarget_real1_zero (&res
->imaginary
);
1697 ffetarget_real1_one (&res
->real
);
1698 ffetarget_real1_zero (&res
->imaginary
);
1705 bad
= ffetarget_multiply_real1 (&tmp1
, l
.real
, l
.real
);
1708 bad
= ffetarget_multiply_real1 (&tmp2
, l
.imaginary
, l
.imaginary
);
1711 bad
= ffetarget_add_real1 (&tmp
, tmp1
, tmp2
);
1714 bad
= ffetarget_divide_real1 (&l
.real
, l
.real
, tmp
);
1717 bad
= ffetarget_divide_real1 (&l
.imaginary
, l
.imaginary
, tmp
);
1720 bad
= ffetarget_uminus_real1 (&l
.imaginary
, l
.imaginary
);
1725 ffetarget_real1_two (&two
);
1727 while ((r
& 1) == 0)
1729 bad
= ffetarget_multiply_real1 (&tmp1
, l
.real
, l
.real
);
1732 bad
= ffetarget_multiply_real1 (&tmp2
, l
.imaginary
, l
.imaginary
);
1735 bad
= ffetarget_subtract_real1 (&tmp
, tmp1
, tmp2
);
1738 bad
= ffetarget_multiply_real1 (&l
.imaginary
, l
.real
, l
.imaginary
);
1741 bad
= ffetarget_multiply_real1 (&l
.imaginary
, l
.imaginary
, two
);
1753 bad
= ffetarget_multiply_real1 (&tmp1
, l
.real
, l
.real
);
1756 bad
= ffetarget_multiply_real1 (&tmp2
, l
.imaginary
, l
.imaginary
);
1759 bad
= ffetarget_subtract_real1 (&tmp
, tmp1
, tmp2
);
1762 bad
= ffetarget_multiply_real1 (&l
.imaginary
, l
.real
, l
.imaginary
);
1765 bad
= ffetarget_multiply_real1 (&l
.imaginary
, l
.imaginary
, two
);
1771 bad
= ffetarget_multiply_real1 (&tmp1
, res
->real
, l
.real
);
1774 bad
= ffetarget_multiply_real1 (&tmp2
, res
->imaginary
,
1778 bad
= ffetarget_subtract_real1 (&tmp
, tmp1
, tmp2
);
1781 bad
= ffetarget_multiply_real1 (&tmp1
, res
->imaginary
, l
.real
);
1784 bad
= ffetarget_multiply_real1 (&tmp2
, res
->real
, l
.imaginary
);
1787 bad
= ffetarget_add_real1 (&res
->imaginary
, tmp1
, tmp2
);
1798 /* ffetarget_power_complexdouble_integerdefault -- Power function
1802 #if FFETARGET_okCOMPLEXDOUBLE
1804 ffetarget_power_complexdouble_integerdefault (ffetargetComplexDouble
*res
,
1805 ffetargetComplexDouble l
, ffetargetIntegerDefault r
)
1808 ffetargetRealDouble tmp
;
1809 ffetargetRealDouble tmp1
;
1810 ffetargetRealDouble tmp2
;
1811 ffetargetRealDouble two
;
1813 if (ffetarget_iszero_real2 (l
.real
)
1814 && ffetarget_iszero_real2 (l
.imaginary
))
1816 ffetarget_real2_zero (&res
->real
);
1817 ffetarget_real2_zero (&res
->imaginary
);
1823 ffetarget_real2_one (&res
->real
);
1824 ffetarget_real2_zero (&res
->imaginary
);
1831 bad
= ffetarget_multiply_real2 (&tmp1
, l
.real
, l
.real
);
1834 bad
= ffetarget_multiply_real2 (&tmp2
, l
.imaginary
, l
.imaginary
);
1837 bad
= ffetarget_add_real2 (&tmp
, tmp1
, tmp2
);
1840 bad
= ffetarget_divide_real2 (&l
.real
, l
.real
, tmp
);
1843 bad
= ffetarget_divide_real2 (&l
.imaginary
, l
.imaginary
, tmp
);
1846 bad
= ffetarget_uminus_real2 (&l
.imaginary
, l
.imaginary
);
1851 ffetarget_real2_two (&two
);
1853 while ((r
& 1) == 0)
1855 bad
= ffetarget_multiply_real2 (&tmp1
, l
.real
, l
.real
);
1858 bad
= ffetarget_multiply_real2 (&tmp2
, l
.imaginary
, l
.imaginary
);
1861 bad
= ffetarget_subtract_real2 (&tmp
, tmp1
, tmp2
);
1864 bad
= ffetarget_multiply_real2 (&l
.imaginary
, l
.real
, l
.imaginary
);
1867 bad
= ffetarget_multiply_real2 (&l
.imaginary
, l
.imaginary
, two
);
1879 bad
= ffetarget_multiply_real2 (&tmp1
, l
.real
, l
.real
);
1882 bad
= ffetarget_multiply_real2 (&tmp2
, l
.imaginary
, l
.imaginary
);
1885 bad
= ffetarget_subtract_real2 (&tmp
, tmp1
, tmp2
);
1888 bad
= ffetarget_multiply_real2 (&l
.imaginary
, l
.real
, l
.imaginary
);
1891 bad
= ffetarget_multiply_real2 (&l
.imaginary
, l
.imaginary
, two
);
1897 bad
= ffetarget_multiply_real2 (&tmp1
, res
->real
, l
.real
);
1900 bad
= ffetarget_multiply_real2 (&tmp2
, res
->imaginary
,
1904 bad
= ffetarget_subtract_real2 (&tmp
, tmp1
, tmp2
);
1907 bad
= ffetarget_multiply_real2 (&tmp1
, res
->imaginary
, l
.real
);
1910 bad
= ffetarget_multiply_real2 (&tmp2
, res
->real
, l
.imaginary
);
1913 bad
= ffetarget_add_real2 (&res
->imaginary
, tmp1
, tmp2
);
1925 /* ffetarget_power_integerdefault_integerdefault -- Power function
1930 ffetarget_power_integerdefault_integerdefault (ffetargetIntegerDefault
*res
,
1931 ffetargetIntegerDefault l
, ffetargetIntegerDefault r
)
1952 *res
= ((-r
) & 1) == 0 ? 1 : -1;
1958 while ((r
& 1) == 0)
1978 /* ffetarget_power_realdefault_integerdefault -- Power function
1983 ffetarget_power_realdefault_integerdefault (ffetargetRealDefault
*res
,
1984 ffetargetRealDefault l
, ffetargetIntegerDefault r
)
1988 if (ffetarget_iszero_real1 (l
))
1990 ffetarget_real1_zero (res
);
1996 ffetarget_real1_one (res
);
2002 ffetargetRealDefault one
;
2004 ffetarget_real1_one (&one
);
2006 bad
= ffetarget_divide_real1 (&l
, one
, l
);
2011 while ((r
& 1) == 0)
2013 bad
= ffetarget_multiply_real1 (&l
, l
, l
);
2024 bad
= ffetarget_multiply_real1 (&l
, l
, l
);
2029 bad
= ffetarget_multiply_real1 (res
, *res
, l
);
2039 /* ffetarget_power_realdouble_integerdefault -- Power function
2044 ffetarget_power_realdouble_integerdefault (ffetargetRealDouble
*res
,
2045 ffetargetRealDouble l
,
2046 ffetargetIntegerDefault r
)
2050 if (ffetarget_iszero_real2 (l
))
2052 ffetarget_real2_zero (res
);
2058 ffetarget_real2_one (res
);
2064 ffetargetRealDouble one
;
2066 ffetarget_real2_one (&one
);
2068 bad
= ffetarget_divide_real2 (&l
, one
, l
);
2073 while ((r
& 1) == 0)
2075 bad
= ffetarget_multiply_real2 (&l
, l
, l
);
2086 bad
= ffetarget_multiply_real2 (&l
, l
, l
);
2091 bad
= ffetarget_multiply_real2 (res
, *res
, l
);
2101 /* ffetarget_print_binary -- Output typeless binary integer
2103 ffetargetTypeless val;
2104 ffetarget_typeless_binary(dmpout,val); */
2107 ffetarget_print_binary (FILE *f
, ffetargetTypeless value
)
2110 char digits
[sizeof (value
) * CHAR_BIT
+ 1];
2115 p
= &digits
[ARRAY_SIZE (digits
) - 1];
2119 *--p
= (value
& 1) + '0';
2121 } while (value
== 0);
2126 /* ffetarget_print_character1 -- Output character string
2128 ffetargetCharacter1 val;
2129 ffetarget_print_character1(dmpout,val); */
2132 ffetarget_print_character1 (FILE *f
, ffetargetCharacter1 value
)
2135 ffetargetCharacterSize i
;
2137 fputc ('\'', dmpout
);
2138 for (i
= 0, p
= value
.text
; i
< value
.length
; ++i
, ++p
)
2139 ffetarget_print_char_ (f
, *p
);
2140 fputc ('\'', dmpout
);
2143 /* ffetarget_print_hollerith -- Output hollerith string
2145 ffetargetHollerith val;
2146 ffetarget_print_hollerith(dmpout,val); */
2149 ffetarget_print_hollerith (FILE *f
, ffetargetHollerith value
)
2152 ffetargetHollerithSize i
;
2154 fputc ('\'', dmpout
);
2155 for (i
= 0, p
= value
.text
; i
< value
.length
; ++i
, ++p
)
2156 ffetarget_print_char_ (f
, *p
);
2157 fputc ('\'', dmpout
);
2160 /* ffetarget_print_octal -- Output typeless octal integer
2162 ffetargetTypeless val;
2163 ffetarget_print_octal(dmpout,val); */
2166 ffetarget_print_octal (FILE *f
, ffetargetTypeless value
)
2169 char digits
[sizeof (value
) * CHAR_BIT
/ 3 + 1];
2174 p
= &digits
[ARRAY_SIZE (digits
) - 3];
2178 *--p
= (value
& 3) + '0';
2180 } while (value
== 0);
2185 /* ffetarget_print_hex -- Output typeless hex integer
2187 ffetargetTypeless val;
2188 ffetarget_print_hex(dmpout,val); */
2191 ffetarget_print_hex (FILE *f
, ffetargetTypeless value
)
2194 char digits
[sizeof (value
) * CHAR_BIT
/ 4 + 1];
2195 static const char hexdigits
[16] = "0123456789ABCDEF";
2200 p
= &digits
[ARRAY_SIZE (digits
) - 3];
2204 *--p
= hexdigits
[value
& 4];
2206 } while (value
== 0);
2211 /* ffetarget_real1 -- Convert token to a single-precision real number
2215 Pass NULL for any token not provided by the user, but a valid Fortran
2216 real number must be provided somehow. For example, it is ok for
2217 exponent_sign_token and exponent_digits_token to be NULL as long as
2218 exponent_token not only starts with "E" or "e" but also contains at least
2219 one digit following it. Token use counts not affected overall. */
2221 #if FFETARGET_okREAL1
2223 ffetarget_real1 (ffetargetReal1
*value
, ffelexToken integer
,
2224 ffelexToken decimal
, ffelexToken fraction
,
2225 ffelexToken exponent
, ffelexToken exponent_sign
,
2226 ffelexToken exponent_digits
)
2228 size_t sz
= 1; /* Allow room for '\0' byte at end. */
2229 char *ptr
= &ffetarget_string_
[0];
2233 #define dotok(x) if (x != NULL) ++sz;
2234 #define dotoktxt(x) if (x != NULL) sz += ffelex_token_length(x)
2238 dotoktxt (fraction
);
2239 dotoktxt (exponent
);
2240 dotok (exponent_sign
);
2241 dotoktxt (exponent_digits
);
2246 if (sz
> ARRAY_SIZE (ffetarget_string_
))
2247 p
= ptr
= (char *) malloc_new_ks (malloc_pool_image (), "ffetarget_real1",
2250 #define dotoktxt(x) if (x != NULL) \
2252 for (q = ffelex_token_text(x); *q != '\0'; ++q) \
2258 if (decimal
!= NULL
)
2261 dotoktxt (fraction
);
2262 dotoktxt (exponent
);
2264 if (exponent_sign
!= NULL
)
2266 if (ffelex_token_type (exponent_sign
) == FFELEX_typePLUS
)
2270 assert (ffelex_token_type (exponent_sign
) == FFELEX_typeMINUS
);
2275 dotoktxt (exponent_digits
);
2283 rv
= FFETARGET_ATOF_ (ptr
, SFmode
);
2284 ffetarget_make_real1 (value
, rv
);
2287 if (sz
> ARRAY_SIZE (ffetarget_string_
))
2288 malloc_kill_ks (malloc_pool_image (), ptr
, sz
);
2294 /* ffetarget_real2 -- Convert token to a single-precision real number
2298 Pass NULL for any token not provided by the user, but a valid Fortran
2299 real number must be provided somehow. For example, it is ok for
2300 exponent_sign_token and exponent_digits_token to be NULL as long as
2301 exponent_token not only starts with "E" or "e" but also contains at least
2302 one digit following it. Token use counts not affected overall. */
2304 #if FFETARGET_okREAL2
2306 ffetarget_real2 (ffetargetReal2
*value
, ffelexToken integer
,
2307 ffelexToken decimal
, ffelexToken fraction
,
2308 ffelexToken exponent
, ffelexToken exponent_sign
,
2309 ffelexToken exponent_digits
)
2311 size_t sz
= 1; /* Allow room for '\0' byte at end. */
2312 char *ptr
= &ffetarget_string_
[0];
2316 #define dotok(x) if (x != NULL) ++sz;
2317 #define dotoktxt(x) if (x != NULL) sz += ffelex_token_length(x)
2321 dotoktxt (fraction
);
2322 dotoktxt (exponent
);
2323 dotok (exponent_sign
);
2324 dotoktxt (exponent_digits
);
2329 if (sz
> ARRAY_SIZE (ffetarget_string_
))
2330 p
= ptr
= (char *) malloc_new_ks (malloc_pool_image (), "ffetarget_real1", sz
);
2332 #define dotoktxt(x) if (x != NULL) \
2334 for (q = ffelex_token_text(x); *q != '\0'; ++q) \
2337 #define dotoktxtexp(x) if (x != NULL) \
2340 for (q = ffelex_token_text(x) + 1; *q != '\0'; ++q) \
2346 if (decimal
!= NULL
)
2349 dotoktxt (fraction
);
2350 dotoktxtexp (exponent
);
2352 if (exponent_sign
!= NULL
)
2354 if (ffelex_token_type (exponent_sign
) == FFELEX_typePLUS
)
2358 assert (ffelex_token_type (exponent_sign
) == FFELEX_typeMINUS
);
2363 dotoktxt (exponent_digits
);
2371 rv
= FFETARGET_ATOF_ (ptr
, DFmode
);
2372 ffetarget_make_real2 (value
, rv
);
2375 if (sz
> ARRAY_SIZE (ffetarget_string_
))
2376 malloc_kill_ks (malloc_pool_image (), ptr
, sz
);
2383 ffetarget_typeless_binary (ffetargetTypeless
*xvalue
, ffelexToken token
)
2387 ffetargetTypeless value
= 0;
2388 ffetargetTypeless new_value
= 0;
2389 bool bad_digit
= FALSE
;
2390 bool overflow
= FALSE
;
2392 p
= ffelex_token_text (token
);
2394 for (c
= *p
; c
!= '\0'; c
= *++p
)
2397 if ((new_value
>> 1) != value
)
2400 new_value
+= c
- '0';
2408 ffebad_start (FFEBAD_INVALID_TYPELESS_BINARY_DIGIT
);
2409 ffebad_here (0, ffelex_token_where_line (token
),
2410 ffelex_token_where_column (token
));
2415 ffebad_start (FFEBAD_TYPELESS_OVERFLOW
);
2416 ffebad_here (0, ffelex_token_where_line (token
),
2417 ffelex_token_where_column (token
));
2423 return !bad_digit
&& !overflow
;
2427 ffetarget_typeless_octal (ffetargetTypeless
*xvalue
, ffelexToken token
)
2431 ffetargetTypeless value
= 0;
2432 ffetargetTypeless new_value
= 0;
2433 bool bad_digit
= FALSE
;
2434 bool overflow
= FALSE
;
2436 p
= ffelex_token_text (token
);
2438 for (c
= *p
; c
!= '\0'; c
= *++p
)
2441 if ((new_value
>> 3) != value
)
2444 new_value
+= c
- '0';
2452 ffebad_start (FFEBAD_INVALID_TYPELESS_OCTAL_DIGIT
);
2453 ffebad_here (0, ffelex_token_where_line (token
),
2454 ffelex_token_where_column (token
));
2459 ffebad_start (FFEBAD_TYPELESS_OVERFLOW
);
2460 ffebad_here (0, ffelex_token_where_line (token
),
2461 ffelex_token_where_column (token
));
2467 return !bad_digit
&& !overflow
;
2471 ffetarget_typeless_hex (ffetargetTypeless
*xvalue
, ffelexToken token
)
2475 ffetargetTypeless value
= 0;
2476 ffetargetTypeless new_value
= 0;
2477 bool bad_digit
= FALSE
;
2478 bool overflow
= FALSE
;
2480 p
= ffelex_token_text (token
);
2482 for (c
= *p
; c
!= '\0'; c
= *++p
)
2485 if ((new_value
>> 4) != value
)
2488 new_value
+= hex_value (c
);
2496 ffebad_start (FFEBAD_INVALID_TYPELESS_HEX_DIGIT
);
2497 ffebad_here (0, ffelex_token_where_line (token
),
2498 ffelex_token_where_column (token
));
2503 ffebad_start (FFEBAD_TYPELESS_OVERFLOW
);
2504 ffebad_here (0, ffelex_token_where_line (token
),
2505 ffelex_token_where_column (token
));
2511 return !bad_digit
&& !overflow
;
2515 ffetarget_verify_character1 (mallocPool pool
, ffetargetCharacter1 val
)
2517 if (val
.length
!= 0)
2518 malloc_verify_kp (pool
, val
.text
, val
.length
);
2521 /* This is like memcpy. It is needed because some systems' header files
2522 don't declare memcpy as a function but instead
2523 "#define memcpy(to,from,len) something". */
2526 ffetarget_memcpy_ (void *dst
, void *src
, size_t len
)
2528 #ifdef CROSS_COMPILE
2529 /* HOST_WORDS_BIG_ENDIAN corresponds to both WORDS_BIG_ENDIAN and
2530 BYTES_BIG_ENDIAN (i.e. there are no HOST_ macros to represent a
2531 difference in the two latter). */
2532 int host_words_big_endian
=
2533 #ifndef HOST_WORDS_BIG_ENDIAN
2536 HOST_WORDS_BIG_ENDIAN
2540 /* This is just hands thrown up in the air over bits coming through this
2541 function representing a number being memcpy:d as-is from host to
2542 target. We can't generally adjust endianness here since we don't
2543 know whether it's an integer or floating point number; they're passed
2544 differently. Better to not emit code at all than to emit wrong code.
2545 We will get some false hits because some data coming through here
2546 seems to be just character vectors, but often enough it's numbers,
2547 for instance in g77.f-torture/execute/980628-[4-6].f and alpha2.f.
2548 Still, we compile *some* code. FIXME: Rewrite handling of numbers. */
2549 if (!WORDS_BIG_ENDIAN
!= !host_words_big_endian
2550 || !BYTES_BIG_ENDIAN
!= !host_words_big_endian
)
2551 sorry ("data initializer on host with different endianness");
2553 #endif /* CROSS_COMPILE */
2555 return (void *) memcpy (dst
, src
, len
);
2558 /* ffetarget_num_digits_ -- Determine number of non-space characters in token
2560 ffetarget_num_digits_(token);
2562 All non-spaces are assumed to be binary, octal, or hex digits. */
2565 ffetarget_num_digits_ (ffelexToken token
)
2570 switch (ffelex_token_type (token
))
2572 case FFELEX_typeNAME
:
2573 case FFELEX_typeNUMBER
:
2574 return ffelex_token_length (token
);
2576 case FFELEX_typeCHARACTER
:
2578 for (c
= ffelex_token_text (token
); *c
!= '\0'; ++c
)
2586 assert ("weird token" == NULL
);