FSF GCC merge 02/23/03
[official-gcc.git] / gcc / f / target.c
blob35eed17c55c12f83896950af0ad0261e83dcdebc
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)
10 any later version.
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
20 02111-1307, USA.
22 Related Modules:
23 None
25 Description:
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
48 manageable.
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
64 instead.
66 Modifications:
69 /* Include files. */
71 #include "proj.h"
72 #include "target.h"
73 #include "diagnostic.h"
74 #include "bad.h"
75 #include "info.h"
76 #include "lex.h"
77 #include "malloc.h"
78 #include "real.h"
79 #include "toplev.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))
110 #else
111 #define FFETARGET_ATOF_(p,m) atof ((p))
112 #endif
115 /* ffetarget_print_char_ -- Print a single character (in apostrophe context)
117 See prototype.
119 Outputs char so it prints or is escaped C style. */
121 static void
122 ffetarget_print_char_ (FILE *f, unsigned char c)
124 switch (c)
126 case '\\':
127 fputs ("\\\\", f);
128 break;
130 case '\'':
131 fputs ("\\\'", f);
132 break;
134 default:
135 if (ISPRINT (c))
136 fputc (c, f);
137 else
138 fprintf (f, "\\%03o", (unsigned int) c);
139 break;
143 /* ffetarget_aggregate_info -- Determine type for aggregate storage area
145 See prototype.
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
150 machines).
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
159 types mixed in.
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. */
167 void
168 ffetarget_aggregate_info (ffeinfoBasictype *ebt, ffeinfoKindtype *ekt,
169 ffetargetAlign *units, ffeinfoBasictype abt,
170 ffeinfoKindtype akt)
172 ffetype type;
174 if ((abt == FFEINFO_basictypeNONE) || (abt == FFEINFO_basictypeANY)
175 || (akt == FFEINFO_kindtypeNONE))
177 *ebt = FFEINFO_basictypeCHARACTER;
178 *ekt = FFEINFO_kindtypeCHARACTERDEFAULT;
180 else
182 *ebt = abt;
183 *ekt = akt;
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
194 See prototype.
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. */
203 ffetargetAlign
204 ffetarget_align (ffetargetAlign *updated_alignment,
205 ffetargetAlign *updated_modulo, ffetargetOffset offset,
206 ffetargetAlign alignment, ffetargetAlign modulo)
208 ffetargetAlign pad;
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. */
216 ffetargetAlign i;
217 ffetargetAlign j;
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);
230 else
231 pad = *updated_modulo - modulo;
232 if (offset < 0)
233 /* De-negatize offset, since % wouldn't do the expected thing. */
234 offset = alignment - ((- offset) % alignment);
235 pad = (offset + pad) % alignment;
236 if (pad != 0)
237 pad = alignment - pad;
238 return pad;
241 /* Sigh, find LCM (Least Common Multiple) for the two alignment factors. */
243 for (ua = *updated_alignment, ucnt = 1;
244 ua % alignment != 0;
245 ua += *updated_alignment)
246 ++ucnt;
248 cnt = ua / alignment;
250 if (offset < 0)
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
260 use that one. */
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. */
267 if (m > um)
268 pad = ua - (m - um);
269 else
270 pad = um - m;
271 pad = (offset + pad) % ua;
272 if (pad == 0)
274 /* A zero pad means we've got something useful. */
275 *updated_alignment = ua;
276 *updated_modulo = um;
277 return 0;
279 pad = ua - pad;
280 if (pad < min_pad)
281 { /* New minimum padding value. */
282 min_pad = pad;
283 min_m = um;
288 *updated_alignment = ua;
289 *updated_modulo = min_m;
290 return min_pad;
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
298 in the code. */
300 #if FFETARGET_okCHARACTER1
301 bool
302 ffetarget_character1 (ffetargetCharacter1 *val, ffelexToken character,
303 mallocPool pool)
305 val->length = ffelex_token_length (character);
306 if (val->length == 0)
307 val->text = NULL;
308 else
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';
315 return TRUE;
318 #endif
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)
328 return -1;
329 if (l.length > r.length)
330 return 1;
331 if (l.length == 0)
332 return 0;
333 return memcmp (l.text, r.text, l.length);
336 #endif
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
344 in the code. */
346 #if FFETARGET_okCHARACTER1
347 ffebad
348 ffetarget_concatenate_character1 (ffetargetCharacter1 *res,
349 ffetargetCharacter1 l, ffetargetCharacter1 r, mallocPool pool,
350 ffetargetCharacterSize *len)
352 res->length = *len = l.length + r.length;
353 if (*len == 0)
354 res->text = NULL;
355 else
357 res->text = malloc_new_kp (pool, "ffetargetCharacter1(CONCAT)", *len + 1);
358 if (l.length != 0)
359 memcpy (res->text, l.text, l.length);
360 if (r.length != 0)
361 memcpy (res->text + l.length, r.text, r.length);
362 res->text[*len] = '\0';
365 return FFEBAD;
368 #endif
369 /* ffetarget_eq_character1 -- Perform relational comparison on char constants
371 Compare lengths, if equal then use memcmp. */
373 #if FFETARGET_okCHARACTER1
374 ffebad
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);
380 return FFEBAD;
383 #endif
384 /* ffetarget_le_character1 -- Perform relational comparison on char constants
386 Compare lengths, if equal then use memcmp. */
388 #if FFETARGET_okCHARACTER1
389 ffebad
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);
395 return FFEBAD;
398 #endif
399 /* ffetarget_lt_character1 -- Perform relational comparison on char constants
401 Compare lengths, if equal then use memcmp. */
403 #if FFETARGET_okCHARACTER1
404 ffebad
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);
410 return FFEBAD;
413 #endif
414 /* ffetarget_ge_character1 -- Perform relational comparison on char constants
416 Compare lengths, if equal then use memcmp. */
418 #if FFETARGET_okCHARACTER1
419 ffebad
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);
425 return FFEBAD;
428 #endif
429 /* ffetarget_gt_character1 -- Perform relational comparison on char constants
431 Compare lengths, if equal then use memcmp. */
433 #if FFETARGET_okCHARACTER1
434 ffebad
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);
440 return FFEBAD;
442 #endif
444 #if FFETARGET_okCHARACTER1
445 bool
446 ffetarget_iszero_character1 (ffetargetCharacter1 constant)
448 ffetargetCharacterSize i;
450 for (i = 0; i < constant.length; ++i)
451 if (constant.text[i] != 0)
452 return FALSE;
453 return TRUE;
455 #endif
457 bool
458 ffetarget_iszero_hollerith (ffetargetHollerith constant)
460 ffetargetHollerithSize i;
462 for (i = 0; i < constant.length; ++i)
463 if (constant.text[i] != 0)
464 return FALSE;
465 return TRUE;
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). */
473 void
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. */
482 ffetype type;
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
493 if (!ok)
494 ffetarget_offset_overflow (error_text);
495 #endif
497 else
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);
505 *alignment = 1;
506 *modulo = 0;
507 *size = 0;
511 /* ffetarget_ne_character1 -- Perform relational comparison on char constants
513 Compare lengths, if equal then use memcmp. */
515 #if FFETARGET_okCHARACTER1
516 ffebad
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);
522 return FFEBAD;
525 #endif
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
533 in the code. */
535 #if FFETARGET_okCHARACTER1
536 ffebad
537 ffetarget_substr_character1 (ffetargetCharacter1 *res,
538 ffetargetCharacter1 l,
539 ffetargetCharacterSize first,
540 ffetargetCharacterSize last, mallocPool pool,
541 ffetargetCharacterSize *len)
543 if (last < first)
545 res->length = *len = 0;
546 res->text = NULL;
548 else
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';
556 return FFEBAD;
559 #endif
560 /* ffetarget_cmp_hollerith -- Produce orderable comparison between two
561 constants
563 Compare lengths, if equal then use memcmp. */
566 ffetarget_cmp_hollerith (ffetargetHollerith l, ffetargetHollerith r)
568 if (l.length < r.length)
569 return -1;
570 if (l.length > r.length)
571 return 1;
572 return memcmp (l.text, r.text, l.length);
575 ffebad
576 ffetarget_convert_any_character1_ (char *res, size_t size,
577 ffetargetCharacter1 l)
579 if (size <= (size_t) l.length)
581 char *p;
582 ffetargetCharacterSize i;
584 memcpy (res, l.text, size);
585 for (p = &l.text[0] + size, i = l.length - size;
586 i > 0;
587 ++p, --i)
588 if (*p != ' ')
589 return FFEBAD_TRUNCATING_CHARACTER;
591 else
593 memcpy (res, l.text, size);
594 memset (res + l.length, ' ', size - l.length);
597 return FFEBAD;
600 ffebad
601 ffetarget_convert_any_hollerith_ (char *res, size_t size,
602 ffetargetHollerith l)
604 if (size <= (size_t) l.length)
606 char *p;
607 ffetargetCharacterSize i;
609 memcpy (res, l.text, size);
610 for (p = &l.text[0] + size, i = l.length - size;
611 i > 0;
612 ++p, --i)
613 if (*p != ' ')
614 return FFEBAD_TRUNCATING_HOLLERITH;
616 else
618 memcpy (res, l.text, size);
619 memset (res + l.length, ' ', size - l.length);
622 return FFEBAD;
625 ffebad
626 ffetarget_convert_any_typeless_ (char *res, size_t size,
627 ffetargetTypeless l)
629 unsigned long long int l1;
630 unsigned long int l2;
631 unsigned int l3;
632 unsigned short int l4;
633 unsigned char l5;
634 size_t size_of;
635 char *p;
637 if (size >= sizeof (l1))
639 l1 = l;
640 p = (char *) &l1;
641 size_of = sizeof (l1);
643 else if (size >= sizeof (l2))
645 l2 = l;
646 p = (char *) &l2;
647 size_of = sizeof (l2);
648 l1 = l2;
650 else if (size >= sizeof (l3))
652 l3 = l;
653 p = (char *) &l3;
654 size_of = sizeof (l3);
655 l1 = l3;
657 else if (size >= sizeof (l4))
659 l4 = l;
660 p = (char *) &l4;
661 size_of = sizeof (l4);
662 l1 = l4;
664 else if (size >= sizeof (l5))
666 l5 = l;
667 p = (char *) &l5;
668 size_of = sizeof (l5);
669 l1 = l5;
671 else
673 assert ("stumped by conversion from typeless!" == NULL);
674 abort ();
677 if (size <= size_of)
679 int i = size_of - size;
681 memcpy (res, p + i, size);
682 for (; i > 0; ++p, --i)
683 if (*p != '\0')
684 return FFEBAD_TRUNCATING_TYPELESS;
686 else
688 int i = size - size_of;
690 memset (res, 0, i);
691 memcpy (res + i, p, size_of);
694 if (l1 != l)
695 return FFEBAD_TRUNCATING_TYPELESS;
696 return FFEBAD;
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
704 in the code. */
706 #if FFETARGET_okCHARACTER1
707 ffebad
708 ffetarget_convert_character1_character1 (ffetargetCharacter1 *res,
709 ffetargetCharacterSize size,
710 ffetargetCharacter1 l,
711 mallocPool pool)
713 res->length = size;
714 if (size == 0)
715 res->text = NULL;
716 else
718 res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1);
719 if (size <= l.length)
720 memcpy (res->text, l.text, size);
721 else
723 memcpy (res->text, l.text, l.length);
724 memset (res->text + l.length, ' ', size - l.length);
726 res->text[size] = '\0';
729 return FFEBAD;
732 #endif
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
739 in the code. */
741 #if FFETARGET_okCHARACTER1
742 ffebad
743 ffetarget_convert_character1_hollerith (ffetargetCharacter1 *res,
744 ffetargetCharacterSize size,
745 ffetargetHollerith l, mallocPool pool)
747 res->length = size;
748 if (size == 0)
749 res->text = NULL;
750 else
752 res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1);
753 res->text[size] = '\0';
754 if (size <= l.length)
756 char *p;
757 ffetargetCharacterSize i;
759 memcpy (res->text, l.text, size);
760 for (p = &l.text[0] + size, i = l.length - size;
761 i > 0;
762 ++p, --i)
763 if (*p != ' ')
764 return FFEBAD_TRUNCATING_HOLLERITH;
766 else
768 memcpy (res->text, l.text, l.length);
769 memset (res->text + l.length, ' ', size - l.length);
773 return FFEBAD;
776 #endif
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
784 in the code. */
786 #if FFETARGET_okCHARACTER1
787 ffebad
788 ffetarget_convert_character1_integer4 (ffetargetCharacter1 *res,
789 ffetargetCharacterSize size,
790 ffetargetInteger4 l, mallocPool pool)
792 long long int l1;
793 long int l2;
794 int l3;
795 short int l4;
796 char l5;
797 size_t size_of;
798 char *p;
800 if (((size_t) size) >= sizeof (l1))
802 l1 = l;
803 p = (char *) &l1;
804 size_of = sizeof (l1);
806 else if (((size_t) size) >= sizeof (l2))
808 l2 = l;
809 p = (char *) &l2;
810 size_of = sizeof (l2);
811 l1 = l2;
813 else if (((size_t) size) >= sizeof (l3))
815 l3 = l;
816 p = (char *) &l3;
817 size_of = sizeof (l3);
818 l1 = l3;
820 else if (((size_t) size) >= sizeof (l4))
822 l4 = l;
823 p = (char *) &l4;
824 size_of = sizeof (l4);
825 l1 = l4;
827 else if (((size_t) size) >= sizeof (l5))
829 l5 = l;
830 p = (char *) &l5;
831 size_of = sizeof (l5);
832 l1 = l5;
834 else
836 assert ("stumped by conversion from integer1!" == NULL);
837 abort ();
840 res->length = size;
841 if (size == 0)
842 res->text = NULL;
843 else
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)
853 if (*p != 0)
854 return FFEBAD_TRUNCATING_NUMERIC;
856 else
858 int i = size - size_of;
860 memset (res->text, 0, i);
861 memcpy (res->text + i, p, size_of);
865 if (l1 != l)
866 return FFEBAD_TRUNCATING_NUMERIC;
867 return FFEBAD;
870 #endif
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
878 in the code. */
880 #if FFETARGET_okCHARACTER1
881 ffebad
882 ffetarget_convert_character1_logical4 (ffetargetCharacter1 *res,
883 ffetargetCharacterSize size,
884 ffetargetLogical4 l, mallocPool pool)
886 long long int l1;
887 long int l2;
888 int l3;
889 short int l4;
890 char l5;
891 size_t size_of;
892 char *p;
894 if (((size_t) size) >= sizeof (l1))
896 l1 = l;
897 p = (char *) &l1;
898 size_of = sizeof (l1);
900 else if (((size_t) size) >= sizeof (l2))
902 l2 = l;
903 p = (char *) &l2;
904 size_of = sizeof (l2);
905 l1 = l2;
907 else if (((size_t) size) >= sizeof (l3))
909 l3 = l;
910 p = (char *) &l3;
911 size_of = sizeof (l3);
912 l1 = l3;
914 else if (((size_t) size) >= sizeof (l4))
916 l4 = l;
917 p = (char *) &l4;
918 size_of = sizeof (l4);
919 l1 = l4;
921 else if (((size_t) size) >= sizeof (l5))
923 l5 = l;
924 p = (char *) &l5;
925 size_of = sizeof (l5);
926 l1 = l5;
928 else
930 assert ("stumped by conversion from logical1!" == NULL);
931 abort ();
934 res->length = size;
935 if (size == 0)
936 res->text = NULL;
937 else
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)
947 if (*p != 0)
948 return FFEBAD_TRUNCATING_NUMERIC;
950 else
952 int i = size - size_of;
954 memset (res->text, 0, i);
955 memcpy (res->text + i, p, size_of);
959 if (l1 != l)
960 return FFEBAD_TRUNCATING_NUMERIC;
961 return FFEBAD;
964 #endif
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
972 in the code. */
974 #if FFETARGET_okCHARACTER1
975 ffebad
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;
982 unsigned int l3;
983 unsigned short int l4;
984 unsigned char l5;
985 size_t size_of;
986 char *p;
988 if (((size_t) size) >= sizeof (l1))
990 l1 = l;
991 p = (char *) &l1;
992 size_of = sizeof (l1);
994 else if (((size_t) size) >= sizeof (l2))
996 l2 = l;
997 p = (char *) &l2;
998 size_of = sizeof (l2);
999 l1 = l2;
1001 else if (((size_t) size) >= sizeof (l3))
1003 l3 = l;
1004 p = (char *) &l3;
1005 size_of = sizeof (l3);
1006 l1 = l3;
1008 else if (((size_t) size) >= sizeof (l4))
1010 l4 = l;
1011 p = (char *) &l4;
1012 size_of = sizeof (l4);
1013 l1 = l4;
1015 else if (((size_t) size) >= sizeof (l5))
1017 l5 = l;
1018 p = (char *) &l5;
1019 size_of = sizeof (l5);
1020 l1 = l5;
1022 else
1024 assert ("stumped by conversion from typeless!" == NULL);
1025 abort ();
1028 res->length = size;
1029 if (size == 0)
1030 res->text = NULL;
1031 else
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)
1041 if (*p != 0)
1042 return FFEBAD_TRUNCATING_TYPELESS;
1044 else
1046 int i = size - size_of;
1048 memset (res->text, 0, i);
1049 memcpy (res->text + i, p, size_of);
1053 if (l1 != l)
1054 return FFEBAD_TRUNCATING_TYPELESS;
1055 return FFEBAD;
1058 #endif
1059 /* ffetarget_divide_complex1 -- Divide function
1061 See prototype. */
1063 #if FFETARGET_okCOMPLEX1
1064 ffebad
1065 ffetarget_divide_complex1 (ffetargetComplex1 *res, ffetargetComplex1 l,
1066 ffetargetComplex1 r)
1068 ffebad bad;
1069 ffetargetReal1 tmp1, tmp2, tmp3, tmp4;
1071 bad = ffetarget_multiply_real1 (&tmp1, r.real, r.real);
1072 if (bad != FFEBAD)
1073 return bad;
1074 bad = ffetarget_multiply_real1 (&tmp2, r.imaginary, r.imaginary);
1075 if (bad != FFEBAD)
1076 return bad;
1077 bad = ffetarget_add_real1 (&tmp3, tmp1, tmp2);
1078 if (bad != FFEBAD)
1079 return bad;
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);
1089 if (bad != FFEBAD)
1090 return bad;
1091 bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, r.imaginary);
1092 if (bad != FFEBAD)
1093 return bad;
1094 bad = ffetarget_add_real1 (&tmp4, tmp1, tmp2);
1095 if (bad != FFEBAD)
1096 return bad;
1097 bad = ffetarget_divide_real1 (&res->real, tmp4, tmp3);
1098 if (bad != FFEBAD)
1099 return bad;
1101 bad = ffetarget_multiply_real1 (&tmp1, r.real, l.imaginary);
1102 if (bad != FFEBAD)
1103 return bad;
1104 bad = ffetarget_multiply_real1 (&tmp2, l.real, r.imaginary);
1105 if (bad != FFEBAD)
1106 return bad;
1107 bad = ffetarget_subtract_real1 (&tmp4, tmp1, tmp2);
1108 if (bad != FFEBAD)
1109 return bad;
1110 bad = ffetarget_divide_real1 (&res->imaginary, tmp4, tmp3);
1112 return FFEBAD;
1115 #endif
1116 /* ffetarget_divide_complex2 -- Divide function
1118 See prototype. */
1120 #if FFETARGET_okCOMPLEX2
1121 ffebad
1122 ffetarget_divide_complex2 (ffetargetComplex2 *res, ffetargetComplex2 l,
1123 ffetargetComplex2 r)
1125 ffebad bad;
1126 ffetargetReal2 tmp1, tmp2, tmp3, tmp4;
1128 bad = ffetarget_multiply_real2 (&tmp1, r.real, r.real);
1129 if (bad != FFEBAD)
1130 return bad;
1131 bad = ffetarget_multiply_real2 (&tmp2, r.imaginary, r.imaginary);
1132 if (bad != FFEBAD)
1133 return bad;
1134 bad = ffetarget_add_real2 (&tmp3, tmp1, tmp2);
1135 if (bad != FFEBAD)
1136 return bad;
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);
1146 if (bad != FFEBAD)
1147 return bad;
1148 bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, r.imaginary);
1149 if (bad != FFEBAD)
1150 return bad;
1151 bad = ffetarget_add_real2 (&tmp4, tmp1, tmp2);
1152 if (bad != FFEBAD)
1153 return bad;
1154 bad = ffetarget_divide_real2 (&res->real, tmp4, tmp3);
1155 if (bad != FFEBAD)
1156 return bad;
1158 bad = ffetarget_multiply_real2 (&tmp1, r.real, l.imaginary);
1159 if (bad != FFEBAD)
1160 return bad;
1161 bad = ffetarget_multiply_real2 (&tmp2, l.real, r.imaginary);
1162 if (bad != FFEBAD)
1163 return bad;
1164 bad = ffetarget_subtract_real2 (&tmp4, tmp1, tmp2);
1165 if (bad != FFEBAD)
1166 return bad;
1167 bad = ffetarget_divide_real2 (&res->imaginary, tmp4, tmp3);
1169 return FFEBAD;
1172 #endif
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
1180 in the code. */
1182 bool
1183 ffetarget_hollerith (ffetargetHollerith *val, ffelexToken integer,
1184 mallocPool pool)
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';
1191 return TRUE;
1194 /* ffetarget_integer_bad_magical -- Complain about a magical number
1196 Just calls ffebad with the arguments. */
1198 void
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));
1203 ffebad_finish ();
1206 /* ffetarget_integer_bad_magical_binary -- Complain about a magical number
1208 Just calls ffebad with the arguments. */
1210 void
1211 ffetarget_integer_bad_magical_binary (ffelexToken integer,
1212 ffelexToken minus)
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));
1219 ffebad_finish ();
1222 /* ffetarget_integer_bad_magical_precedence -- Complain about a magical
1223 number
1225 Just calls ffebad with the arguments. */
1227 void
1228 ffetarget_integer_bad_magical_precedence (ffelexToken integer,
1229 ffelexToken uminus,
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));
1239 ffebad_finish ();
1242 /* ffetarget_integer_bad_magical_precedence_binary -- Complain...
1244 Just calls ffebad with the arguments. */
1246 void
1247 ffetarget_integer_bad_magical_precedence_binary (ffelexToken integer,
1248 ffelexToken minus,
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));
1258 ffebad_finish ();
1261 /* ffetarget_integer1 -- Convert token to an integer
1263 See prototype.
1265 Token use count not affected overall. */
1267 #if FFETARGET_okINTEGER1
1268 bool
1269 ffetarget_integer1 (ffetargetInteger1 *val, ffelexToken integer)
1271 ffetargetInteger1 x;
1272 char *p;
1273 char c;
1275 assert (ffelex_token_type (integer) == FFELEX_typeNUMBER);
1277 p = ffelex_token_text (integer);
1278 x = 0;
1280 /* Skip past leading zeros. */
1282 while (((c = *p) != '\0') && (c == '0'))
1283 ++p;
1285 /* Interpret rest of number. */
1287 while (c != '\0')
1289 if ((x == FFETARGET_integerALMOST_BIG_MAGICAL)
1290 && (c == '0' + FFETARGET_integerFINISH_BIG_MAGICAL)
1291 && (*(p + 1) == '\0'))
1293 *val = (ffetargetInteger1) FFETARGET_integerBIG_MAGICAL;
1294 return TRUE;
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));
1304 ffebad_finish ();
1305 *val = 0;
1306 return FALSE;
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));
1314 ffebad_finish ();
1315 *val = 0;
1316 return FALSE;
1318 x = x * 10 + c - '0';
1319 c = *(++p);
1322 *val = x;
1323 return TRUE;
1326 #endif
1327 /* ffetarget_integerbinary -- Convert token to a binary integer
1329 ffetarget_integerbinary x;
1330 if (ffetarget_integerdefault_8(&x,integer_token))
1331 // conversion ok.
1333 Token use count not affected overall. */
1335 bool
1336 ffetarget_integerbinary (ffetargetIntegerDefault *val, ffelexToken integer)
1338 ffetargetIntegerDefault x;
1339 char *p;
1340 char c;
1341 bool bad_digit;
1343 assert ((ffelex_token_type (integer) == FFELEX_typeNAME)
1344 || (ffelex_token_type (integer) == FFELEX_typeNUMBER));
1346 p = ffelex_token_text (integer);
1347 x = 0;
1349 /* Skip past leading zeros. */
1351 while (((c = *p) != '\0') && (c == '0'))
1352 ++p;
1354 /* Interpret rest of number. */
1356 bad_digit = FALSE;
1357 while (c != '\0')
1359 if ((c >= '0') && (c <= '1'))
1360 c -= '0';
1361 else
1363 bad_digit = TRUE;
1364 c = 0;
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;
1374 return TRUE;
1376 else
1377 #endif
1378 #if FFETARGET_integerFINISH_BIG_OVERFLOW_BINARY == 0
1379 if ((x & FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY) != 0)
1380 #else
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));
1389 ffebad_finish ();
1390 *val = 0;
1391 return FALSE;
1394 else if (x > FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY)
1395 #endif
1397 ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1398 ffebad_here (0, ffelex_token_where_line (integer),
1399 ffelex_token_where_column (integer));
1400 ffebad_finish ();
1401 *val = 0;
1402 return FALSE;
1404 x = (x << 1) + c;
1405 c = *(++p);
1408 if (bad_digit)
1410 ffebad_start (FFEBAD_INVALID_BINARY_DIGIT);
1411 ffebad_here (0, ffelex_token_where_line (integer),
1412 ffelex_token_where_column (integer));
1413 ffebad_finish ();
1416 *val = x;
1417 return !bad_digit;
1420 /* ffetarget_integerhex -- Convert token to a hex integer
1422 ffetarget_integerhex x;
1423 if (ffetarget_integerdefault_8(&x,integer_token))
1424 // conversion ok.
1426 Token use count not affected overall. */
1428 bool
1429 ffetarget_integerhex (ffetargetIntegerDefault *val, ffelexToken integer)
1431 ffetargetIntegerDefault x;
1432 char *p;
1433 char c;
1434 bool bad_digit;
1436 assert ((ffelex_token_type (integer) == FFELEX_typeNAME)
1437 || (ffelex_token_type (integer) == FFELEX_typeNUMBER));
1439 p = ffelex_token_text (integer);
1440 x = 0;
1442 /* Skip past leading zeros. */
1444 while (((c = *p) != '\0') && (c == '0'))
1445 ++p;
1447 /* Interpret rest of number. */
1449 bad_digit = FALSE;
1450 while (c != '\0')
1452 if (hex_p (c))
1453 c = hex_value (c);
1454 else
1456 bad_digit = TRUE;
1457 c = 0;
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;
1467 return TRUE;
1469 else
1470 #endif
1471 #if FFETARGET_integerFINISH_BIG_OVERFLOW_HEX == 0
1472 if (x >= FFETARGET_integerALMOST_BIG_OVERFLOW_HEX)
1473 #else
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));
1482 ffebad_finish ();
1483 *val = 0;
1484 return FALSE;
1487 else if (x > FFETARGET_integerALMOST_BIG_OVERFLOW_HEX)
1488 #endif
1490 ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1491 ffebad_here (0, ffelex_token_where_line (integer),
1492 ffelex_token_where_column (integer));
1493 ffebad_finish ();
1494 *val = 0;
1495 return FALSE;
1497 x = (x << 4) + c;
1498 c = *(++p);
1501 if (bad_digit)
1503 ffebad_start (FFEBAD_INVALID_HEX_DIGIT);
1504 ffebad_here (0, ffelex_token_where_line (integer),
1505 ffelex_token_where_column (integer));
1506 ffebad_finish ();
1509 *val = x;
1510 return !bad_digit;
1513 /* ffetarget_integeroctal -- Convert token to an octal integer
1515 ffetarget_integeroctal x;
1516 if (ffetarget_integerdefault_8(&x,integer_token))
1517 // conversion ok.
1519 Token use count not affected overall. */
1521 bool
1522 ffetarget_integeroctal (ffetargetIntegerDefault *val, ffelexToken integer)
1524 ffetargetIntegerDefault x;
1525 char *p;
1526 char c;
1527 bool bad_digit;
1529 assert ((ffelex_token_type (integer) == FFELEX_typeNAME)
1530 || (ffelex_token_type (integer) == FFELEX_typeNUMBER));
1532 p = ffelex_token_text (integer);
1533 x = 0;
1535 /* Skip past leading zeros. */
1537 while (((c = *p) != '\0') && (c == '0'))
1538 ++p;
1540 /* Interpret rest of number. */
1542 bad_digit = FALSE;
1543 while (c != '\0')
1545 if ((c >= '0') && (c <= '7'))
1546 c -= '0';
1547 else
1549 bad_digit = TRUE;
1550 c = 0;
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;
1560 return TRUE;
1562 else
1563 #endif
1564 #if FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL == 0
1565 if (x >= FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
1566 #else
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));
1575 ffebad_finish ();
1576 *val = 0;
1577 return FALSE;
1580 else if (x > FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
1581 #endif
1583 ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1584 ffebad_here (0, ffelex_token_where_line (integer),
1585 ffelex_token_where_column (integer));
1586 ffebad_finish ();
1587 *val = 0;
1588 return FALSE;
1590 x = (x << 3) + c;
1591 c = *(++p);
1594 if (bad_digit)
1596 ffebad_start (FFEBAD_INVALID_OCTAL_DIGIT);
1597 ffebad_here (0, ffelex_token_where_line (integer),
1598 ffelex_token_where_column (integer));
1599 ffebad_finish ();
1602 *val = x;
1603 return !bad_digit;
1606 /* ffetarget_multiply_complex1 -- Multiply function
1608 See prototype. */
1610 #if FFETARGET_okCOMPLEX1
1611 ffebad
1612 ffetarget_multiply_complex1 (ffetargetComplex1 *res, ffetargetComplex1 l,
1613 ffetargetComplex1 r)
1615 ffebad bad;
1616 ffetargetReal1 tmp1, tmp2;
1618 bad = ffetarget_multiply_real1 (&tmp1, l.real, r.real);
1619 if (bad != FFEBAD)
1620 return bad;
1621 bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, r.imaginary);
1622 if (bad != FFEBAD)
1623 return bad;
1624 bad = ffetarget_subtract_real1 (&res->real, tmp1, tmp2);
1625 if (bad != FFEBAD)
1626 return bad;
1627 bad = ffetarget_multiply_real1 (&tmp1, l.imaginary, r.real);
1628 if (bad != FFEBAD)
1629 return bad;
1630 bad = ffetarget_multiply_real1 (&tmp2, l.real, r.imaginary);
1631 if (bad != FFEBAD)
1632 return bad;
1633 bad = ffetarget_add_real1 (&res->imaginary, tmp1, tmp2);
1635 return bad;
1638 #endif
1639 /* ffetarget_multiply_complex2 -- Multiply function
1641 See prototype. */
1643 #if FFETARGET_okCOMPLEX2
1644 ffebad
1645 ffetarget_multiply_complex2 (ffetargetComplex2 *res, ffetargetComplex2 l,
1646 ffetargetComplex2 r)
1648 ffebad bad;
1649 ffetargetReal2 tmp1, tmp2;
1651 bad = ffetarget_multiply_real2 (&tmp1, l.real, r.real);
1652 if (bad != FFEBAD)
1653 return bad;
1654 bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, r.imaginary);
1655 if (bad != FFEBAD)
1656 return bad;
1657 bad = ffetarget_subtract_real2 (&res->real, tmp1, tmp2);
1658 if (bad != FFEBAD)
1659 return bad;
1660 bad = ffetarget_multiply_real2 (&tmp1, l.imaginary, r.real);
1661 if (bad != FFEBAD)
1662 return bad;
1663 bad = ffetarget_multiply_real2 (&tmp2, l.real, r.imaginary);
1664 if (bad != FFEBAD)
1665 return bad;
1666 bad = ffetarget_add_real2 (&res->imaginary, tmp1, tmp2);
1668 return bad;
1671 #endif
1672 /* ffetarget_power_complexdefault_integerdefault -- Power function
1674 See prototype. */
1676 ffebad
1677 ffetarget_power_complexdefault_integerdefault (ffetargetComplexDefault *res,
1678 ffetargetComplexDefault l,
1679 ffetargetIntegerDefault r)
1681 ffebad bad;
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);
1692 return FFEBAD;
1695 if (r == 0)
1697 ffetarget_real1_one (&res->real);
1698 ffetarget_real1_zero (&res->imaginary);
1699 return FFEBAD;
1702 if (r < 0)
1704 r = -r;
1705 bad = ffetarget_multiply_real1 (&tmp1, l.real, l.real);
1706 if (bad != FFEBAD)
1707 return bad;
1708 bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, l.imaginary);
1709 if (bad != FFEBAD)
1710 return bad;
1711 bad = ffetarget_add_real1 (&tmp, tmp1, tmp2);
1712 if (bad != FFEBAD)
1713 return bad;
1714 bad = ffetarget_divide_real1 (&l.real, l.real, tmp);
1715 if (bad != FFEBAD)
1716 return bad;
1717 bad = ffetarget_divide_real1 (&l.imaginary, l.imaginary, tmp);
1718 if (bad != FFEBAD)
1719 return bad;
1720 bad = ffetarget_uminus_real1 (&l.imaginary, l.imaginary);
1721 if (bad != FFEBAD)
1722 return bad;
1725 ffetarget_real1_two (&two);
1727 while ((r & 1) == 0)
1729 bad = ffetarget_multiply_real1 (&tmp1, l.real, l.real);
1730 if (bad != FFEBAD)
1731 return bad;
1732 bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, l.imaginary);
1733 if (bad != FFEBAD)
1734 return bad;
1735 bad = ffetarget_subtract_real1 (&tmp, tmp1, tmp2);
1736 if (bad != FFEBAD)
1737 return bad;
1738 bad = ffetarget_multiply_real1 (&l.imaginary, l.real, l.imaginary);
1739 if (bad != FFEBAD)
1740 return bad;
1741 bad = ffetarget_multiply_real1 (&l.imaginary, l.imaginary, two);
1742 if (bad != FFEBAD)
1743 return bad;
1744 l.real = tmp;
1745 r >>= 1;
1748 *res = l;
1749 r >>= 1;
1751 while (r != 0)
1753 bad = ffetarget_multiply_real1 (&tmp1, l.real, l.real);
1754 if (bad != FFEBAD)
1755 return bad;
1756 bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, l.imaginary);
1757 if (bad != FFEBAD)
1758 return bad;
1759 bad = ffetarget_subtract_real1 (&tmp, tmp1, tmp2);
1760 if (bad != FFEBAD)
1761 return bad;
1762 bad = ffetarget_multiply_real1 (&l.imaginary, l.real, l.imaginary);
1763 if (bad != FFEBAD)
1764 return bad;
1765 bad = ffetarget_multiply_real1 (&l.imaginary, l.imaginary, two);
1766 if (bad != FFEBAD)
1767 return bad;
1768 l.real = tmp;
1769 if ((r & 1) == 1)
1771 bad = ffetarget_multiply_real1 (&tmp1, res->real, l.real);
1772 if (bad != FFEBAD)
1773 return bad;
1774 bad = ffetarget_multiply_real1 (&tmp2, res->imaginary,
1775 l.imaginary);
1776 if (bad != FFEBAD)
1777 return bad;
1778 bad = ffetarget_subtract_real1 (&tmp, tmp1, tmp2);
1779 if (bad != FFEBAD)
1780 return bad;
1781 bad = ffetarget_multiply_real1 (&tmp1, res->imaginary, l.real);
1782 if (bad != FFEBAD)
1783 return bad;
1784 bad = ffetarget_multiply_real1 (&tmp2, res->real, l.imaginary);
1785 if (bad != FFEBAD)
1786 return bad;
1787 bad = ffetarget_add_real1 (&res->imaginary, tmp1, tmp2);
1788 if (bad != FFEBAD)
1789 return bad;
1790 res->real = tmp;
1792 r >>= 1;
1795 return FFEBAD;
1798 /* ffetarget_power_complexdouble_integerdefault -- Power function
1800 See prototype. */
1802 #if FFETARGET_okCOMPLEXDOUBLE
1803 ffebad
1804 ffetarget_power_complexdouble_integerdefault (ffetargetComplexDouble *res,
1805 ffetargetComplexDouble l, ffetargetIntegerDefault r)
1807 ffebad bad;
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);
1818 return FFEBAD;
1821 if (r == 0)
1823 ffetarget_real2_one (&res->real);
1824 ffetarget_real2_zero (&res->imaginary);
1825 return FFEBAD;
1828 if (r < 0)
1830 r = -r;
1831 bad = ffetarget_multiply_real2 (&tmp1, l.real, l.real);
1832 if (bad != FFEBAD)
1833 return bad;
1834 bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, l.imaginary);
1835 if (bad != FFEBAD)
1836 return bad;
1837 bad = ffetarget_add_real2 (&tmp, tmp1, tmp2);
1838 if (bad != FFEBAD)
1839 return bad;
1840 bad = ffetarget_divide_real2 (&l.real, l.real, tmp);
1841 if (bad != FFEBAD)
1842 return bad;
1843 bad = ffetarget_divide_real2 (&l.imaginary, l.imaginary, tmp);
1844 if (bad != FFEBAD)
1845 return bad;
1846 bad = ffetarget_uminus_real2 (&l.imaginary, l.imaginary);
1847 if (bad != FFEBAD)
1848 return bad;
1851 ffetarget_real2_two (&two);
1853 while ((r & 1) == 0)
1855 bad = ffetarget_multiply_real2 (&tmp1, l.real, l.real);
1856 if (bad != FFEBAD)
1857 return bad;
1858 bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, l.imaginary);
1859 if (bad != FFEBAD)
1860 return bad;
1861 bad = ffetarget_subtract_real2 (&tmp, tmp1, tmp2);
1862 if (bad != FFEBAD)
1863 return bad;
1864 bad = ffetarget_multiply_real2 (&l.imaginary, l.real, l.imaginary);
1865 if (bad != FFEBAD)
1866 return bad;
1867 bad = ffetarget_multiply_real2 (&l.imaginary, l.imaginary, two);
1868 if (bad != FFEBAD)
1869 return bad;
1870 l.real = tmp;
1871 r >>= 1;
1874 *res = l;
1875 r >>= 1;
1877 while (r != 0)
1879 bad = ffetarget_multiply_real2 (&tmp1, l.real, l.real);
1880 if (bad != FFEBAD)
1881 return bad;
1882 bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, l.imaginary);
1883 if (bad != FFEBAD)
1884 return bad;
1885 bad = ffetarget_subtract_real2 (&tmp, tmp1, tmp2);
1886 if (bad != FFEBAD)
1887 return bad;
1888 bad = ffetarget_multiply_real2 (&l.imaginary, l.real, l.imaginary);
1889 if (bad != FFEBAD)
1890 return bad;
1891 bad = ffetarget_multiply_real2 (&l.imaginary, l.imaginary, two);
1892 if (bad != FFEBAD)
1893 return bad;
1894 l.real = tmp;
1895 if ((r & 1) == 1)
1897 bad = ffetarget_multiply_real2 (&tmp1, res->real, l.real);
1898 if (bad != FFEBAD)
1899 return bad;
1900 bad = ffetarget_multiply_real2 (&tmp2, res->imaginary,
1901 l.imaginary);
1902 if (bad != FFEBAD)
1903 return bad;
1904 bad = ffetarget_subtract_real2 (&tmp, tmp1, tmp2);
1905 if (bad != FFEBAD)
1906 return bad;
1907 bad = ffetarget_multiply_real2 (&tmp1, res->imaginary, l.real);
1908 if (bad != FFEBAD)
1909 return bad;
1910 bad = ffetarget_multiply_real2 (&tmp2, res->real, l.imaginary);
1911 if (bad != FFEBAD)
1912 return bad;
1913 bad = ffetarget_add_real2 (&res->imaginary, tmp1, tmp2);
1914 if (bad != FFEBAD)
1915 return bad;
1916 res->real = tmp;
1918 r >>= 1;
1921 return FFEBAD;
1924 #endif
1925 /* ffetarget_power_integerdefault_integerdefault -- Power function
1927 See prototype. */
1929 ffebad
1930 ffetarget_power_integerdefault_integerdefault (ffetargetIntegerDefault *res,
1931 ffetargetIntegerDefault l, ffetargetIntegerDefault r)
1933 if (l == 0)
1935 *res = 0;
1936 return FFEBAD;
1939 if (r == 0)
1941 *res = 1;
1942 return FFEBAD;
1945 if (r < 0)
1947 if (l == 1)
1948 *res = 1;
1949 else if (l == 0)
1950 *res = 1;
1951 else if (l == -1)
1952 *res = ((-r) & 1) == 0 ? 1 : -1;
1953 else
1954 *res = 0;
1955 return FFEBAD;
1958 while ((r & 1) == 0)
1960 l *= l;
1961 r >>= 1;
1964 *res = l;
1965 r >>= 1;
1967 while (r != 0)
1969 l *= l;
1970 if ((r & 1) == 1)
1971 *res *= l;
1972 r >>= 1;
1975 return FFEBAD;
1978 /* ffetarget_power_realdefault_integerdefault -- Power function
1980 See prototype. */
1982 ffebad
1983 ffetarget_power_realdefault_integerdefault (ffetargetRealDefault *res,
1984 ffetargetRealDefault l, ffetargetIntegerDefault r)
1986 ffebad bad;
1988 if (ffetarget_iszero_real1 (l))
1990 ffetarget_real1_zero (res);
1991 return FFEBAD;
1994 if (r == 0)
1996 ffetarget_real1_one (res);
1997 return FFEBAD;
2000 if (r < 0)
2002 ffetargetRealDefault one;
2004 ffetarget_real1_one (&one);
2005 r = -r;
2006 bad = ffetarget_divide_real1 (&l, one, l);
2007 if (bad != FFEBAD)
2008 return bad;
2011 while ((r & 1) == 0)
2013 bad = ffetarget_multiply_real1 (&l, l, l);
2014 if (bad != FFEBAD)
2015 return bad;
2016 r >>= 1;
2019 *res = l;
2020 r >>= 1;
2022 while (r != 0)
2024 bad = ffetarget_multiply_real1 (&l, l, l);
2025 if (bad != FFEBAD)
2026 return bad;
2027 if ((r & 1) == 1)
2029 bad = ffetarget_multiply_real1 (res, *res, l);
2030 if (bad != FFEBAD)
2031 return bad;
2033 r >>= 1;
2036 return FFEBAD;
2039 /* ffetarget_power_realdouble_integerdefault -- Power function
2041 See prototype. */
2043 ffebad
2044 ffetarget_power_realdouble_integerdefault (ffetargetRealDouble *res,
2045 ffetargetRealDouble l,
2046 ffetargetIntegerDefault r)
2048 ffebad bad;
2050 if (ffetarget_iszero_real2 (l))
2052 ffetarget_real2_zero (res);
2053 return FFEBAD;
2056 if (r == 0)
2058 ffetarget_real2_one (res);
2059 return FFEBAD;
2062 if (r < 0)
2064 ffetargetRealDouble one;
2066 ffetarget_real2_one (&one);
2067 r = -r;
2068 bad = ffetarget_divide_real2 (&l, one, l);
2069 if (bad != FFEBAD)
2070 return bad;
2073 while ((r & 1) == 0)
2075 bad = ffetarget_multiply_real2 (&l, l, l);
2076 if (bad != FFEBAD)
2077 return bad;
2078 r >>= 1;
2081 *res = l;
2082 r >>= 1;
2084 while (r != 0)
2086 bad = ffetarget_multiply_real2 (&l, l, l);
2087 if (bad != FFEBAD)
2088 return bad;
2089 if ((r & 1) == 1)
2091 bad = ffetarget_multiply_real2 (res, *res, l);
2092 if (bad != FFEBAD)
2093 return bad;
2095 r >>= 1;
2098 return FFEBAD;
2101 /* ffetarget_print_binary -- Output typeless binary integer
2103 ffetargetTypeless val;
2104 ffetarget_typeless_binary(dmpout,val); */
2106 void
2107 ffetarget_print_binary (FILE *f, ffetargetTypeless value)
2109 char *p;
2110 char digits[sizeof (value) * CHAR_BIT + 1];
2112 if (f == NULL)
2113 f = dmpout;
2115 p = &digits[ARRAY_SIZE (digits) - 1];
2116 *p = '\0';
2119 *--p = (value & 1) + '0';
2120 value >>= 1;
2121 } while (value == 0);
2123 fputs (p, f);
2126 /* ffetarget_print_character1 -- Output character string
2128 ffetargetCharacter1 val;
2129 ffetarget_print_character1(dmpout,val); */
2131 void
2132 ffetarget_print_character1 (FILE *f, ffetargetCharacter1 value)
2134 unsigned char *p;
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); */
2148 void
2149 ffetarget_print_hollerith (FILE *f, ffetargetHollerith value)
2151 unsigned char *p;
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); */
2165 void
2166 ffetarget_print_octal (FILE *f, ffetargetTypeless value)
2168 char *p;
2169 char digits[sizeof (value) * CHAR_BIT / 3 + 1];
2171 if (f == NULL)
2172 f = dmpout;
2174 p = &digits[ARRAY_SIZE (digits) - 3];
2175 *p = '\0';
2178 *--p = (value & 3) + '0';
2179 value >>= 3;
2180 } while (value == 0);
2182 fputs (p, f);
2185 /* ffetarget_print_hex -- Output typeless hex integer
2187 ffetargetTypeless val;
2188 ffetarget_print_hex(dmpout,val); */
2190 void
2191 ffetarget_print_hex (FILE *f, ffetargetTypeless value)
2193 char *p;
2194 char digits[sizeof (value) * CHAR_BIT / 4 + 1];
2195 static const char hexdigits[16] = "0123456789ABCDEF";
2197 if (f == NULL)
2198 f = dmpout;
2200 p = &digits[ARRAY_SIZE (digits) - 3];
2201 *p = '\0';
2204 *--p = hexdigits[value & 4];
2205 value >>= 4;
2206 } while (value == 0);
2208 fputs (p, f);
2211 /* ffetarget_real1 -- Convert token to a single-precision real number
2213 See prototype.
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
2222 bool
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];
2230 char *p = ptr;
2231 char *q;
2233 #define dotok(x) if (x != NULL) ++sz;
2234 #define dotoktxt(x) if (x != NULL) sz += ffelex_token_length(x)
2236 dotoktxt (integer);
2237 dotok (decimal);
2238 dotoktxt (fraction);
2239 dotoktxt (exponent);
2240 dotok (exponent_sign);
2241 dotoktxt (exponent_digits);
2243 #undef dotok
2244 #undef dotoktxt
2246 if (sz > ARRAY_SIZE (ffetarget_string_))
2247 p = ptr = (char *) malloc_new_ks (malloc_pool_image (), "ffetarget_real1",
2248 sz);
2250 #define dotoktxt(x) if (x != NULL) \
2252 for (q = ffelex_token_text(x); *q != '\0'; ++q) \
2253 *p++ = *q; \
2256 dotoktxt (integer);
2258 if (decimal != NULL)
2259 *p++ = '.';
2261 dotoktxt (fraction);
2262 dotoktxt (exponent);
2264 if (exponent_sign != NULL)
2266 if (ffelex_token_type (exponent_sign) == FFELEX_typePLUS)
2267 *p++ = '+';
2268 else
2270 assert (ffelex_token_type (exponent_sign) == FFELEX_typeMINUS);
2271 *p++ = '-';
2275 dotoktxt (exponent_digits);
2277 #undef dotoktxt
2279 *p = '\0';
2282 REAL_VALUE_TYPE rv;
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);
2290 return TRUE;
2293 #endif
2294 /* ffetarget_real2 -- Convert token to a single-precision real number
2296 See prototype.
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
2305 bool
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];
2313 char *p = ptr;
2314 char *q;
2316 #define dotok(x) if (x != NULL) ++sz;
2317 #define dotoktxt(x) if (x != NULL) sz += ffelex_token_length(x)
2319 dotoktxt (integer);
2320 dotok (decimal);
2321 dotoktxt (fraction);
2322 dotoktxt (exponent);
2323 dotok (exponent_sign);
2324 dotoktxt (exponent_digits);
2326 #undef dotok
2327 #undef dotoktxt
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) \
2335 *p++ = *q; \
2337 #define dotoktxtexp(x) if (x != NULL) \
2339 *p++ = 'E'; \
2340 for (q = ffelex_token_text(x) + 1; *q != '\0'; ++q) \
2341 *p++ = *q; \
2344 dotoktxt (integer);
2346 if (decimal != NULL)
2347 *p++ = '.';
2349 dotoktxt (fraction);
2350 dotoktxtexp (exponent);
2352 if (exponent_sign != NULL)
2354 if (ffelex_token_type (exponent_sign) == FFELEX_typePLUS)
2355 *p++ = '+';
2356 else
2358 assert (ffelex_token_type (exponent_sign) == FFELEX_typeMINUS);
2359 *p++ = '-';
2363 dotoktxt (exponent_digits);
2365 #undef dotoktxt
2367 *p = '\0';
2370 REAL_VALUE_TYPE rv;
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);
2378 return TRUE;
2381 #endif
2382 bool
2383 ffetarget_typeless_binary (ffetargetTypeless *xvalue, ffelexToken token)
2385 char *p;
2386 char c;
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)
2396 new_value <<= 1;
2397 if ((new_value >> 1) != value)
2398 overflow = TRUE;
2399 if (ISDIGIT (c))
2400 new_value += c - '0';
2401 else
2402 bad_digit = TRUE;
2403 value = new_value;
2406 if (bad_digit)
2408 ffebad_start (FFEBAD_INVALID_TYPELESS_BINARY_DIGIT);
2409 ffebad_here (0, ffelex_token_where_line (token),
2410 ffelex_token_where_column (token));
2411 ffebad_finish ();
2413 else if (overflow)
2415 ffebad_start (FFEBAD_TYPELESS_OVERFLOW);
2416 ffebad_here (0, ffelex_token_where_line (token),
2417 ffelex_token_where_column (token));
2418 ffebad_finish ();
2421 *xvalue = value;
2423 return !bad_digit && !overflow;
2426 bool
2427 ffetarget_typeless_octal (ffetargetTypeless *xvalue, ffelexToken token)
2429 char *p;
2430 char c;
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)
2440 new_value <<= 3;
2441 if ((new_value >> 3) != value)
2442 overflow = TRUE;
2443 if (ISDIGIT (c))
2444 new_value += c - '0';
2445 else
2446 bad_digit = TRUE;
2447 value = new_value;
2450 if (bad_digit)
2452 ffebad_start (FFEBAD_INVALID_TYPELESS_OCTAL_DIGIT);
2453 ffebad_here (0, ffelex_token_where_line (token),
2454 ffelex_token_where_column (token));
2455 ffebad_finish ();
2457 else if (overflow)
2459 ffebad_start (FFEBAD_TYPELESS_OVERFLOW);
2460 ffebad_here (0, ffelex_token_where_line (token),
2461 ffelex_token_where_column (token));
2462 ffebad_finish ();
2465 *xvalue = value;
2467 return !bad_digit && !overflow;
2470 bool
2471 ffetarget_typeless_hex (ffetargetTypeless *xvalue, ffelexToken token)
2473 char *p;
2474 char c;
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)
2484 new_value <<= 4;
2485 if ((new_value >> 4) != value)
2486 overflow = TRUE;
2487 if (hex_p (c))
2488 new_value += hex_value (c);
2489 else
2490 bad_digit = TRUE;
2491 value = new_value;
2494 if (bad_digit)
2496 ffebad_start (FFEBAD_INVALID_TYPELESS_HEX_DIGIT);
2497 ffebad_here (0, ffelex_token_where_line (token),
2498 ffelex_token_where_column (token));
2499 ffebad_finish ();
2501 else if (overflow)
2503 ffebad_start (FFEBAD_TYPELESS_OVERFLOW);
2504 ffebad_here (0, ffelex_token_where_line (token),
2505 ffelex_token_where_column (token));
2506 ffebad_finish ();
2509 *xvalue = value;
2511 return !bad_digit && !overflow;
2514 void
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". */
2525 void *
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
2535 #else
2536 HOST_WORDS_BIG_ENDIAN
2537 #endif
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)
2567 int i;
2568 char *c;
2570 switch (ffelex_token_type (token))
2572 case FFELEX_typeNAME:
2573 case FFELEX_typeNUMBER:
2574 return ffelex_token_length (token);
2576 case FFELEX_typeCHARACTER:
2577 i = 0;
2578 for (c = ffelex_token_text (token); *c != '\0'; ++c)
2580 if (*c != ' ')
2581 ++i;
2583 return i;
2585 default:
2586 assert ("weird token" == NULL);
2587 return 1;