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. */
110 /* ffetarget_print_char_ -- Print a single character (in apostrophe context)
114 Outputs char so it prints or is escaped C style. */
117 ffetarget_print_char_ (FILE *f
, unsigned char c
)
133 fprintf (f
, "\\%03o", (unsigned int) c
);
138 /* ffetarget_aggregate_info -- Determine type for aggregate storage area
142 If aggregate type is distinct, just return it. Else return a type
143 representing a common denominator for the nondistinct type (for now,
144 just return default character, since that'll work on almost all target
147 The rules for abt/akt are (as implemented by ffestorag_update):
149 abt == FFEINFO_basictypeANY (akt == FFEINFO_kindtypeANY also, by
150 definition): CHARACTER and non-CHARACTER types mixed.
152 abt == FFEINFO_basictypeNONE (akt == FFEINFO_kindtypeNONE also, by
153 definition): More than one non-CHARACTER type mixed, but no CHARACTER
156 abt some other value, akt == FFEINFO_kindtypeNONE: abt indicates the
157 only basic type mixed in, but more than one kind type is mixed in.
159 abt some other value, akt some other value: abt and akt indicate the
160 only type represented in the aggregation. */
163 ffetarget_aggregate_info (ffeinfoBasictype
*ebt
, ffeinfoKindtype
*ekt
,
164 ffetargetAlign
*units
, ffeinfoBasictype abt
,
169 if ((abt
== FFEINFO_basictypeNONE
) || (abt
== FFEINFO_basictypeANY
)
170 || (akt
== FFEINFO_kindtypeNONE
))
172 *ebt
= FFEINFO_basictypeCHARACTER
;
173 *ekt
= FFEINFO_kindtypeCHARACTERDEFAULT
;
181 type
= ffeinfo_type (*ebt
, *ekt
);
182 assert (type
!= NULL
);
184 *units
= ffetype_size (type
);
187 /* ffetarget_align -- Align one storage area to superordinate, update super
191 updated_alignment/updated_modulo contain the already existing
192 alignment requirements for the storage area at whose offset the
193 object with alignment requirements alignment/modulo is to be placed.
194 Find the smallest pad such that the requirements are maintained and
195 return it, but only after updating the updated_alignment/_modulo
196 requirements as necessary to indicate the placement of the new object. */
199 ffetarget_align (ffetargetAlign
*updated_alignment
,
200 ffetargetAlign
*updated_modulo
, ffetargetOffset offset
,
201 ffetargetAlign alignment
, ffetargetAlign modulo
)
204 ffetargetAlign min_pad
; /* Minimum amount of padding needed. */
205 ffetargetAlign min_m
= 0; /* Minimum-padding m. */
206 ffetargetAlign ua
; /* Updated alignment. */
207 ffetargetAlign um
; /* Updated modulo. */
208 ffetargetAlign ucnt
; /* Multiplier applied to ua. */
209 ffetargetAlign m
; /* Copy of modulo. */
210 ffetargetAlign cnt
; /* Multiplier applied to alignment. */
214 assert (alignment
> 0);
215 assert (*updated_alignment
> 0);
217 assert (*updated_modulo
< *updated_alignment
);
218 assert (modulo
< alignment
);
220 /* The easy case: similar alignment requirements. */
221 if (*updated_alignment
== alignment
)
223 if (modulo
> *updated_modulo
)
224 pad
= alignment
- (modulo
- *updated_modulo
);
226 pad
= *updated_modulo
- modulo
;
228 /* De-negatize offset, since % wouldn't do the expected thing. */
229 offset
= alignment
- ((- offset
) % alignment
);
230 pad
= (offset
+ pad
) % alignment
;
232 pad
= alignment
- pad
;
236 /* Sigh, find LCM (Least Common Multiple) for the two alignment factors. */
238 for (ua
= *updated_alignment
, ucnt
= 1;
240 ua
+= *updated_alignment
)
243 cnt
= ua
/ alignment
;
246 /* De-negatize offset, since % wouldn't do the expected thing. */
247 offset
= ua
- ((- offset
) % ua
);
249 /* Set to largest value. */
250 min_pad
= ~(ffetargetAlign
) 0;
252 /* Find all combinations of modulo values the two alignment requirements
253 have; pick the combination that results in the smallest padding
254 requirement. Of course, if a zero-pad requirement is encountered, just
257 for (um
= *updated_modulo
, i
= 0; i
< ucnt
; um
+= *updated_alignment
, ++i
)
259 for (m
= modulo
, j
= 0; j
< cnt
; m
+= alignment
, ++j
)
261 /* This code is similar to the "easy case" code above. */
266 pad
= (offset
+ pad
) % ua
;
269 /* A zero pad means we've got something useful. */
270 *updated_alignment
= ua
;
271 *updated_modulo
= um
;
276 { /* New minimum padding value. */
283 *updated_alignment
= ua
;
284 *updated_modulo
= min_m
;
288 /* Always append a null byte to the end, in case this is wanted in
289 a special case such as passing a string as a FORMAT or %REF.
290 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
291 because it isn't a "feature" that is self-documenting. Use the
292 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
295 #if FFETARGET_okCHARACTER1
297 ffetarget_character1 (ffetargetCharacter1
*val
, ffelexToken character
,
300 val
->length
= ffelex_token_length (character
);
301 if (val
->length
== 0)
305 val
->text
= malloc_new_kp (pool
, "ffetargetCharacter1", val
->length
+ 1);
306 memcpy (val
->text
, ffelex_token_text (character
), val
->length
);
307 val
->text
[val
->length
] = '\0';
314 /* Produce orderable comparison between two constants
316 Compare lengths, if equal then use memcmp. */
318 #if FFETARGET_okCHARACTER1
320 ffetarget_cmp_character1 (ffetargetCharacter1 l
, ffetargetCharacter1 r
)
322 if (l
.length
< r
.length
)
324 if (l
.length
> r
.length
)
328 return memcmp (l
.text
, r
.text
, l
.length
);
332 /* ffetarget_concatenate_character1 -- Perform CONCAT op on two constants
334 Always append a null byte to the end, in case this is wanted in
335 a special case such as passing a string as a FORMAT or %REF.
336 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
337 because it isn't a "feature" that is self-documenting. Use the
338 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
341 #if FFETARGET_okCHARACTER1
343 ffetarget_concatenate_character1 (ffetargetCharacter1
*res
,
344 ffetargetCharacter1 l
, ffetargetCharacter1 r
, mallocPool pool
,
345 ffetargetCharacterSize
*len
)
347 res
->length
= *len
= l
.length
+ r
.length
;
352 res
->text
= malloc_new_kp (pool
, "ffetargetCharacter1(CONCAT)", *len
+ 1);
354 memcpy (res
->text
, l
.text
, l
.length
);
356 memcpy (res
->text
+ l
.length
, r
.text
, r
.length
);
357 res
->text
[*len
] = '\0';
364 /* ffetarget_eq_character1 -- Perform relational comparison on char constants
366 Compare lengths, if equal then use memcmp. */
368 #if FFETARGET_okCHARACTER1
370 ffetarget_eq_character1 (bool *res
, ffetargetCharacter1 l
,
371 ffetargetCharacter1 r
)
373 assert (l
.length
== r
.length
);
374 *res
= (memcmp (l
.text
, r
.text
, l
.length
) == 0);
379 /* ffetarget_le_character1 -- Perform relational comparison on char constants
381 Compare lengths, if equal then use memcmp. */
383 #if FFETARGET_okCHARACTER1
385 ffetarget_le_character1 (bool *res
, ffetargetCharacter1 l
,
386 ffetargetCharacter1 r
)
388 assert (l
.length
== r
.length
);
389 *res
= (memcmp (l
.text
, r
.text
, l
.length
) <= 0);
394 /* ffetarget_lt_character1 -- Perform relational comparison on char constants
396 Compare lengths, if equal then use memcmp. */
398 #if FFETARGET_okCHARACTER1
400 ffetarget_lt_character1 (bool *res
, ffetargetCharacter1 l
,
401 ffetargetCharacter1 r
)
403 assert (l
.length
== r
.length
);
404 *res
= (memcmp (l
.text
, r
.text
, l
.length
) < 0);
409 /* ffetarget_ge_character1 -- Perform relational comparison on char constants
411 Compare lengths, if equal then use memcmp. */
413 #if FFETARGET_okCHARACTER1
415 ffetarget_ge_character1 (bool *res
, ffetargetCharacter1 l
,
416 ffetargetCharacter1 r
)
418 assert (l
.length
== r
.length
);
419 *res
= (memcmp (l
.text
, r
.text
, l
.length
) >= 0);
424 /* ffetarget_gt_character1 -- Perform relational comparison on char constants
426 Compare lengths, if equal then use memcmp. */
428 #if FFETARGET_okCHARACTER1
430 ffetarget_gt_character1 (bool *res
, ffetargetCharacter1 l
,
431 ffetargetCharacter1 r
)
433 assert (l
.length
== r
.length
);
434 *res
= (memcmp (l
.text
, r
.text
, l
.length
) > 0);
439 #if FFETARGET_okCHARACTER1
441 ffetarget_iszero_character1 (ffetargetCharacter1 constant
)
443 ffetargetCharacterSize i
;
445 for (i
= 0; i
< constant
.length
; ++i
)
446 if (constant
.text
[i
] != 0)
453 ffetarget_iszero_hollerith (ffetargetHollerith constant
)
455 ffetargetHollerithSize i
;
457 for (i
= 0; i
< constant
.length
; ++i
)
458 if (constant
.text
[i
] != 0)
463 /* ffetarget_layout -- Do storage requirement analysis for entity
465 Return the alignment/modulo requirements along with the size, given the
466 data type info and the number of elements an array (1 for a scalar). */
469 ffetarget_layout (const char *error_text UNUSED
, ffetargetAlign
*alignment
,
470 ffetargetAlign
*modulo
, ffetargetOffset
*size
,
471 ffeinfoBasictype bt
, ffeinfoKindtype kt
,
472 ffetargetCharacterSize charsize
,
473 ffetargetIntegerDefault num_elements
)
475 bool ok
; /* For character type. */
476 ffetargetOffset numele
; /* Converted from num_elements. */
479 type
= ffeinfo_type (bt
, kt
);
480 assert (type
!= NULL
);
482 *alignment
= ffetype_alignment (type
);
483 *modulo
= ffetype_modulo (type
);
484 if (bt
== FFEINFO_basictypeCHARACTER
)
486 ok
= ffetarget_offset_charsize (size
, charsize
, ffetype_size (type
));
487 #ifdef ffetarget_offset_overflow
489 ffetarget_offset_overflow (error_text
);
493 *size
= ffetype_size (type
);
495 if ((num_elements
< 0)
496 || !ffetarget_offset (&numele
, num_elements
)
497 || !ffetarget_offset_multiply (size
, *size
, numele
))
499 ffetarget_offset_overflow (error_text
);
506 /* ffetarget_ne_character1 -- Perform relational comparison on char constants
508 Compare lengths, if equal then use memcmp. */
510 #if FFETARGET_okCHARACTER1
512 ffetarget_ne_character1 (bool *res
, ffetargetCharacter1 l
,
513 ffetargetCharacter1 r
)
515 assert (l
.length
== r
.length
);
516 *res
= (memcmp (l
.text
, r
.text
, l
.length
) != 0);
521 /* ffetarget_substr_character1 -- Perform SUBSTR op on three constants
523 Always append a null byte to the end, in case this is wanted in
524 a special case such as passing a string as a FORMAT or %REF.
525 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
526 because it isn't a "feature" that is self-documenting. Use the
527 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
530 #if FFETARGET_okCHARACTER1
532 ffetarget_substr_character1 (ffetargetCharacter1
*res
,
533 ffetargetCharacter1 l
,
534 ffetargetCharacterSize first
,
535 ffetargetCharacterSize last
, mallocPool pool
,
536 ffetargetCharacterSize
*len
)
540 res
->length
= *len
= 0;
545 res
->length
= *len
= last
- first
+ 1;
546 res
->text
= malloc_new_kp (pool
, "ffetargetCharacter1(SUBSTR)", *len
+ 1);
547 memcpy (res
->text
, l
.text
+ first
- 1, *len
);
548 res
->text
[*len
] = '\0';
555 /* ffetarget_cmp_hollerith -- Produce orderable comparison between two
558 Compare lengths, if equal then use memcmp. */
561 ffetarget_cmp_hollerith (ffetargetHollerith l
, ffetargetHollerith r
)
563 if (l
.length
< r
.length
)
565 if (l
.length
> r
.length
)
567 return memcmp (l
.text
, r
.text
, l
.length
);
571 ffetarget_convert_any_character1_ (char *res
, size_t size
,
572 ffetargetCharacter1 l
)
574 if (size
<= (size_t) l
.length
)
577 ffetargetCharacterSize i
;
579 memcpy (res
, l
.text
, size
);
580 for (p
= &l
.text
[0] + size
, i
= l
.length
- size
;
584 return FFEBAD_TRUNCATING_CHARACTER
;
588 memcpy (res
, l
.text
, size
);
589 memset (res
+ l
.length
, ' ', size
- l
.length
);
596 ffetarget_convert_any_hollerith_ (char *res
, size_t size
,
597 ffetargetHollerith l
)
599 if (size
<= (size_t) l
.length
)
602 ffetargetCharacterSize i
;
604 memcpy (res
, l
.text
, size
);
605 for (p
= &l
.text
[0] + size
, i
= l
.length
- size
;
609 return FFEBAD_TRUNCATING_HOLLERITH
;
613 memcpy (res
, l
.text
, size
);
614 memset (res
+ l
.length
, ' ', size
- l
.length
);
621 ffetarget_convert_any_typeless_ (char *res
, size_t size
,
624 unsigned long long int l1
;
625 unsigned long int l2
;
627 unsigned short int l4
;
632 if (size
>= sizeof (l1
))
636 size_of
= sizeof (l1
);
638 else if (size
>= sizeof (l2
))
642 size_of
= sizeof (l2
);
645 else if (size
>= sizeof (l3
))
649 size_of
= sizeof (l3
);
652 else if (size
>= sizeof (l4
))
656 size_of
= sizeof (l4
);
659 else if (size
>= sizeof (l5
))
663 size_of
= sizeof (l5
);
668 assert ("stumped by conversion from typeless!" == NULL
);
674 int i
= size_of
- size
;
676 memcpy (res
, p
+ i
, size
);
677 for (; i
> 0; ++p
, --i
)
679 return FFEBAD_TRUNCATING_TYPELESS
;
683 int i
= size
- size_of
;
686 memcpy (res
+ i
, p
, size_of
);
690 return FFEBAD_TRUNCATING_TYPELESS
;
694 /* Always append a null byte to the end, in case this is wanted in
695 a special case such as passing a string as a FORMAT or %REF.
696 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
697 because it isn't a "feature" that is self-documenting. Use the
698 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
701 #if FFETARGET_okCHARACTER1
703 ffetarget_convert_character1_character1 (ffetargetCharacter1
*res
,
704 ffetargetCharacterSize size
,
705 ffetargetCharacter1 l
,
713 res
->text
= malloc_new_kp (pool
, "FFETARGET cvt char1", size
+ 1);
714 if (size
<= l
.length
)
715 memcpy (res
->text
, l
.text
, size
);
718 memcpy (res
->text
, l
.text
, l
.length
);
719 memset (res
->text
+ l
.length
, ' ', size
- l
.length
);
721 res
->text
[size
] = '\0';
729 /* Always append a null byte to the end, in case this is wanted in
730 a special case such as passing a string as a FORMAT or %REF.
731 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
732 because it isn't a "feature" that is self-documenting. Use the
733 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
736 #if FFETARGET_okCHARACTER1
738 ffetarget_convert_character1_hollerith (ffetargetCharacter1
*res
,
739 ffetargetCharacterSize size
,
740 ffetargetHollerith l
, mallocPool pool
)
747 res
->text
= malloc_new_kp (pool
, "FFETARGET cvt char1", size
+ 1);
748 res
->text
[size
] = '\0';
749 if (size
<= l
.length
)
752 ffetargetCharacterSize i
;
754 memcpy (res
->text
, l
.text
, size
);
755 for (p
= &l
.text
[0] + size
, i
= l
.length
- size
;
759 return FFEBAD_TRUNCATING_HOLLERITH
;
763 memcpy (res
->text
, l
.text
, l
.length
);
764 memset (res
->text
+ l
.length
, ' ', size
- l
.length
);
772 /* ffetarget_convert_character1_integer4 -- Raw conversion.
774 Always append a null byte to the end, in case this is wanted in
775 a special case such as passing a string as a FORMAT or %REF.
776 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
777 because it isn't a "feature" that is self-documenting. Use the
778 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
781 #if FFETARGET_okCHARACTER1
783 ffetarget_convert_character1_integer4 (ffetargetCharacter1
*res
,
784 ffetargetCharacterSize size
,
785 ffetargetInteger4 l
, mallocPool pool
)
795 if (((size_t) size
) >= sizeof (l1
))
799 size_of
= sizeof (l1
);
801 else if (((size_t) size
) >= sizeof (l2
))
805 size_of
= sizeof (l2
);
808 else if (((size_t) size
) >= sizeof (l3
))
812 size_of
= sizeof (l3
);
815 else if (((size_t) size
) >= sizeof (l4
))
819 size_of
= sizeof (l4
);
822 else if (((size_t) size
) >= sizeof (l5
))
826 size_of
= sizeof (l5
);
831 assert ("stumped by conversion from integer1!" == NULL
);
840 res
->text
= malloc_new_kp (pool
, "FFETARGET cvt char1", size
+ 1);
841 res
->text
[size
] = '\0';
842 if (((size_t) size
) <= size_of
)
844 int i
= size_of
- size
;
846 memcpy (res
->text
, p
+ i
, size
);
847 for (; i
> 0; ++p
, --i
)
849 return FFEBAD_TRUNCATING_NUMERIC
;
853 int i
= size
- size_of
;
855 memset (res
->text
, 0, i
);
856 memcpy (res
->text
+ i
, p
, size_of
);
861 return FFEBAD_TRUNCATING_NUMERIC
;
866 /* ffetarget_convert_character1_logical4 -- Raw conversion.
868 Always append a null byte to the end, in case this is wanted in
869 a special case such as passing a string as a FORMAT or %REF.
870 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
871 because it isn't a "feature" that is self-documenting. Use the
872 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
875 #if FFETARGET_okCHARACTER1
877 ffetarget_convert_character1_logical4 (ffetargetCharacter1
*res
,
878 ffetargetCharacterSize size
,
879 ffetargetLogical4 l
, mallocPool pool
)
889 if (((size_t) size
) >= sizeof (l1
))
893 size_of
= sizeof (l1
);
895 else if (((size_t) size
) >= sizeof (l2
))
899 size_of
= sizeof (l2
);
902 else if (((size_t) size
) >= sizeof (l3
))
906 size_of
= sizeof (l3
);
909 else if (((size_t) size
) >= sizeof (l4
))
913 size_of
= sizeof (l4
);
916 else if (((size_t) size
) >= sizeof (l5
))
920 size_of
= sizeof (l5
);
925 assert ("stumped by conversion from logical1!" == NULL
);
934 res
->text
= malloc_new_kp (pool
, "FFETARGET cvt char1", size
+ 1);
935 res
->text
[size
] = '\0';
936 if (((size_t) size
) <= size_of
)
938 int i
= size_of
- size
;
940 memcpy (res
->text
, p
+ i
, size
);
941 for (; i
> 0; ++p
, --i
)
943 return FFEBAD_TRUNCATING_NUMERIC
;
947 int i
= size
- size_of
;
949 memset (res
->text
, 0, i
);
950 memcpy (res
->text
+ i
, p
, size_of
);
955 return FFEBAD_TRUNCATING_NUMERIC
;
960 /* ffetarget_convert_character1_typeless -- Raw conversion.
962 Always append a null byte to the end, in case this is wanted in
963 a special case such as passing a string as a FORMAT or %REF.
964 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
965 because it isn't a "feature" that is self-documenting. Use the
966 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
969 #if FFETARGET_okCHARACTER1
971 ffetarget_convert_character1_typeless (ffetargetCharacter1
*res
,
972 ffetargetCharacterSize size
,
973 ffetargetTypeless l
, mallocPool pool
)
975 unsigned long long int l1
;
976 unsigned long int l2
;
978 unsigned short int l4
;
983 if (((size_t) size
) >= sizeof (l1
))
987 size_of
= sizeof (l1
);
989 else if (((size_t) size
) >= sizeof (l2
))
993 size_of
= sizeof (l2
);
996 else if (((size_t) size
) >= sizeof (l3
))
1000 size_of
= sizeof (l3
);
1003 else if (((size_t) size
) >= sizeof (l4
))
1007 size_of
= sizeof (l4
);
1010 else if (((size_t) size
) >= sizeof (l5
))
1014 size_of
= sizeof (l5
);
1019 assert ("stumped by conversion from typeless!" == NULL
);
1028 res
->text
= malloc_new_kp (pool
, "FFETARGET cvt char1", size
+ 1);
1029 res
->text
[size
] = '\0';
1030 if (((size_t) size
) <= size_of
)
1032 int i
= size_of
- size
;
1034 memcpy (res
->text
, p
+ i
, size
);
1035 for (; i
> 0; ++p
, --i
)
1037 return FFEBAD_TRUNCATING_TYPELESS
;
1041 int i
= size
- size_of
;
1043 memset (res
->text
, 0, i
);
1044 memcpy (res
->text
+ i
, p
, size_of
);
1049 return FFEBAD_TRUNCATING_TYPELESS
;
1054 /* ffetarget_divide_complex1 -- Divide function
1058 #if FFETARGET_okCOMPLEX1
1060 ffetarget_divide_complex1 (ffetargetComplex1
*res
, ffetargetComplex1 l
,
1061 ffetargetComplex1 r
)
1064 ffetargetReal1 tmp1
, tmp2
, tmp3
, tmp4
;
1066 bad
= ffetarget_multiply_real1 (&tmp1
, r
.real
, r
.real
);
1069 bad
= ffetarget_multiply_real1 (&tmp2
, r
.imaginary
, r
.imaginary
);
1072 bad
= ffetarget_add_real1 (&tmp3
, tmp1
, tmp2
);
1076 if (ffetarget_iszero_real1 (tmp3
))
1078 ffetarget_real1_zero (&(res
)->real
);
1079 ffetarget_real1_zero (&(res
)->imaginary
);
1080 return FFEBAD_DIV_BY_ZERO
;
1083 bad
= ffetarget_multiply_real1 (&tmp1
, l
.real
, r
.real
);
1086 bad
= ffetarget_multiply_real1 (&tmp2
, l
.imaginary
, r
.imaginary
);
1089 bad
= ffetarget_add_real1 (&tmp4
, tmp1
, tmp2
);
1092 bad
= ffetarget_divide_real1 (&res
->real
, tmp4
, tmp3
);
1096 bad
= ffetarget_multiply_real1 (&tmp1
, r
.real
, l
.imaginary
);
1099 bad
= ffetarget_multiply_real1 (&tmp2
, l
.real
, r
.imaginary
);
1102 bad
= ffetarget_subtract_real1 (&tmp4
, tmp1
, tmp2
);
1105 bad
= ffetarget_divide_real1 (&res
->imaginary
, tmp4
, tmp3
);
1111 /* ffetarget_divide_complex2 -- Divide function
1115 #if FFETARGET_okCOMPLEX2
1117 ffetarget_divide_complex2 (ffetargetComplex2
*res
, ffetargetComplex2 l
,
1118 ffetargetComplex2 r
)
1121 ffetargetReal2 tmp1
, tmp2
, tmp3
, tmp4
;
1123 bad
= ffetarget_multiply_real2 (&tmp1
, r
.real
, r
.real
);
1126 bad
= ffetarget_multiply_real2 (&tmp2
, r
.imaginary
, r
.imaginary
);
1129 bad
= ffetarget_add_real2 (&tmp3
, tmp1
, tmp2
);
1133 if (ffetarget_iszero_real2 (tmp3
))
1135 ffetarget_real2_zero (&(res
)->real
);
1136 ffetarget_real2_zero (&(res
)->imaginary
);
1137 return FFEBAD_DIV_BY_ZERO
;
1140 bad
= ffetarget_multiply_real2 (&tmp1
, l
.real
, r
.real
);
1143 bad
= ffetarget_multiply_real2 (&tmp2
, l
.imaginary
, r
.imaginary
);
1146 bad
= ffetarget_add_real2 (&tmp4
, tmp1
, tmp2
);
1149 bad
= ffetarget_divide_real2 (&res
->real
, tmp4
, tmp3
);
1153 bad
= ffetarget_multiply_real2 (&tmp1
, r
.real
, l
.imaginary
);
1156 bad
= ffetarget_multiply_real2 (&tmp2
, l
.real
, r
.imaginary
);
1159 bad
= ffetarget_subtract_real2 (&tmp4
, tmp1
, tmp2
);
1162 bad
= ffetarget_divide_real2 (&res
->imaginary
, tmp4
, tmp3
);
1168 /* ffetarget_hollerith -- Convert token to a hollerith constant
1170 Always append a null byte to the end, in case this is wanted in
1171 a special case such as passing a string as a FORMAT or %REF.
1172 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
1173 because it isn't a "feature" that is self-documenting. Use the
1174 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
1178 ffetarget_hollerith (ffetargetHollerith
*val
, ffelexToken integer
,
1181 val
->length
= ffelex_token_length (integer
);
1182 val
->text
= malloc_new_kp (pool
, "ffetargetHollerith", val
->length
+ 1);
1183 memcpy (val
->text
, ffelex_token_text (integer
), val
->length
);
1184 val
->text
[val
->length
] = '\0';
1189 /* ffetarget_integer_bad_magical -- Complain about a magical number
1191 Just calls ffebad with the arguments. */
1194 ffetarget_integer_bad_magical (ffelexToken t
)
1196 ffebad_start (FFEBAD_BAD_MAGICAL
);
1197 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
1201 /* ffetarget_integer_bad_magical_binary -- Complain about a magical number
1203 Just calls ffebad with the arguments. */
1206 ffetarget_integer_bad_magical_binary (ffelexToken integer
,
1209 ffebad_start (FFEBAD_BAD_MAGICAL_BINARY
);
1210 ffebad_here (0, ffelex_token_where_line (integer
),
1211 ffelex_token_where_column (integer
));
1212 ffebad_here (1, ffelex_token_where_line (minus
),
1213 ffelex_token_where_column (minus
));
1217 /* ffetarget_integer_bad_magical_precedence -- Complain about a magical
1220 Just calls ffebad with the arguments. */
1223 ffetarget_integer_bad_magical_precedence (ffelexToken integer
,
1225 ffelexToken higher_op
)
1227 ffebad_start (FFEBAD_BAD_MAGICAL_PRECEDENCE
);
1228 ffebad_here (0, ffelex_token_where_line (integer
),
1229 ffelex_token_where_column (integer
));
1230 ffebad_here (1, ffelex_token_where_line (uminus
),
1231 ffelex_token_where_column (uminus
));
1232 ffebad_here (2, ffelex_token_where_line (higher_op
),
1233 ffelex_token_where_column (higher_op
));
1237 /* ffetarget_integer_bad_magical_precedence_binary -- Complain...
1239 Just calls ffebad with the arguments. */
1242 ffetarget_integer_bad_magical_precedence_binary (ffelexToken integer
,
1244 ffelexToken higher_op
)
1246 ffebad_start (FFEBAD_BAD_MAGICAL_PRECEDENCE_BINARY
);
1247 ffebad_here (0, ffelex_token_where_line (integer
),
1248 ffelex_token_where_column (integer
));
1249 ffebad_here (1, ffelex_token_where_line (minus
),
1250 ffelex_token_where_column (minus
));
1251 ffebad_here (2, ffelex_token_where_line (higher_op
),
1252 ffelex_token_where_column (higher_op
));
1256 /* ffetarget_integer1 -- Convert token to an integer
1260 Token use count not affected overall. */
1262 #if FFETARGET_okINTEGER1
1264 ffetarget_integer1 (ffetargetInteger1
*val
, ffelexToken integer
)
1266 ffetargetInteger1 x
;
1270 assert (ffelex_token_type (integer
) == FFELEX_typeNUMBER
);
1272 p
= ffelex_token_text (integer
);
1275 /* Skip past leading zeros. */
1277 while (((c
= *p
) != '\0') && (c
== '0'))
1280 /* Interpret rest of number. */
1284 if ((x
== FFETARGET_integerALMOST_BIG_MAGICAL
)
1285 && (c
== '0' + FFETARGET_integerFINISH_BIG_MAGICAL
)
1286 && (*(p
+ 1) == '\0'))
1288 *val
= (ffetargetInteger1
) FFETARGET_integerBIG_MAGICAL
;
1291 else if (x
== FFETARGET_integerALMOST_BIG_MAGICAL
)
1293 if ((c
> '0' + FFETARGET_integerFINISH_BIG_MAGICAL
)
1294 || (*(p
+ 1) != '\0'))
1296 ffebad_start (FFEBAD_INTEGER_TOO_LARGE
);
1297 ffebad_here (0, ffelex_token_where_line (integer
),
1298 ffelex_token_where_column (integer
));
1304 else if (x
> FFETARGET_integerALMOST_BIG_MAGICAL
)
1306 ffebad_start (FFEBAD_INTEGER_TOO_LARGE
);
1307 ffebad_here (0, ffelex_token_where_line (integer
),
1308 ffelex_token_where_column (integer
));
1313 x
= x
* 10 + c
- '0';
1322 /* ffetarget_integerbinary -- Convert token to a binary integer
1324 ffetarget_integerbinary x;
1325 if (ffetarget_integerdefault_8(&x,integer_token))
1328 Token use count not affected overall. */
1331 ffetarget_integerbinary (ffetargetIntegerDefault
*val
, ffelexToken integer
)
1333 ffetargetIntegerDefault x
;
1338 assert ((ffelex_token_type (integer
) == FFELEX_typeNAME
)
1339 || (ffelex_token_type (integer
) == FFELEX_typeNUMBER
));
1341 p
= ffelex_token_text (integer
);
1344 /* Skip past leading zeros. */
1346 while (((c
= *p
) != '\0') && (c
== '0'))
1349 /* Interpret rest of number. */
1354 if ((c
>= '0') && (c
<= '1'))
1362 #if 0 /* Don't complain about signed overflow; just
1363 unsigned overflow. */
1364 if ((x
== FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY
)
1365 && (c
== FFETARGET_integerFINISH_BIG_OVERFLOW_BINARY
)
1366 && (*(p
+ 1) == '\0'))
1368 *val
= FFETARGET_integerBIG_OVERFLOW_BINARY
;
1373 #if FFETARGET_integerFINISH_BIG_OVERFLOW_BINARY == 0
1374 if ((x
& FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY
) != 0)
1376 if (x
== FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY
)
1378 if ((c
> FFETARGET_integerFINISH_BIG_OVERFLOW_BINARY
)
1379 || (*(p
+ 1) != '\0'))
1381 ffebad_start (FFEBAD_INTEGER_TOO_LARGE
);
1382 ffebad_here (0, ffelex_token_where_line (integer
),
1383 ffelex_token_where_column (integer
));
1389 else if (x
> FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY
)
1392 ffebad_start (FFEBAD_INTEGER_TOO_LARGE
);
1393 ffebad_here (0, ffelex_token_where_line (integer
),
1394 ffelex_token_where_column (integer
));
1405 ffebad_start (FFEBAD_INVALID_BINARY_DIGIT
);
1406 ffebad_here (0, ffelex_token_where_line (integer
),
1407 ffelex_token_where_column (integer
));
1415 /* ffetarget_integerhex -- Convert token to a hex integer
1417 ffetarget_integerhex x;
1418 if (ffetarget_integerdefault_8(&x,integer_token))
1421 Token use count not affected overall. */
1424 ffetarget_integerhex (ffetargetIntegerDefault
*val
, ffelexToken integer
)
1426 ffetargetIntegerDefault x
;
1431 assert ((ffelex_token_type (integer
) == FFELEX_typeNAME
)
1432 || (ffelex_token_type (integer
) == FFELEX_typeNUMBER
));
1434 p
= ffelex_token_text (integer
);
1437 /* Skip past leading zeros. */
1439 while (((c
= *p
) != '\0') && (c
== '0'))
1442 /* Interpret rest of number. */
1455 #if 0 /* Don't complain about signed overflow; just
1456 unsigned overflow. */
1457 if ((x
== FFETARGET_integerALMOST_BIG_OVERFLOW_HEX
)
1458 && (c
== FFETARGET_integerFINISH_BIG_OVERFLOW_HEX
)
1459 && (*(p
+ 1) == '\0'))
1461 *val
= FFETARGET_integerBIG_OVERFLOW_HEX
;
1466 #if FFETARGET_integerFINISH_BIG_OVERFLOW_HEX == 0
1467 if (x
>= FFETARGET_integerALMOST_BIG_OVERFLOW_HEX
)
1469 if (x
== FFETARGET_integerALMOST_BIG_OVERFLOW_HEX
)
1471 if ((c
> FFETARGET_integerFINISH_BIG_OVERFLOW_HEX
)
1472 || (*(p
+ 1) != '\0'))
1474 ffebad_start (FFEBAD_INTEGER_TOO_LARGE
);
1475 ffebad_here (0, ffelex_token_where_line (integer
),
1476 ffelex_token_where_column (integer
));
1482 else if (x
> FFETARGET_integerALMOST_BIG_OVERFLOW_HEX
)
1485 ffebad_start (FFEBAD_INTEGER_TOO_LARGE
);
1486 ffebad_here (0, ffelex_token_where_line (integer
),
1487 ffelex_token_where_column (integer
));
1498 ffebad_start (FFEBAD_INVALID_HEX_DIGIT
);
1499 ffebad_here (0, ffelex_token_where_line (integer
),
1500 ffelex_token_where_column (integer
));
1508 /* ffetarget_integeroctal -- Convert token to an octal integer
1510 ffetarget_integeroctal x;
1511 if (ffetarget_integerdefault_8(&x,integer_token))
1514 Token use count not affected overall. */
1517 ffetarget_integeroctal (ffetargetIntegerDefault
*val
, ffelexToken integer
)
1519 ffetargetIntegerDefault x
;
1524 assert ((ffelex_token_type (integer
) == FFELEX_typeNAME
)
1525 || (ffelex_token_type (integer
) == FFELEX_typeNUMBER
));
1527 p
= ffelex_token_text (integer
);
1530 /* Skip past leading zeros. */
1532 while (((c
= *p
) != '\0') && (c
== '0'))
1535 /* Interpret rest of number. */
1540 if ((c
>= '0') && (c
<= '7'))
1548 #if 0 /* Don't complain about signed overflow; just
1549 unsigned overflow. */
1550 if ((x
== FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL
)
1551 && (c
== FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL
)
1552 && (*(p
+ 1) == '\0'))
1554 *val
= FFETARGET_integerBIG_OVERFLOW_OCTAL
;
1559 #if FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL == 0
1560 if (x
>= FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL
)
1562 if (x
== FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL
)
1564 if ((c
> FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL
)
1565 || (*(p
+ 1) != '\0'))
1567 ffebad_start (FFEBAD_INTEGER_TOO_LARGE
);
1568 ffebad_here (0, ffelex_token_where_line (integer
),
1569 ffelex_token_where_column (integer
));
1575 else if (x
> FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL
)
1578 ffebad_start (FFEBAD_INTEGER_TOO_LARGE
);
1579 ffebad_here (0, ffelex_token_where_line (integer
),
1580 ffelex_token_where_column (integer
));
1591 ffebad_start (FFEBAD_INVALID_OCTAL_DIGIT
);
1592 ffebad_here (0, ffelex_token_where_line (integer
),
1593 ffelex_token_where_column (integer
));
1601 /* ffetarget_multiply_complex1 -- Multiply function
1605 #if FFETARGET_okCOMPLEX1
1607 ffetarget_multiply_complex1 (ffetargetComplex1
*res
, ffetargetComplex1 l
,
1608 ffetargetComplex1 r
)
1611 ffetargetReal1 tmp1
, tmp2
;
1613 bad
= ffetarget_multiply_real1 (&tmp1
, l
.real
, r
.real
);
1616 bad
= ffetarget_multiply_real1 (&tmp2
, l
.imaginary
, r
.imaginary
);
1619 bad
= ffetarget_subtract_real1 (&res
->real
, tmp1
, tmp2
);
1622 bad
= ffetarget_multiply_real1 (&tmp1
, l
.imaginary
, r
.real
);
1625 bad
= ffetarget_multiply_real1 (&tmp2
, l
.real
, r
.imaginary
);
1628 bad
= ffetarget_add_real1 (&res
->imaginary
, tmp1
, tmp2
);
1634 /* ffetarget_multiply_complex2 -- Multiply function
1638 #if FFETARGET_okCOMPLEX2
1640 ffetarget_multiply_complex2 (ffetargetComplex2
*res
, ffetargetComplex2 l
,
1641 ffetargetComplex2 r
)
1644 ffetargetReal2 tmp1
, tmp2
;
1646 bad
= ffetarget_multiply_real2 (&tmp1
, l
.real
, r
.real
);
1649 bad
= ffetarget_multiply_real2 (&tmp2
, l
.imaginary
, r
.imaginary
);
1652 bad
= ffetarget_subtract_real2 (&res
->real
, tmp1
, tmp2
);
1655 bad
= ffetarget_multiply_real2 (&tmp1
, l
.imaginary
, r
.real
);
1658 bad
= ffetarget_multiply_real2 (&tmp2
, l
.real
, r
.imaginary
);
1661 bad
= ffetarget_add_real2 (&res
->imaginary
, tmp1
, tmp2
);
1667 /* ffetarget_power_complexdefault_integerdefault -- Power function
1672 ffetarget_power_complexdefault_integerdefault (ffetargetComplexDefault
*res
,
1673 ffetargetComplexDefault l
,
1674 ffetargetIntegerDefault r
)
1677 ffetargetRealDefault tmp
;
1678 ffetargetRealDefault tmp1
;
1679 ffetargetRealDefault tmp2
;
1680 ffetargetRealDefault two
;
1682 if (ffetarget_iszero_real1 (l
.real
)
1683 && ffetarget_iszero_real1 (l
.imaginary
))
1685 ffetarget_real1_zero (&res
->real
);
1686 ffetarget_real1_zero (&res
->imaginary
);
1692 ffetarget_real1_one (&res
->real
);
1693 ffetarget_real1_zero (&res
->imaginary
);
1700 bad
= ffetarget_multiply_real1 (&tmp1
, l
.real
, l
.real
);
1703 bad
= ffetarget_multiply_real1 (&tmp2
, l
.imaginary
, l
.imaginary
);
1706 bad
= ffetarget_add_real1 (&tmp
, tmp1
, tmp2
);
1709 bad
= ffetarget_divide_real1 (&l
.real
, l
.real
, tmp
);
1712 bad
= ffetarget_divide_real1 (&l
.imaginary
, l
.imaginary
, tmp
);
1715 bad
= ffetarget_uminus_real1 (&l
.imaginary
, l
.imaginary
);
1720 ffetarget_real1_two (&two
);
1722 while ((r
& 1) == 0)
1724 bad
= ffetarget_multiply_real1 (&tmp1
, l
.real
, l
.real
);
1727 bad
= ffetarget_multiply_real1 (&tmp2
, l
.imaginary
, l
.imaginary
);
1730 bad
= ffetarget_subtract_real1 (&tmp
, tmp1
, tmp2
);
1733 bad
= ffetarget_multiply_real1 (&l
.imaginary
, l
.real
, l
.imaginary
);
1736 bad
= ffetarget_multiply_real1 (&l
.imaginary
, l
.imaginary
, two
);
1748 bad
= ffetarget_multiply_real1 (&tmp1
, l
.real
, l
.real
);
1751 bad
= ffetarget_multiply_real1 (&tmp2
, l
.imaginary
, l
.imaginary
);
1754 bad
= ffetarget_subtract_real1 (&tmp
, tmp1
, tmp2
);
1757 bad
= ffetarget_multiply_real1 (&l
.imaginary
, l
.real
, l
.imaginary
);
1760 bad
= ffetarget_multiply_real1 (&l
.imaginary
, l
.imaginary
, two
);
1766 bad
= ffetarget_multiply_real1 (&tmp1
, res
->real
, l
.real
);
1769 bad
= ffetarget_multiply_real1 (&tmp2
, res
->imaginary
,
1773 bad
= ffetarget_subtract_real1 (&tmp
, tmp1
, tmp2
);
1776 bad
= ffetarget_multiply_real1 (&tmp1
, res
->imaginary
, l
.real
);
1779 bad
= ffetarget_multiply_real1 (&tmp2
, res
->real
, l
.imaginary
);
1782 bad
= ffetarget_add_real1 (&res
->imaginary
, tmp1
, tmp2
);
1793 /* ffetarget_power_complexdouble_integerdefault -- Power function
1797 #if FFETARGET_okCOMPLEXDOUBLE
1799 ffetarget_power_complexdouble_integerdefault (ffetargetComplexDouble
*res
,
1800 ffetargetComplexDouble l
, ffetargetIntegerDefault r
)
1803 ffetargetRealDouble tmp
;
1804 ffetargetRealDouble tmp1
;
1805 ffetargetRealDouble tmp2
;
1806 ffetargetRealDouble two
;
1808 if (ffetarget_iszero_real2 (l
.real
)
1809 && ffetarget_iszero_real2 (l
.imaginary
))
1811 ffetarget_real2_zero (&res
->real
);
1812 ffetarget_real2_zero (&res
->imaginary
);
1818 ffetarget_real2_one (&res
->real
);
1819 ffetarget_real2_zero (&res
->imaginary
);
1826 bad
= ffetarget_multiply_real2 (&tmp1
, l
.real
, l
.real
);
1829 bad
= ffetarget_multiply_real2 (&tmp2
, l
.imaginary
, l
.imaginary
);
1832 bad
= ffetarget_add_real2 (&tmp
, tmp1
, tmp2
);
1835 bad
= ffetarget_divide_real2 (&l
.real
, l
.real
, tmp
);
1838 bad
= ffetarget_divide_real2 (&l
.imaginary
, l
.imaginary
, tmp
);
1841 bad
= ffetarget_uminus_real2 (&l
.imaginary
, l
.imaginary
);
1846 ffetarget_real2_two (&two
);
1848 while ((r
& 1) == 0)
1850 bad
= ffetarget_multiply_real2 (&tmp1
, l
.real
, l
.real
);
1853 bad
= ffetarget_multiply_real2 (&tmp2
, l
.imaginary
, l
.imaginary
);
1856 bad
= ffetarget_subtract_real2 (&tmp
, tmp1
, tmp2
);
1859 bad
= ffetarget_multiply_real2 (&l
.imaginary
, l
.real
, l
.imaginary
);
1862 bad
= ffetarget_multiply_real2 (&l
.imaginary
, l
.imaginary
, two
);
1874 bad
= ffetarget_multiply_real2 (&tmp1
, l
.real
, l
.real
);
1877 bad
= ffetarget_multiply_real2 (&tmp2
, l
.imaginary
, l
.imaginary
);
1880 bad
= ffetarget_subtract_real2 (&tmp
, tmp1
, tmp2
);
1883 bad
= ffetarget_multiply_real2 (&l
.imaginary
, l
.real
, l
.imaginary
);
1886 bad
= ffetarget_multiply_real2 (&l
.imaginary
, l
.imaginary
, two
);
1892 bad
= ffetarget_multiply_real2 (&tmp1
, res
->real
, l
.real
);
1895 bad
= ffetarget_multiply_real2 (&tmp2
, res
->imaginary
,
1899 bad
= ffetarget_subtract_real2 (&tmp
, tmp1
, tmp2
);
1902 bad
= ffetarget_multiply_real2 (&tmp1
, res
->imaginary
, l
.real
);
1905 bad
= ffetarget_multiply_real2 (&tmp2
, res
->real
, l
.imaginary
);
1908 bad
= ffetarget_add_real2 (&res
->imaginary
, tmp1
, tmp2
);
1920 /* ffetarget_power_integerdefault_integerdefault -- Power function
1925 ffetarget_power_integerdefault_integerdefault (ffetargetIntegerDefault
*res
,
1926 ffetargetIntegerDefault l
, ffetargetIntegerDefault r
)
1947 *res
= ((-r
) & 1) == 0 ? 1 : -1;
1953 while ((r
& 1) == 0)
1973 /* ffetarget_power_realdefault_integerdefault -- Power function
1978 ffetarget_power_realdefault_integerdefault (ffetargetRealDefault
*res
,
1979 ffetargetRealDefault l
, ffetargetIntegerDefault r
)
1983 if (ffetarget_iszero_real1 (l
))
1985 ffetarget_real1_zero (res
);
1991 ffetarget_real1_one (res
);
1997 ffetargetRealDefault one
;
1999 ffetarget_real1_one (&one
);
2001 bad
= ffetarget_divide_real1 (&l
, one
, l
);
2006 while ((r
& 1) == 0)
2008 bad
= ffetarget_multiply_real1 (&l
, l
, l
);
2019 bad
= ffetarget_multiply_real1 (&l
, l
, l
);
2024 bad
= ffetarget_multiply_real1 (res
, *res
, l
);
2034 /* ffetarget_power_realdouble_integerdefault -- Power function
2039 ffetarget_power_realdouble_integerdefault (ffetargetRealDouble
*res
,
2040 ffetargetRealDouble l
,
2041 ffetargetIntegerDefault r
)
2045 if (ffetarget_iszero_real2 (l
))
2047 ffetarget_real2_zero (res
);
2053 ffetarget_real2_one (res
);
2059 ffetargetRealDouble one
;
2061 ffetarget_real2_one (&one
);
2063 bad
= ffetarget_divide_real2 (&l
, one
, l
);
2068 while ((r
& 1) == 0)
2070 bad
= ffetarget_multiply_real2 (&l
, l
, l
);
2081 bad
= ffetarget_multiply_real2 (&l
, l
, l
);
2086 bad
= ffetarget_multiply_real2 (res
, *res
, l
);
2096 /* ffetarget_print_binary -- Output typeless binary integer
2098 ffetargetTypeless val;
2099 ffetarget_typeless_binary(dmpout,val); */
2102 ffetarget_print_binary (FILE *f
, ffetargetTypeless value
)
2105 char digits
[sizeof (value
) * CHAR_BIT
+ 1];
2110 p
= &digits
[ARRAY_SIZE (digits
) - 1];
2114 *--p
= (value
& 1) + '0';
2116 } while (value
== 0);
2121 /* ffetarget_print_character1 -- Output character string
2123 ffetargetCharacter1 val;
2124 ffetarget_print_character1(dmpout,val); */
2127 ffetarget_print_character1 (FILE *f
, ffetargetCharacter1 value
)
2130 ffetargetCharacterSize i
;
2132 fputc ('\'', dmpout
);
2133 for (i
= 0, p
= value
.text
; i
< value
.length
; ++i
, ++p
)
2134 ffetarget_print_char_ (f
, *p
);
2135 fputc ('\'', dmpout
);
2138 /* ffetarget_print_hollerith -- Output hollerith string
2140 ffetargetHollerith val;
2141 ffetarget_print_hollerith(dmpout,val); */
2144 ffetarget_print_hollerith (FILE *f
, ffetargetHollerith value
)
2147 ffetargetHollerithSize i
;
2149 fputc ('\'', dmpout
);
2150 for (i
= 0, p
= value
.text
; i
< value
.length
; ++i
, ++p
)
2151 ffetarget_print_char_ (f
, *p
);
2152 fputc ('\'', dmpout
);
2155 /* ffetarget_print_octal -- Output typeless octal integer
2157 ffetargetTypeless val;
2158 ffetarget_print_octal(dmpout,val); */
2161 ffetarget_print_octal (FILE *f
, ffetargetTypeless value
)
2164 char digits
[sizeof (value
) * CHAR_BIT
/ 3 + 1];
2169 p
= &digits
[ARRAY_SIZE (digits
) - 3];
2173 *--p
= (value
& 3) + '0';
2175 } while (value
== 0);
2180 /* ffetarget_print_hex -- Output typeless hex integer
2182 ffetargetTypeless val;
2183 ffetarget_print_hex(dmpout,val); */
2186 ffetarget_print_hex (FILE *f
, ffetargetTypeless value
)
2189 char digits
[sizeof (value
) * CHAR_BIT
/ 4 + 1];
2190 static const char hexdigits
[16] = "0123456789ABCDEF";
2195 p
= &digits
[ARRAY_SIZE (digits
) - 3];
2199 *--p
= hexdigits
[value
& 4];
2201 } while (value
== 0);
2206 /* ffetarget_real1 -- Convert token to a single-precision real number
2210 Pass NULL for any token not provided by the user, but a valid Fortran
2211 real number must be provided somehow. For example, it is ok for
2212 exponent_sign_token and exponent_digits_token to be NULL as long as
2213 exponent_token not only starts with "E" or "e" but also contains at least
2214 one digit following it. Token use counts not affected overall. */
2216 #if FFETARGET_okREAL1
2218 ffetarget_real1 (ffetargetReal1
*value
, ffelexToken integer
,
2219 ffelexToken decimal
, ffelexToken fraction
,
2220 ffelexToken exponent
, ffelexToken exponent_sign
,
2221 ffelexToken exponent_digits
)
2223 size_t sz
= 1; /* Allow room for '\0' byte at end. */
2224 char *ptr
= &ffetarget_string_
[0];
2228 #define dotok(x) if (x != NULL) ++sz;
2229 #define dotoktxt(x) if (x != NULL) sz += ffelex_token_length(x)
2233 dotoktxt (fraction
);
2234 dotoktxt (exponent
);
2235 dotok (exponent_sign
);
2236 dotoktxt (exponent_digits
);
2241 if (sz
> ARRAY_SIZE (ffetarget_string_
))
2242 p
= ptr
= malloc_new_ks (malloc_pool_image (), "ffetarget_real1", sz
);
2244 #define dotoktxt(x) if (x != NULL) \
2246 for (q = ffelex_token_text(x); *q != '\0'; ++q) \
2252 if (decimal
!= NULL
)
2255 dotoktxt (fraction
);
2256 dotoktxt (exponent
);
2258 if (exponent_sign
!= NULL
)
2260 if (ffelex_token_type (exponent_sign
) == FFELEX_typePLUS
)
2264 assert (ffelex_token_type (exponent_sign
) == FFELEX_typeMINUS
);
2269 dotoktxt (exponent_digits
);
2277 real_from_string (&rv
, ptr
);
2278 ffetarget_make_real1 (value
, rv
);
2281 if (sz
> ARRAY_SIZE (ffetarget_string_
))
2282 malloc_kill_ks (malloc_pool_image (), ptr
, sz
);
2288 /* ffetarget_real2 -- Convert token to a single-precision real number
2292 Pass NULL for any token not provided by the user, but a valid Fortran
2293 real number must be provided somehow. For example, it is ok for
2294 exponent_sign_token and exponent_digits_token to be NULL as long as
2295 exponent_token not only starts with "E" or "e" but also contains at least
2296 one digit following it. Token use counts not affected overall. */
2298 #if FFETARGET_okREAL2
2300 ffetarget_real2 (ffetargetReal2
*value
, ffelexToken integer
,
2301 ffelexToken decimal
, ffelexToken fraction
,
2302 ffelexToken exponent
, ffelexToken exponent_sign
,
2303 ffelexToken exponent_digits
)
2305 size_t sz
= 1; /* Allow room for '\0' byte at end. */
2306 char *ptr
= &ffetarget_string_
[0];
2310 #define dotok(x) if (x != NULL) ++sz;
2311 #define dotoktxt(x) if (x != NULL) sz += ffelex_token_length(x)
2315 dotoktxt (fraction
);
2316 dotoktxt (exponent
);
2317 dotok (exponent_sign
);
2318 dotoktxt (exponent_digits
);
2323 if (sz
> ARRAY_SIZE (ffetarget_string_
))
2324 p
= ptr
= malloc_new_ks (malloc_pool_image (), "ffetarget_real1", sz
);
2326 #define dotoktxt(x) if (x != NULL) \
2328 for (q = ffelex_token_text(x); *q != '\0'; ++q) \
2331 #define dotoktxtexp(x) if (x != NULL) \
2334 for (q = ffelex_token_text(x) + 1; *q != '\0'; ++q) \
2340 if (decimal
!= NULL
)
2343 dotoktxt (fraction
);
2344 dotoktxtexp (exponent
);
2346 if (exponent_sign
!= NULL
)
2348 if (ffelex_token_type (exponent_sign
) == FFELEX_typePLUS
)
2352 assert (ffelex_token_type (exponent_sign
) == FFELEX_typeMINUS
);
2357 dotoktxt (exponent_digits
);
2365 real_from_string (&rv
, ptr
);
2366 ffetarget_make_real2 (value
, rv
);
2369 if (sz
> ARRAY_SIZE (ffetarget_string_
))
2370 malloc_kill_ks (malloc_pool_image (), ptr
, sz
);
2377 ffetarget_typeless_binary (ffetargetTypeless
*xvalue
, ffelexToken token
)
2381 ffetargetTypeless value
= 0;
2382 ffetargetTypeless new_value
= 0;
2383 bool bad_digit
= FALSE
;
2384 bool overflow
= FALSE
;
2386 p
= ffelex_token_text (token
);
2388 for (c
= *p
; c
!= '\0'; c
= *++p
)
2391 if ((new_value
>> 1) != value
)
2394 new_value
+= c
- '0';
2402 ffebad_start (FFEBAD_INVALID_TYPELESS_BINARY_DIGIT
);
2403 ffebad_here (0, ffelex_token_where_line (token
),
2404 ffelex_token_where_column (token
));
2409 ffebad_start (FFEBAD_TYPELESS_OVERFLOW
);
2410 ffebad_here (0, ffelex_token_where_line (token
),
2411 ffelex_token_where_column (token
));
2417 return !bad_digit
&& !overflow
;
2421 ffetarget_typeless_octal (ffetargetTypeless
*xvalue
, ffelexToken token
)
2425 ffetargetTypeless value
= 0;
2426 ffetargetTypeless new_value
= 0;
2427 bool bad_digit
= FALSE
;
2428 bool overflow
= FALSE
;
2430 p
= ffelex_token_text (token
);
2432 for (c
= *p
; c
!= '\0'; c
= *++p
)
2435 if ((new_value
>> 3) != value
)
2438 new_value
+= c
- '0';
2446 ffebad_start (FFEBAD_INVALID_TYPELESS_OCTAL_DIGIT
);
2447 ffebad_here (0, ffelex_token_where_line (token
),
2448 ffelex_token_where_column (token
));
2453 ffebad_start (FFEBAD_TYPELESS_OVERFLOW
);
2454 ffebad_here (0, ffelex_token_where_line (token
),
2455 ffelex_token_where_column (token
));
2461 return !bad_digit
&& !overflow
;
2465 ffetarget_typeless_hex (ffetargetTypeless
*xvalue
, ffelexToken token
)
2469 ffetargetTypeless value
= 0;
2470 ffetargetTypeless new_value
= 0;
2471 bool bad_digit
= FALSE
;
2472 bool overflow
= FALSE
;
2474 p
= ffelex_token_text (token
);
2476 for (c
= *p
; c
!= '\0'; c
= *++p
)
2479 if ((new_value
>> 4) != value
)
2482 new_value
+= hex_value (c
);
2490 ffebad_start (FFEBAD_INVALID_TYPELESS_HEX_DIGIT
);
2491 ffebad_here (0, ffelex_token_where_line (token
),
2492 ffelex_token_where_column (token
));
2497 ffebad_start (FFEBAD_TYPELESS_OVERFLOW
);
2498 ffebad_here (0, ffelex_token_where_line (token
),
2499 ffelex_token_where_column (token
));
2505 return !bad_digit
&& !overflow
;
2509 ffetarget_verify_character1 (mallocPool pool
, ffetargetCharacter1 val
)
2511 if (val
.length
!= 0)
2512 malloc_verify_kp (pool
, val
.text
, val
.length
);
2515 /* This is like memcpy. It is needed because some systems' header files
2516 don't declare memcpy as a function but instead
2517 "#define memcpy(to,from,len) something". */
2520 ffetarget_memcpy_ (void *dst
, void *src
, size_t len
)
2522 #ifdef CROSS_COMPILE
2523 /* HOST_WORDS_BIG_ENDIAN corresponds to both WORDS_BIG_ENDIAN and
2524 BYTES_BIG_ENDIAN (i.e. there are no HOST_ macros to represent a
2525 difference in the two latter). */
2526 int host_words_big_endian
=
2527 #ifndef HOST_WORDS_BIG_ENDIAN
2530 HOST_WORDS_BIG_ENDIAN
2534 /* This is just hands thrown up in the air over bits coming through this
2535 function representing a number being memcpy:d as-is from host to
2536 target. We can't generally adjust endianness here since we don't
2537 know whether it's an integer or floating point number; they're passed
2538 differently. Better to not emit code at all than to emit wrong code.
2539 We will get some false hits because some data coming through here
2540 seems to be just character vectors, but often enough it's numbers,
2541 for instance in g77.f-torture/execute/980628-[4-6].f and alpha2.f.
2542 Still, we compile *some* code. FIXME: Rewrite handling of numbers. */
2543 if (!WORDS_BIG_ENDIAN
!= !host_words_big_endian
2544 || !BYTES_BIG_ENDIAN
!= !host_words_big_endian
)
2545 sorry ("data initializer on host with different endianness");
2547 #endif /* CROSS_COMPILE */
2549 return (void *) memcpy (dst
, src
, len
);
2552 /* ffetarget_num_digits_ -- Determine number of non-space characters in token
2554 ffetarget_num_digits_(token);
2556 All non-spaces are assumed to be binary, octal, or hex digits. */
2559 ffetarget_num_digits_ (ffelexToken token
)
2564 switch (ffelex_token_type (token
))
2566 case FFELEX_typeNAME
:
2567 case FFELEX_typeNUMBER
:
2568 return ffelex_token_length (token
);
2570 case FFELEX_typeCHARACTER
:
2572 for (c
= ffelex_token_text (token
); *c
!= '\0'; ++c
)
2580 assert ("weird token" == NULL
);