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.
4
5 This file is part of GNU Fortran.
6
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.
11
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.
16
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.
21
22 Related Modules:
23 None
24
25 Description:
26 Implements conversion of lexer tokens to machine-dependent numerical
27 form and accordingly issues diagnostic messages when necessary.
28
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.
49
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.
65
66 Modifications:
67 */
68
69 /* Include files. */
70
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
80 /* Externals defined here. */
81
82 char ffetarget_string_[40]; /* Temp for ascii-to-double (atof). */
83 HOST_WIDE_INT ffetarget_long_val_;
84 HOST_WIDE_INT ffetarget_long_junk_;
85
86 /* Simple definitions and enumerations. */
87
88
89 /* Internal typedefs. */
90
91
92 /* Private include files. */
93
94
95 /* Internal structure definitions. */
96
97
98 /* Static objects accessed by functions in this module. */
99
100
101 /* Static functions (internal). */
102
103 static void ffetarget_print_char_ (FILE *f, unsigned char c);
104
105 /* Internal macros. */
106
107 #ifdef REAL_VALUE_ATOF
108 #define FFETARGET_ATOF_(p,m) REAL_VALUE_ATOF ((p),(m))
109 #else
110 #define FFETARGET_ATOF_(p,m) atof ((p))
111 #endif
112
113
114 /* ffetarget_print_char_ -- Print a single character (in apostrophe context)
115
116 See prototype.
117
118 Outputs char so it prints or is escaped C style. */
119
120 static void
ffetarget_print_char_(FILE * f,unsigned char c)121 ffetarget_print_char_ (FILE *f, unsigned char c)
122 {
123 switch (c)
124 {
125 case '\\':
126 fputs ("\\\\", f);
127 break;
128
129 case '\'':
130 fputs ("\\\'", f);
131 break;
132
133 default:
134 if (ISPRINT (c))
135 fputc (c, f);
136 else
137 fprintf (f, "\\%03o", (unsigned int) c);
138 break;
139 }
140 }
141
142 /* ffetarget_aggregate_info -- Determine type for aggregate storage area
143
144 See prototype.
145
146 If aggregate type is distinct, just return it. Else return a type
147 representing a common denominator for the nondistinct type (for now,
148 just return default character, since that'll work on almost all target
149 machines).
150
151 The rules for abt/akt are (as implemented by ffestorag_update):
152
153 abt == FFEINFO_basictypeANY (akt == FFEINFO_kindtypeANY also, by
154 definition): CHARACTER and non-CHARACTER types mixed.
155
156 abt == FFEINFO_basictypeNONE (akt == FFEINFO_kindtypeNONE also, by
157 definition): More than one non-CHARACTER type mixed, but no CHARACTER
158 types mixed in.
159
160 abt some other value, akt == FFEINFO_kindtypeNONE: abt indicates the
161 only basic type mixed in, but more than one kind type is mixed in.
162
163 abt some other value, akt some other value: abt and akt indicate the
164 only type represented in the aggregation. */
165
166 void
ffetarget_aggregate_info(ffeinfoBasictype * ebt,ffeinfoKindtype * ekt,ffetargetAlign * units,ffeinfoBasictype abt,ffeinfoKindtype akt)167 ffetarget_aggregate_info (ffeinfoBasictype *ebt, ffeinfoKindtype *ekt,
168 ffetargetAlign *units, ffeinfoBasictype abt,
169 ffeinfoKindtype akt)
170 {
171 ffetype type;
172
173 if ((abt == FFEINFO_basictypeNONE) || (abt == FFEINFO_basictypeANY)
174 || (akt == FFEINFO_kindtypeNONE))
175 {
176 *ebt = FFEINFO_basictypeCHARACTER;
177 *ekt = FFEINFO_kindtypeCHARACTERDEFAULT;
178 }
179 else
180 {
181 *ebt = abt;
182 *ekt = akt;
183 }
184
185 type = ffeinfo_type (*ebt, *ekt);
186 assert (type != NULL);
187
188 *units = ffetype_size (type);
189 }
190
191 /* ffetarget_align -- Align one storage area to superordinate, update super
192
193 See prototype.
194
195 updated_alignment/updated_modulo contain the already existing
196 alignment requirements for the storage area at whose offset the
197 object with alignment requirements alignment/modulo is to be placed.
198 Find the smallest pad such that the requirements are maintained and
199 return it, but only after updating the updated_alignment/_modulo
200 requirements as necessary to indicate the placement of the new object. */
201
202 ffetargetAlign
ffetarget_align(ffetargetAlign * updated_alignment,ffetargetAlign * updated_modulo,ffetargetOffset offset,ffetargetAlign alignment,ffetargetAlign modulo)203 ffetarget_align (ffetargetAlign *updated_alignment,
204 ffetargetAlign *updated_modulo, ffetargetOffset offset,
205 ffetargetAlign alignment, ffetargetAlign modulo)
206 {
207 ffetargetAlign pad;
208 ffetargetAlign min_pad; /* Minimum amount of padding needed. */
209 ffetargetAlign min_m = 0; /* Minimum-padding m. */
210 ffetargetAlign ua; /* Updated alignment. */
211 ffetargetAlign um; /* Updated modulo. */
212 ffetargetAlign ucnt; /* Multiplier applied to ua. */
213 ffetargetAlign m; /* Copy of modulo. */
214 ffetargetAlign cnt; /* Multiplier applied to alignment. */
215 ffetargetAlign i;
216 ffetargetAlign j;
217
218 assert (alignment > 0);
219 assert (*updated_alignment > 0);
220
221 assert (*updated_modulo < *updated_alignment);
222 assert (modulo < alignment);
223
224 /* The easy case: similar alignment requirements. */
225 if (*updated_alignment == alignment)
226 {
227 if (modulo > *updated_modulo)
228 pad = alignment - (modulo - *updated_modulo);
229 else
230 pad = *updated_modulo - modulo;
231 if (offset < 0)
232 /* De-negatize offset, since % wouldn't do the expected thing. */
233 offset = alignment - ((- offset) % alignment);
234 pad = (offset + pad) % alignment;
235 if (pad != 0)
236 pad = alignment - pad;
237 return pad;
238 }
239
240 /* Sigh, find LCM (Least Common Multiple) for the two alignment factors. */
241
242 for (ua = *updated_alignment, ucnt = 1;
243 ua % alignment != 0;
244 ua += *updated_alignment)
245 ++ucnt;
246
247 cnt = ua / alignment;
248
249 if (offset < 0)
250 /* De-negatize offset, since % wouldn't do the expected thing. */
251 offset = ua - ((- offset) % ua);
252
253 /* Set to largest value. */
254 min_pad = ~(ffetargetAlign) 0;
255
256 /* Find all combinations of modulo values the two alignment requirements
257 have; pick the combination that results in the smallest padding
258 requirement. Of course, if a zero-pad requirement is encountered, just
259 use that one. */
260
261 for (um = *updated_modulo, i = 0; i < ucnt; um += *updated_alignment, ++i)
262 {
263 for (m = modulo, j = 0; j < cnt; m += alignment, ++j)
264 {
265 /* This code is similar to the "easy case" code above. */
266 if (m > um)
267 pad = ua - (m - um);
268 else
269 pad = um - m;
270 pad = (offset + pad) % ua;
271 if (pad == 0)
272 {
273 /* A zero pad means we've got something useful. */
274 *updated_alignment = ua;
275 *updated_modulo = um;
276 return 0;
277 }
278 pad = ua - pad;
279 if (pad < min_pad)
280 { /* New minimum padding value. */
281 min_pad = pad;
282 min_m = um;
283 }
284 }
285 }
286
287 *updated_alignment = ua;
288 *updated_modulo = min_m;
289 return min_pad;
290 }
291
292 /* Always append a null byte to the end, in case this is wanted in
293 a special case such as passing a string as a FORMAT or %REF.
294 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
295 because it isn't a "feature" that is self-documenting. Use the
296 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
297 in the code. */
298
299 #if FFETARGET_okCHARACTER1
300 bool
ffetarget_character1(ffetargetCharacter1 * val,ffelexToken character,mallocPool pool)301 ffetarget_character1 (ffetargetCharacter1 *val, ffelexToken character,
302 mallocPool pool)
303 {
304 val->length = ffelex_token_length (character);
305 if (val->length == 0)
306 val->text = NULL;
307 else
308 {
309 val->text = malloc_new_kp (pool, "ffetargetCharacter1", val->length + 1);
310 memcpy (val->text, ffelex_token_text (character), val->length);
311 val->text[val->length] = '\0';
312 }
313
314 return TRUE;
315 }
316
317 #endif
318 /* Produce orderable comparison between two constants
319
320 Compare lengths, if equal then use memcmp. */
321
322 #if FFETARGET_okCHARACTER1
323 int
ffetarget_cmp_character1(ffetargetCharacter1 l,ffetargetCharacter1 r)324 ffetarget_cmp_character1 (ffetargetCharacter1 l, ffetargetCharacter1 r)
325 {
326 if (l.length < r.length)
327 return -1;
328 if (l.length > r.length)
329 return 1;
330 if (l.length == 0)
331 return 0;
332 return memcmp (l.text, r.text, l.length);
333 }
334
335 #endif
336 /* ffetarget_concatenate_character1 -- Perform CONCAT op on two constants
337
338 Always append a null byte to the end, in case this is wanted in
339 a special case such as passing a string as a FORMAT or %REF.
340 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
341 because it isn't a "feature" that is self-documenting. Use the
342 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
343 in the code. */
344
345 #if FFETARGET_okCHARACTER1
346 ffebad
ffetarget_concatenate_character1(ffetargetCharacter1 * res,ffetargetCharacter1 l,ffetargetCharacter1 r,mallocPool pool,ffetargetCharacterSize * len)347 ffetarget_concatenate_character1 (ffetargetCharacter1 *res,
348 ffetargetCharacter1 l, ffetargetCharacter1 r, mallocPool pool,
349 ffetargetCharacterSize *len)
350 {
351 res->length = *len = l.length + r.length;
352 if (*len == 0)
353 res->text = NULL;
354 else
355 {
356 res->text = malloc_new_kp (pool, "ffetargetCharacter1(CONCAT)", *len + 1);
357 if (l.length != 0)
358 memcpy (res->text, l.text, l.length);
359 if (r.length != 0)
360 memcpy (res->text + l.length, r.text, r.length);
361 res->text[*len] = '\0';
362 }
363
364 return FFEBAD;
365 }
366
367 #endif
368 /* ffetarget_eq_character1 -- Perform relational comparison on char constants
369
370 Compare lengths, if equal then use memcmp. */
371
372 #if FFETARGET_okCHARACTER1
373 ffebad
ffetarget_eq_character1(bool * res,ffetargetCharacter1 l,ffetargetCharacter1 r)374 ffetarget_eq_character1 (bool *res, ffetargetCharacter1 l,
375 ffetargetCharacter1 r)
376 {
377 assert (l.length == r.length);
378 *res = (memcmp (l.text, r.text, l.length) == 0);
379 return FFEBAD;
380 }
381
382 #endif
383 /* ffetarget_le_character1 -- Perform relational comparison on char constants
384
385 Compare lengths, if equal then use memcmp. */
386
387 #if FFETARGET_okCHARACTER1
388 ffebad
ffetarget_le_character1(bool * res,ffetargetCharacter1 l,ffetargetCharacter1 r)389 ffetarget_le_character1 (bool *res, ffetargetCharacter1 l,
390 ffetargetCharacter1 r)
391 {
392 assert (l.length == r.length);
393 *res = (memcmp (l.text, r.text, l.length) <= 0);
394 return FFEBAD;
395 }
396
397 #endif
398 /* ffetarget_lt_character1 -- Perform relational comparison on char constants
399
400 Compare lengths, if equal then use memcmp. */
401
402 #if FFETARGET_okCHARACTER1
403 ffebad
ffetarget_lt_character1(bool * res,ffetargetCharacter1 l,ffetargetCharacter1 r)404 ffetarget_lt_character1 (bool *res, ffetargetCharacter1 l,
405 ffetargetCharacter1 r)
406 {
407 assert (l.length == r.length);
408 *res = (memcmp (l.text, r.text, l.length) < 0);
409 return FFEBAD;
410 }
411
412 #endif
413 /* ffetarget_ge_character1 -- Perform relational comparison on char constants
414
415 Compare lengths, if equal then use memcmp. */
416
417 #if FFETARGET_okCHARACTER1
418 ffebad
ffetarget_ge_character1(bool * res,ffetargetCharacter1 l,ffetargetCharacter1 r)419 ffetarget_ge_character1 (bool *res, ffetargetCharacter1 l,
420 ffetargetCharacter1 r)
421 {
422 assert (l.length == r.length);
423 *res = (memcmp (l.text, r.text, l.length) >= 0);
424 return FFEBAD;
425 }
426
427 #endif
428 /* ffetarget_gt_character1 -- Perform relational comparison on char constants
429
430 Compare lengths, if equal then use memcmp. */
431
432 #if FFETARGET_okCHARACTER1
433 ffebad
ffetarget_gt_character1(bool * res,ffetargetCharacter1 l,ffetargetCharacter1 r)434 ffetarget_gt_character1 (bool *res, ffetargetCharacter1 l,
435 ffetargetCharacter1 r)
436 {
437 assert (l.length == r.length);
438 *res = (memcmp (l.text, r.text, l.length) > 0);
439 return FFEBAD;
440 }
441 #endif
442
443 #if FFETARGET_okCHARACTER1
444 bool
ffetarget_iszero_character1(ffetargetCharacter1 constant)445 ffetarget_iszero_character1 (ffetargetCharacter1 constant)
446 {
447 ffetargetCharacterSize i;
448
449 for (i = 0; i < constant.length; ++i)
450 if (constant.text[i] != 0)
451 return FALSE;
452 return TRUE;
453 }
454 #endif
455
456 bool
ffetarget_iszero_hollerith(ffetargetHollerith constant)457 ffetarget_iszero_hollerith (ffetargetHollerith constant)
458 {
459 ffetargetHollerithSize i;
460
461 for (i = 0; i < constant.length; ++i)
462 if (constant.text[i] != 0)
463 return FALSE;
464 return TRUE;
465 }
466
467 /* ffetarget_layout -- Do storage requirement analysis for entity
468
469 Return the alignment/modulo requirements along with the size, given the
470 data type info and the number of elements an array (1 for a scalar). */
471
472 void
ffetarget_layout(const char * error_text UNUSED,ffetargetAlign * alignment,ffetargetAlign * modulo,ffetargetOffset * size,ffeinfoBasictype bt,ffeinfoKindtype kt,ffetargetCharacterSize charsize,ffetargetIntegerDefault num_elements)473 ffetarget_layout (const char *error_text UNUSED, ffetargetAlign *alignment,
474 ffetargetAlign *modulo, ffetargetOffset *size,
475 ffeinfoBasictype bt, ffeinfoKindtype kt,
476 ffetargetCharacterSize charsize,
477 ffetargetIntegerDefault num_elements)
478 {
479 bool ok; /* For character type. */
480 ffetargetOffset numele; /* Converted from num_elements. */
481 ffetype type;
482
483 type = ffeinfo_type (bt, kt);
484 assert (type != NULL);
485
486 *alignment = ffetype_alignment (type);
487 *modulo = ffetype_modulo (type);
488 if (bt == FFEINFO_basictypeCHARACTER)
489 {
490 ok = ffetarget_offset_charsize (size, charsize, ffetype_size (type));
491 #ifdef ffetarget_offset_overflow
492 if (!ok)
493 ffetarget_offset_overflow (error_text);
494 #endif
495 }
496 else
497 *size = ffetype_size (type);
498
499 if ((num_elements < 0)
500 || !ffetarget_offset (&numele, num_elements)
501 || !ffetarget_offset_multiply (size, *size, numele))
502 {
503 ffetarget_offset_overflow (error_text);
504 *alignment = 1;
505 *modulo = 0;
506 *size = 0;
507 }
508 }
509
510 /* ffetarget_ne_character1 -- Perform relational comparison on char constants
511
512 Compare lengths, if equal then use memcmp. */
513
514 #if FFETARGET_okCHARACTER1
515 ffebad
ffetarget_ne_character1(bool * res,ffetargetCharacter1 l,ffetargetCharacter1 r)516 ffetarget_ne_character1 (bool *res, ffetargetCharacter1 l,
517 ffetargetCharacter1 r)
518 {
519 assert (l.length == r.length);
520 *res = (memcmp (l.text, r.text, l.length) != 0);
521 return FFEBAD;
522 }
523
524 #endif
525 /* ffetarget_substr_character1 -- Perform SUBSTR op on three constants
526
527 Always append a null byte to the end, in case this is wanted in
528 a special case such as passing a string as a FORMAT or %REF.
529 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
530 because it isn't a "feature" that is self-documenting. Use the
531 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
532 in the code. */
533
534 #if FFETARGET_okCHARACTER1
535 ffebad
ffetarget_substr_character1(ffetargetCharacter1 * res,ffetargetCharacter1 l,ffetargetCharacterSize first,ffetargetCharacterSize last,mallocPool pool,ffetargetCharacterSize * len)536 ffetarget_substr_character1 (ffetargetCharacter1 *res,
537 ffetargetCharacter1 l,
538 ffetargetCharacterSize first,
539 ffetargetCharacterSize last, mallocPool pool,
540 ffetargetCharacterSize *len)
541 {
542 if (last < first)
543 {
544 res->length = *len = 0;
545 res->text = NULL;
546 }
547 else
548 {
549 res->length = *len = last - first + 1;
550 res->text = malloc_new_kp (pool, "ffetargetCharacter1(SUBSTR)", *len + 1);
551 memcpy (res->text, l.text + first - 1, *len);
552 res->text[*len] = '\0';
553 }
554
555 return FFEBAD;
556 }
557
558 #endif
559 /* ffetarget_cmp_hollerith -- Produce orderable comparison between two
560 constants
561
562 Compare lengths, if equal then use memcmp. */
563
564 int
ffetarget_cmp_hollerith(ffetargetHollerith l,ffetargetHollerith r)565 ffetarget_cmp_hollerith (ffetargetHollerith l, ffetargetHollerith r)
566 {
567 if (l.length < r.length)
568 return -1;
569 if (l.length > r.length)
570 return 1;
571 return memcmp (l.text, r.text, l.length);
572 }
573
574 ffebad
ffetarget_convert_any_character1_(char * res,size_t size,ffetargetCharacter1 l)575 ffetarget_convert_any_character1_ (char *res, size_t size,
576 ffetargetCharacter1 l)
577 {
578 if (size <= (size_t) l.length)
579 {
580 char *p;
581 ffetargetCharacterSize i;
582
583 memcpy (res, l.text, size);
584 for (p = &l.text[0] + size, i = l.length - size;
585 i > 0;
586 ++p, --i)
587 if (*p != ' ')
588 return FFEBAD_TRUNCATING_CHARACTER;
589 }
590 else
591 {
592 memcpy (res, l.text, size);
593 memset (res + l.length, ' ', size - l.length);
594 }
595
596 return FFEBAD;
597 }
598
599 ffebad
ffetarget_convert_any_hollerith_(char * res,size_t size,ffetargetHollerith l)600 ffetarget_convert_any_hollerith_ (char *res, size_t size,
601 ffetargetHollerith l)
602 {
603 if (size <= (size_t) l.length)
604 {
605 char *p;
606 ffetargetCharacterSize i;
607
608 memcpy (res, l.text, size);
609 for (p = &l.text[0] + size, i = l.length - size;
610 i > 0;
611 ++p, --i)
612 if (*p != ' ')
613 return FFEBAD_TRUNCATING_HOLLERITH;
614 }
615 else
616 {
617 memcpy (res, l.text, size);
618 memset (res + l.length, ' ', size - l.length);
619 }
620
621 return FFEBAD;
622 }
623
624 ffebad
ffetarget_convert_any_typeless_(char * res,size_t size,ffetargetTypeless l)625 ffetarget_convert_any_typeless_ (char *res, size_t size,
626 ffetargetTypeless l)
627 {
628 unsigned long long int l1;
629 unsigned long int l2;
630 unsigned int l3;
631 unsigned short int l4;
632 unsigned char l5;
633 size_t size_of;
634 char *p;
635
636 if (size >= sizeof (l1))
637 {
638 l1 = l;
639 p = (char *) &l1;
640 size_of = sizeof (l1);
641 }
642 else if (size >= sizeof (l2))
643 {
644 l2 = l;
645 p = (char *) &l2;
646 size_of = sizeof (l2);
647 l1 = l2;
648 }
649 else if (size >= sizeof (l3))
650 {
651 l3 = l;
652 p = (char *) &l3;
653 size_of = sizeof (l3);
654 l1 = l3;
655 }
656 else if (size >= sizeof (l4))
657 {
658 l4 = l;
659 p = (char *) &l4;
660 size_of = sizeof (l4);
661 l1 = l4;
662 }
663 else if (size >= sizeof (l5))
664 {
665 l5 = l;
666 p = (char *) &l5;
667 size_of = sizeof (l5);
668 l1 = l5;
669 }
670 else
671 {
672 assert ("stumped by conversion from typeless!" == NULL);
673 abort ();
674 }
675
676 if (size <= size_of)
677 {
678 int i = size_of - size;
679
680 memcpy (res, p + i, size);
681 for (; i > 0; ++p, --i)
682 if (*p != '\0')
683 return FFEBAD_TRUNCATING_TYPELESS;
684 }
685 else
686 {
687 int i = size - size_of;
688
689 memset (res, 0, i);
690 memcpy (res + i, p, size_of);
691 }
692
693 if (l1 != l)
694 return FFEBAD_TRUNCATING_TYPELESS;
695 return FFEBAD;
696 }
697
698 /* Always append a null byte to the end, in case this is wanted in
699 a special case such as passing a string as a FORMAT or %REF.
700 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
701 because it isn't a "feature" that is self-documenting. Use the
702 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
703 in the code. */
704
705 #if FFETARGET_okCHARACTER1
706 ffebad
ffetarget_convert_character1_character1(ffetargetCharacter1 * res,ffetargetCharacterSize size,ffetargetCharacter1 l,mallocPool pool)707 ffetarget_convert_character1_character1 (ffetargetCharacter1 *res,
708 ffetargetCharacterSize size,
709 ffetargetCharacter1 l,
710 mallocPool pool)
711 {
712 res->length = size;
713 if (size == 0)
714 res->text = NULL;
715 else
716 {
717 res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1);
718 if (size <= l.length)
719 memcpy (res->text, l.text, size);
720 else
721 {
722 memcpy (res->text, l.text, l.length);
723 memset (res->text + l.length, ' ', size - l.length);
724 }
725 res->text[size] = '\0';
726 }
727
728 return FFEBAD;
729 }
730
731 #endif
732
733 /* Always append a null byte to the end, in case this is wanted in
734 a special case such as passing a string as a FORMAT or %REF.
735 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
736 because it isn't a "feature" that is self-documenting. Use the
737 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
738 in the code. */
739
740 #if FFETARGET_okCHARACTER1
741 ffebad
ffetarget_convert_character1_hollerith(ffetargetCharacter1 * res,ffetargetCharacterSize size,ffetargetHollerith l,mallocPool pool)742 ffetarget_convert_character1_hollerith (ffetargetCharacter1 *res,
743 ffetargetCharacterSize size,
744 ffetargetHollerith l, mallocPool pool)
745 {
746 res->length = size;
747 if (size == 0)
748 res->text = NULL;
749 else
750 {
751 res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1);
752 res->text[size] = '\0';
753 if (size <= l.length)
754 {
755 char *p;
756 ffetargetCharacterSize i;
757
758 memcpy (res->text, l.text, size);
759 for (p = &l.text[0] + size, i = l.length - size;
760 i > 0;
761 ++p, --i)
762 if (*p != ' ')
763 return FFEBAD_TRUNCATING_HOLLERITH;
764 }
765 else
766 {
767 memcpy (res->text, l.text, l.length);
768 memset (res->text + l.length, ' ', size - l.length);
769 }
770 }
771
772 return FFEBAD;
773 }
774
775 #endif
776 /* ffetarget_convert_character1_integer4 -- Raw conversion.
777
778 Always append a null byte to the end, in case this is wanted in
779 a special case such as passing a string as a FORMAT or %REF.
780 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
781 because it isn't a "feature" that is self-documenting. Use the
782 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
783 in the code. */
784
785 #if FFETARGET_okCHARACTER1
786 ffebad
ffetarget_convert_character1_integer4(ffetargetCharacter1 * res,ffetargetCharacterSize size,ffetargetInteger4 l,mallocPool pool)787 ffetarget_convert_character1_integer4 (ffetargetCharacter1 *res,
788 ffetargetCharacterSize size,
789 ffetargetInteger4 l, mallocPool pool)
790 {
791 long long int l1;
792 long int l2;
793 int l3;
794 short int l4;
795 char l5;
796 size_t size_of;
797 char *p;
798
799 if (((size_t) size) >= sizeof (l1))
800 {
801 l1 = l;
802 p = (char *) &l1;
803 size_of = sizeof (l1);
804 }
805 else if (((size_t) size) >= sizeof (l2))
806 {
807 l2 = l;
808 p = (char *) &l2;
809 size_of = sizeof (l2);
810 l1 = l2;
811 }
812 else if (((size_t) size) >= sizeof (l3))
813 {
814 l3 = l;
815 p = (char *) &l3;
816 size_of = sizeof (l3);
817 l1 = l3;
818 }
819 else if (((size_t) size) >= sizeof (l4))
820 {
821 l4 = l;
822 p = (char *) &l4;
823 size_of = sizeof (l4);
824 l1 = l4;
825 }
826 else if (((size_t) size) >= sizeof (l5))
827 {
828 l5 = l;
829 p = (char *) &l5;
830 size_of = sizeof (l5);
831 l1 = l5;
832 }
833 else
834 {
835 assert ("stumped by conversion from integer1!" == NULL);
836 abort ();
837 }
838
839 res->length = size;
840 if (size == 0)
841 res->text = NULL;
842 else
843 {
844 res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1);
845 res->text[size] = '\0';
846 if (((size_t) size) <= size_of)
847 {
848 int i = size_of - size;
849
850 memcpy (res->text, p + i, size);
851 for (; i > 0; ++p, --i)
852 if (*p != 0)
853 return FFEBAD_TRUNCATING_NUMERIC;
854 }
855 else
856 {
857 int i = size - size_of;
858
859 memset (res->text, 0, i);
860 memcpy (res->text + i, p, size_of);
861 }
862 }
863
864 if (l1 != l)
865 return FFEBAD_TRUNCATING_NUMERIC;
866 return FFEBAD;
867 }
868
869 #endif
870 /* ffetarget_convert_character1_logical4 -- Raw conversion.
871
872 Always append a null byte to the end, in case this is wanted in
873 a special case such as passing a string as a FORMAT or %REF.
874 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
875 because it isn't a "feature" that is self-documenting. Use the
876 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
877 in the code. */
878
879 #if FFETARGET_okCHARACTER1
880 ffebad
ffetarget_convert_character1_logical4(ffetargetCharacter1 * res,ffetargetCharacterSize size,ffetargetLogical4 l,mallocPool pool)881 ffetarget_convert_character1_logical4 (ffetargetCharacter1 *res,
882 ffetargetCharacterSize size,
883 ffetargetLogical4 l, mallocPool pool)
884 {
885 long long int l1;
886 long int l2;
887 int l3;
888 short int l4;
889 char l5;
890 size_t size_of;
891 char *p;
892
893 if (((size_t) size) >= sizeof (l1))
894 {
895 l1 = l;
896 p = (char *) &l1;
897 size_of = sizeof (l1);
898 }
899 else if (((size_t) size) >= sizeof (l2))
900 {
901 l2 = l;
902 p = (char *) &l2;
903 size_of = sizeof (l2);
904 l1 = l2;
905 }
906 else if (((size_t) size) >= sizeof (l3))
907 {
908 l3 = l;
909 p = (char *) &l3;
910 size_of = sizeof (l3);
911 l1 = l3;
912 }
913 else if (((size_t) size) >= sizeof (l4))
914 {
915 l4 = l;
916 p = (char *) &l4;
917 size_of = sizeof (l4);
918 l1 = l4;
919 }
920 else if (((size_t) size) >= sizeof (l5))
921 {
922 l5 = l;
923 p = (char *) &l5;
924 size_of = sizeof (l5);
925 l1 = l5;
926 }
927 else
928 {
929 assert ("stumped by conversion from logical1!" == NULL);
930 abort ();
931 }
932
933 res->length = size;
934 if (size == 0)
935 res->text = NULL;
936 else
937 {
938 res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1);
939 res->text[size] = '\0';
940 if (((size_t) size) <= size_of)
941 {
942 int i = size_of - size;
943
944 memcpy (res->text, p + i, size);
945 for (; i > 0; ++p, --i)
946 if (*p != 0)
947 return FFEBAD_TRUNCATING_NUMERIC;
948 }
949 else
950 {
951 int i = size - size_of;
952
953 memset (res->text, 0, i);
954 memcpy (res->text + i, p, size_of);
955 }
956 }
957
958 if (l1 != l)
959 return FFEBAD_TRUNCATING_NUMERIC;
960 return FFEBAD;
961 }
962
963 #endif
964 /* ffetarget_convert_character1_typeless -- Raw conversion.
965
966 Always append a null byte to the end, in case this is wanted in
967 a special case such as passing a string as a FORMAT or %REF.
968 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
969 because it isn't a "feature" that is self-documenting. Use the
970 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
971 in the code. */
972
973 #if FFETARGET_okCHARACTER1
974 ffebad
ffetarget_convert_character1_typeless(ffetargetCharacter1 * res,ffetargetCharacterSize size,ffetargetTypeless l,mallocPool pool)975 ffetarget_convert_character1_typeless (ffetargetCharacter1 *res,
976 ffetargetCharacterSize size,
977 ffetargetTypeless l, mallocPool pool)
978 {
979 unsigned long long int l1;
980 unsigned long int l2;
981 unsigned int l3;
982 unsigned short int l4;
983 unsigned char l5;
984 size_t size_of;
985 char *p;
986
987 if (((size_t) size) >= sizeof (l1))
988 {
989 l1 = l;
990 p = (char *) &l1;
991 size_of = sizeof (l1);
992 }
993 else if (((size_t) size) >= sizeof (l2))
994 {
995 l2 = l;
996 p = (char *) &l2;
997 size_of = sizeof (l2);
998 l1 = l2;
999 }
1000 else if (((size_t) size) >= sizeof (l3))
1001 {
1002 l3 = l;
1003 p = (char *) &l3;
1004 size_of = sizeof (l3);
1005 l1 = l3;
1006 }
1007 else if (((size_t) size) >= sizeof (l4))
1008 {
1009 l4 = l;
1010 p = (char *) &l4;
1011 size_of = sizeof (l4);
1012 l1 = l4;
1013 }
1014 else if (((size_t) size) >= sizeof (l5))
1015 {
1016 l5 = l;
1017 p = (char *) &l5;
1018 size_of = sizeof (l5);
1019 l1 = l5;
1020 }
1021 else
1022 {
1023 assert ("stumped by conversion from typeless!" == NULL);
1024 abort ();
1025 }
1026
1027 res->length = size;
1028 if (size == 0)
1029 res->text = NULL;
1030 else
1031 {
1032 res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1);
1033 res->text[size] = '\0';
1034 if (((size_t) size) <= size_of)
1035 {
1036 int i = size_of - size;
1037
1038 memcpy (res->text, p + i, size);
1039 for (; i > 0; ++p, --i)
1040 if (*p != 0)
1041 return FFEBAD_TRUNCATING_TYPELESS;
1042 }
1043 else
1044 {
1045 int i = size - size_of;
1046
1047 memset (res->text, 0, i);
1048 memcpy (res->text + i, p, size_of);
1049 }
1050 }
1051
1052 if (l1 != l)
1053 return FFEBAD_TRUNCATING_TYPELESS;
1054 return FFEBAD;
1055 }
1056
1057 #endif
1058 /* ffetarget_divide_complex1 -- Divide function
1059
1060 See prototype. */
1061
1062 #if FFETARGET_okCOMPLEX1
1063 ffebad
ffetarget_divide_complex1(ffetargetComplex1 * res,ffetargetComplex1 l,ffetargetComplex1 r)1064 ffetarget_divide_complex1 (ffetargetComplex1 *res, ffetargetComplex1 l,
1065 ffetargetComplex1 r)
1066 {
1067 ffebad bad;
1068 ffetargetReal1 tmp1, tmp2, tmp3, tmp4;
1069
1070 bad = ffetarget_multiply_real1 (&tmp1, r.real, r.real);
1071 if (bad != FFEBAD)
1072 return bad;
1073 bad = ffetarget_multiply_real1 (&tmp2, r.imaginary, r.imaginary);
1074 if (bad != FFEBAD)
1075 return bad;
1076 bad = ffetarget_add_real1 (&tmp3, tmp1, tmp2);
1077 if (bad != FFEBAD)
1078 return bad;
1079
1080 if (ffetarget_iszero_real1 (tmp3))
1081 {
1082 ffetarget_real1_zero (&(res)->real);
1083 ffetarget_real1_zero (&(res)->imaginary);
1084 return FFEBAD_DIV_BY_ZERO;
1085 }
1086
1087 bad = ffetarget_multiply_real1 (&tmp1, l.real, r.real);
1088 if (bad != FFEBAD)
1089 return bad;
1090 bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, r.imaginary);
1091 if (bad != FFEBAD)
1092 return bad;
1093 bad = ffetarget_add_real1 (&tmp4, tmp1, tmp2);
1094 if (bad != FFEBAD)
1095 return bad;
1096 bad = ffetarget_divide_real1 (&res->real, tmp4, tmp3);
1097 if (bad != FFEBAD)
1098 return bad;
1099
1100 bad = ffetarget_multiply_real1 (&tmp1, r.real, l.imaginary);
1101 if (bad != FFEBAD)
1102 return bad;
1103 bad = ffetarget_multiply_real1 (&tmp2, l.real, r.imaginary);
1104 if (bad != FFEBAD)
1105 return bad;
1106 bad = ffetarget_subtract_real1 (&tmp4, tmp1, tmp2);
1107 if (bad != FFEBAD)
1108 return bad;
1109 bad = ffetarget_divide_real1 (&res->imaginary, tmp4, tmp3);
1110
1111 return FFEBAD;
1112 }
1113
1114 #endif
1115 /* ffetarget_divide_complex2 -- Divide function
1116
1117 See prototype. */
1118
1119 #if FFETARGET_okCOMPLEX2
1120 ffebad
ffetarget_divide_complex2(ffetargetComplex2 * res,ffetargetComplex2 l,ffetargetComplex2 r)1121 ffetarget_divide_complex2 (ffetargetComplex2 *res, ffetargetComplex2 l,
1122 ffetargetComplex2 r)
1123 {
1124 ffebad bad;
1125 ffetargetReal2 tmp1, tmp2, tmp3, tmp4;
1126
1127 bad = ffetarget_multiply_real2 (&tmp1, r.real, r.real);
1128 if (bad != FFEBAD)
1129 return bad;
1130 bad = ffetarget_multiply_real2 (&tmp2, r.imaginary, r.imaginary);
1131 if (bad != FFEBAD)
1132 return bad;
1133 bad = ffetarget_add_real2 (&tmp3, tmp1, tmp2);
1134 if (bad != FFEBAD)
1135 return bad;
1136
1137 if (ffetarget_iszero_real2 (tmp3))
1138 {
1139 ffetarget_real2_zero (&(res)->real);
1140 ffetarget_real2_zero (&(res)->imaginary);
1141 return FFEBAD_DIV_BY_ZERO;
1142 }
1143
1144 bad = ffetarget_multiply_real2 (&tmp1, l.real, r.real);
1145 if (bad != FFEBAD)
1146 return bad;
1147 bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, r.imaginary);
1148 if (bad != FFEBAD)
1149 return bad;
1150 bad = ffetarget_add_real2 (&tmp4, tmp1, tmp2);
1151 if (bad != FFEBAD)
1152 return bad;
1153 bad = ffetarget_divide_real2 (&res->real, tmp4, tmp3);
1154 if (bad != FFEBAD)
1155 return bad;
1156
1157 bad = ffetarget_multiply_real2 (&tmp1, r.real, l.imaginary);
1158 if (bad != FFEBAD)
1159 return bad;
1160 bad = ffetarget_multiply_real2 (&tmp2, l.real, r.imaginary);
1161 if (bad != FFEBAD)
1162 return bad;
1163 bad = ffetarget_subtract_real2 (&tmp4, tmp1, tmp2);
1164 if (bad != FFEBAD)
1165 return bad;
1166 bad = ffetarget_divide_real2 (&res->imaginary, tmp4, tmp3);
1167
1168 return FFEBAD;
1169 }
1170
1171 #endif
1172 /* ffetarget_hollerith -- Convert token to a hollerith constant
1173
1174 Always append a null byte to the end, in case this is wanted in
1175 a special case such as passing a string as a FORMAT or %REF.
1176 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
1177 because it isn't a "feature" that is self-documenting. Use the
1178 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
1179 in the code. */
1180
1181 bool
ffetarget_hollerith(ffetargetHollerith * val,ffelexToken integer,mallocPool pool)1182 ffetarget_hollerith (ffetargetHollerith *val, ffelexToken integer,
1183 mallocPool pool)
1184 {
1185 val->length = ffelex_token_length (integer);
1186 val->text = malloc_new_kp (pool, "ffetargetHollerith", val->length + 1);
1187 memcpy (val->text, ffelex_token_text (integer), val->length);
1188 val->text[val->length] = '\0';
1189
1190 return TRUE;
1191 }
1192
1193 /* ffetarget_integer_bad_magical -- Complain about a magical number
1194
1195 Just calls ffebad with the arguments. */
1196
1197 void
ffetarget_integer_bad_magical(ffelexToken t)1198 ffetarget_integer_bad_magical (ffelexToken t)
1199 {
1200 ffebad_start (FFEBAD_BAD_MAGICAL);
1201 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1202 ffebad_finish ();
1203 }
1204
1205 /* ffetarget_integer_bad_magical_binary -- Complain about a magical number
1206
1207 Just calls ffebad with the arguments. */
1208
1209 void
ffetarget_integer_bad_magical_binary(ffelexToken integer,ffelexToken minus)1210 ffetarget_integer_bad_magical_binary (ffelexToken integer,
1211 ffelexToken minus)
1212 {
1213 ffebad_start (FFEBAD_BAD_MAGICAL_BINARY);
1214 ffebad_here (0, ffelex_token_where_line (integer),
1215 ffelex_token_where_column (integer));
1216 ffebad_here (1, ffelex_token_where_line (minus),
1217 ffelex_token_where_column (minus));
1218 ffebad_finish ();
1219 }
1220
1221 /* ffetarget_integer_bad_magical_precedence -- Complain about a magical
1222 number
1223
1224 Just calls ffebad with the arguments. */
1225
1226 void
ffetarget_integer_bad_magical_precedence(ffelexToken integer,ffelexToken uminus,ffelexToken higher_op)1227 ffetarget_integer_bad_magical_precedence (ffelexToken integer,
1228 ffelexToken uminus,
1229 ffelexToken higher_op)
1230 {
1231 ffebad_start (FFEBAD_BAD_MAGICAL_PRECEDENCE);
1232 ffebad_here (0, ffelex_token_where_line (integer),
1233 ffelex_token_where_column (integer));
1234 ffebad_here (1, ffelex_token_where_line (uminus),
1235 ffelex_token_where_column (uminus));
1236 ffebad_here (2, ffelex_token_where_line (higher_op),
1237 ffelex_token_where_column (higher_op));
1238 ffebad_finish ();
1239 }
1240
1241 /* ffetarget_integer_bad_magical_precedence_binary -- Complain...
1242
1243 Just calls ffebad with the arguments. */
1244
1245 void
ffetarget_integer_bad_magical_precedence_binary(ffelexToken integer,ffelexToken minus,ffelexToken higher_op)1246 ffetarget_integer_bad_magical_precedence_binary (ffelexToken integer,
1247 ffelexToken minus,
1248 ffelexToken higher_op)
1249 {
1250 ffebad_start (FFEBAD_BAD_MAGICAL_PRECEDENCE_BINARY);
1251 ffebad_here (0, ffelex_token_where_line (integer),
1252 ffelex_token_where_column (integer));
1253 ffebad_here (1, ffelex_token_where_line (minus),
1254 ffelex_token_where_column (minus));
1255 ffebad_here (2, ffelex_token_where_line (higher_op),
1256 ffelex_token_where_column (higher_op));
1257 ffebad_finish ();
1258 }
1259
1260 /* ffetarget_integer1 -- Convert token to an integer
1261
1262 See prototype.
1263
1264 Token use count not affected overall. */
1265
1266 #if FFETARGET_okINTEGER1
1267 bool
ffetarget_integer1(ffetargetInteger1 * val,ffelexToken integer)1268 ffetarget_integer1 (ffetargetInteger1 *val, ffelexToken integer)
1269 {
1270 ffetargetInteger1 x;
1271 char *p;
1272 char c;
1273
1274 assert (ffelex_token_type (integer) == FFELEX_typeNUMBER);
1275
1276 p = ffelex_token_text (integer);
1277 x = 0;
1278
1279 /* Skip past leading zeros. */
1280
1281 while (((c = *p) != '\0') && (c == '0'))
1282 ++p;
1283
1284 /* Interpret rest of number. */
1285
1286 while (c != '\0')
1287 {
1288 if ((x == FFETARGET_integerALMOST_BIG_MAGICAL)
1289 && (c == '0' + FFETARGET_integerFINISH_BIG_MAGICAL)
1290 && (*(p + 1) == '\0'))
1291 {
1292 *val = (ffetargetInteger1) FFETARGET_integerBIG_MAGICAL;
1293 return TRUE;
1294 }
1295 else if (x == FFETARGET_integerALMOST_BIG_MAGICAL)
1296 {
1297 if ((c > '0' + FFETARGET_integerFINISH_BIG_MAGICAL)
1298 || (*(p + 1) != '\0'))
1299 {
1300 ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1301 ffebad_here (0, ffelex_token_where_line (integer),
1302 ffelex_token_where_column (integer));
1303 ffebad_finish ();
1304 *val = 0;
1305 return FALSE;
1306 }
1307 }
1308 else if (x > FFETARGET_integerALMOST_BIG_MAGICAL)
1309 {
1310 ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1311 ffebad_here (0, ffelex_token_where_line (integer),
1312 ffelex_token_where_column (integer));
1313 ffebad_finish ();
1314 *val = 0;
1315 return FALSE;
1316 }
1317 x = x * 10 + c - '0';
1318 c = *(++p);
1319 };
1320
1321 *val = x;
1322 return TRUE;
1323 }
1324
1325 #endif
1326 /* ffetarget_integerbinary -- Convert token to a binary integer
1327
1328 ffetarget_integerbinary x;
1329 if (ffetarget_integerdefault_8(&x,integer_token))
1330 // conversion ok.
1331
1332 Token use count not affected overall. */
1333
1334 bool
ffetarget_integerbinary(ffetargetIntegerDefault * val,ffelexToken integer)1335 ffetarget_integerbinary (ffetargetIntegerDefault *val, ffelexToken integer)
1336 {
1337 ffetargetIntegerDefault x;
1338 char *p;
1339 char c;
1340 bool bad_digit;
1341
1342 assert ((ffelex_token_type (integer) == FFELEX_typeNAME)
1343 || (ffelex_token_type (integer) == FFELEX_typeNUMBER));
1344
1345 p = ffelex_token_text (integer);
1346 x = 0;
1347
1348 /* Skip past leading zeros. */
1349
1350 while (((c = *p) != '\0') && (c == '0'))
1351 ++p;
1352
1353 /* Interpret rest of number. */
1354
1355 bad_digit = FALSE;
1356 while (c != '\0')
1357 {
1358 if ((c >= '0') && (c <= '1'))
1359 c -= '0';
1360 else
1361 {
1362 bad_digit = TRUE;
1363 c = 0;
1364 }
1365
1366 #if 0 /* Don't complain about signed overflow; just
1367 unsigned overflow. */
1368 if ((x == FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY)
1369 && (c == FFETARGET_integerFINISH_BIG_OVERFLOW_BINARY)
1370 && (*(p + 1) == '\0'))
1371 {
1372 *val = FFETARGET_integerBIG_OVERFLOW_BINARY;
1373 return TRUE;
1374 }
1375 else
1376 #endif
1377 #if FFETARGET_integerFINISH_BIG_OVERFLOW_BINARY == 0
1378 if ((x & FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY) != 0)
1379 #else
1380 if (x == FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY)
1381 {
1382 if ((c > FFETARGET_integerFINISH_BIG_OVERFLOW_BINARY)
1383 || (*(p + 1) != '\0'))
1384 {
1385 ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1386 ffebad_here (0, ffelex_token_where_line (integer),
1387 ffelex_token_where_column (integer));
1388 ffebad_finish ();
1389 *val = 0;
1390 return FALSE;
1391 }
1392 }
1393 else if (x > FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY)
1394 #endif
1395 {
1396 ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1397 ffebad_here (0, ffelex_token_where_line (integer),
1398 ffelex_token_where_column (integer));
1399 ffebad_finish ();
1400 *val = 0;
1401 return FALSE;
1402 }
1403 x = (x << 1) + c;
1404 c = *(++p);
1405 };
1406
1407 if (bad_digit)
1408 {
1409 ffebad_start (FFEBAD_INVALID_BINARY_DIGIT);
1410 ffebad_here (0, ffelex_token_where_line (integer),
1411 ffelex_token_where_column (integer));
1412 ffebad_finish ();
1413 }
1414
1415 *val = x;
1416 return !bad_digit;
1417 }
1418
1419 /* ffetarget_integerhex -- Convert token to a hex integer
1420
1421 ffetarget_integerhex x;
1422 if (ffetarget_integerdefault_8(&x,integer_token))
1423 // conversion ok.
1424
1425 Token use count not affected overall. */
1426
1427 bool
ffetarget_integerhex(ffetargetIntegerDefault * val,ffelexToken integer)1428 ffetarget_integerhex (ffetargetIntegerDefault *val, ffelexToken integer)
1429 {
1430 ffetargetIntegerDefault x;
1431 char *p;
1432 char c;
1433 bool bad_digit;
1434
1435 assert ((ffelex_token_type (integer) == FFELEX_typeNAME)
1436 || (ffelex_token_type (integer) == FFELEX_typeNUMBER));
1437
1438 p = ffelex_token_text (integer);
1439 x = 0;
1440
1441 /* Skip past leading zeros. */
1442
1443 while (((c = *p) != '\0') && (c == '0'))
1444 ++p;
1445
1446 /* Interpret rest of number. */
1447
1448 bad_digit = FALSE;
1449 while (c != '\0')
1450 {
1451 if (hex_p (c))
1452 c = hex_value (c);
1453 else
1454 {
1455 bad_digit = TRUE;
1456 c = 0;
1457 }
1458
1459 #if 0 /* Don't complain about signed overflow; just
1460 unsigned overflow. */
1461 if ((x == FFETARGET_integerALMOST_BIG_OVERFLOW_HEX)
1462 && (c == FFETARGET_integerFINISH_BIG_OVERFLOW_HEX)
1463 && (*(p + 1) == '\0'))
1464 {
1465 *val = FFETARGET_integerBIG_OVERFLOW_HEX;
1466 return TRUE;
1467 }
1468 else
1469 #endif
1470 #if FFETARGET_integerFINISH_BIG_OVERFLOW_HEX == 0
1471 if (x >= FFETARGET_integerALMOST_BIG_OVERFLOW_HEX)
1472 #else
1473 if (x == FFETARGET_integerALMOST_BIG_OVERFLOW_HEX)
1474 {
1475 if ((c > FFETARGET_integerFINISH_BIG_OVERFLOW_HEX)
1476 || (*(p + 1) != '\0'))
1477 {
1478 ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1479 ffebad_here (0, ffelex_token_where_line (integer),
1480 ffelex_token_where_column (integer));
1481 ffebad_finish ();
1482 *val = 0;
1483 return FALSE;
1484 }
1485 }
1486 else if (x > FFETARGET_integerALMOST_BIG_OVERFLOW_HEX)
1487 #endif
1488 {
1489 ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1490 ffebad_here (0, ffelex_token_where_line (integer),
1491 ffelex_token_where_column (integer));
1492 ffebad_finish ();
1493 *val = 0;
1494 return FALSE;
1495 }
1496 x = (x << 4) + c;
1497 c = *(++p);
1498 };
1499
1500 if (bad_digit)
1501 {
1502 ffebad_start (FFEBAD_INVALID_HEX_DIGIT);
1503 ffebad_here (0, ffelex_token_where_line (integer),
1504 ffelex_token_where_column (integer));
1505 ffebad_finish ();
1506 }
1507
1508 *val = x;
1509 return !bad_digit;
1510 }
1511
1512 /* ffetarget_integeroctal -- Convert token to an octal integer
1513
1514 ffetarget_integeroctal x;
1515 if (ffetarget_integerdefault_8(&x,integer_token))
1516 // conversion ok.
1517
1518 Token use count not affected overall. */
1519
1520 bool
ffetarget_integeroctal(ffetargetIntegerDefault * val,ffelexToken integer)1521 ffetarget_integeroctal (ffetargetIntegerDefault *val, ffelexToken integer)
1522 {
1523 ffetargetIntegerDefault x;
1524 char *p;
1525 char c;
1526 bool bad_digit;
1527
1528 assert ((ffelex_token_type (integer) == FFELEX_typeNAME)
1529 || (ffelex_token_type (integer) == FFELEX_typeNUMBER));
1530
1531 p = ffelex_token_text (integer);
1532 x = 0;
1533
1534 /* Skip past leading zeros. */
1535
1536 while (((c = *p) != '\0') && (c == '0'))
1537 ++p;
1538
1539 /* Interpret rest of number. */
1540
1541 bad_digit = FALSE;
1542 while (c != '\0')
1543 {
1544 if ((c >= '0') && (c <= '7'))
1545 c -= '0';
1546 else
1547 {
1548 bad_digit = TRUE;
1549 c = 0;
1550 }
1551
1552 #if 0 /* Don't complain about signed overflow; just
1553 unsigned overflow. */
1554 if ((x == FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
1555 && (c == FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL)
1556 && (*(p + 1) == '\0'))
1557 {
1558 *val = FFETARGET_integerBIG_OVERFLOW_OCTAL;
1559 return TRUE;
1560 }
1561 else
1562 #endif
1563 #if FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL == 0
1564 if (x >= FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
1565 #else
1566 if (x == FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
1567 {
1568 if ((c > FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL)
1569 || (*(p + 1) != '\0'))
1570 {
1571 ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1572 ffebad_here (0, ffelex_token_where_line (integer),
1573 ffelex_token_where_column (integer));
1574 ffebad_finish ();
1575 *val = 0;
1576 return FALSE;
1577 }
1578 }
1579 else if (x > FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
1580 #endif
1581 {
1582 ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1583 ffebad_here (0, ffelex_token_where_line (integer),
1584 ffelex_token_where_column (integer));
1585 ffebad_finish ();
1586 *val = 0;
1587 return FALSE;
1588 }
1589 x = (x << 3) + c;
1590 c = *(++p);
1591 };
1592
1593 if (bad_digit)
1594 {
1595 ffebad_start (FFEBAD_INVALID_OCTAL_DIGIT);
1596 ffebad_here (0, ffelex_token_where_line (integer),
1597 ffelex_token_where_column (integer));
1598 ffebad_finish ();
1599 }
1600
1601 *val = x;
1602 return !bad_digit;
1603 }
1604
1605 /* ffetarget_multiply_complex1 -- Multiply function
1606
1607 See prototype. */
1608
1609 #if FFETARGET_okCOMPLEX1
1610 ffebad
ffetarget_multiply_complex1(ffetargetComplex1 * res,ffetargetComplex1 l,ffetargetComplex1 r)1611 ffetarget_multiply_complex1 (ffetargetComplex1 *res, ffetargetComplex1 l,
1612 ffetargetComplex1 r)
1613 {
1614 ffebad bad;
1615 ffetargetReal1 tmp1, tmp2;
1616
1617 bad = ffetarget_multiply_real1 (&tmp1, l.real, r.real);
1618 if (bad != FFEBAD)
1619 return bad;
1620 bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, r.imaginary);
1621 if (bad != FFEBAD)
1622 return bad;
1623 bad = ffetarget_subtract_real1 (&res->real, tmp1, tmp2);
1624 if (bad != FFEBAD)
1625 return bad;
1626 bad = ffetarget_multiply_real1 (&tmp1, l.imaginary, r.real);
1627 if (bad != FFEBAD)
1628 return bad;
1629 bad = ffetarget_multiply_real1 (&tmp2, l.real, r.imaginary);
1630 if (bad != FFEBAD)
1631 return bad;
1632 bad = ffetarget_add_real1 (&res->imaginary, tmp1, tmp2);
1633
1634 return bad;
1635 }
1636
1637 #endif
1638 /* ffetarget_multiply_complex2 -- Multiply function
1639
1640 See prototype. */
1641
1642 #if FFETARGET_okCOMPLEX2
1643 ffebad
ffetarget_multiply_complex2(ffetargetComplex2 * res,ffetargetComplex2 l,ffetargetComplex2 r)1644 ffetarget_multiply_complex2 (ffetargetComplex2 *res, ffetargetComplex2 l,
1645 ffetargetComplex2 r)
1646 {
1647 ffebad bad;
1648 ffetargetReal2 tmp1, tmp2;
1649
1650 bad = ffetarget_multiply_real2 (&tmp1, l.real, r.real);
1651 if (bad != FFEBAD)
1652 return bad;
1653 bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, r.imaginary);
1654 if (bad != FFEBAD)
1655 return bad;
1656 bad = ffetarget_subtract_real2 (&res->real, tmp1, tmp2);
1657 if (bad != FFEBAD)
1658 return bad;
1659 bad = ffetarget_multiply_real2 (&tmp1, l.imaginary, r.real);
1660 if (bad != FFEBAD)
1661 return bad;
1662 bad = ffetarget_multiply_real2 (&tmp2, l.real, r.imaginary);
1663 if (bad != FFEBAD)
1664 return bad;
1665 bad = ffetarget_add_real2 (&res->imaginary, tmp1, tmp2);
1666
1667 return bad;
1668 }
1669
1670 #endif
1671 /* ffetarget_power_complexdefault_integerdefault -- Power function
1672
1673 See prototype. */
1674
1675 ffebad
ffetarget_power_complexdefault_integerdefault(ffetargetComplexDefault * res,ffetargetComplexDefault l,ffetargetIntegerDefault r)1676 ffetarget_power_complexdefault_integerdefault (ffetargetComplexDefault *res,
1677 ffetargetComplexDefault l,
1678 ffetargetIntegerDefault r)
1679 {
1680 ffebad bad;
1681 ffetargetRealDefault tmp;
1682 ffetargetRealDefault tmp1;
1683 ffetargetRealDefault tmp2;
1684 ffetargetRealDefault two;
1685
1686 if (ffetarget_iszero_real1 (l.real)
1687 && ffetarget_iszero_real1 (l.imaginary))
1688 {
1689 ffetarget_real1_zero (&res->real);
1690 ffetarget_real1_zero (&res->imaginary);
1691 return FFEBAD;
1692 }
1693
1694 if (r == 0)
1695 {
1696 ffetarget_real1_one (&res->real);
1697 ffetarget_real1_zero (&res->imaginary);
1698 return FFEBAD;
1699 }
1700
1701 if (r < 0)
1702 {
1703 r = -r;
1704 bad = ffetarget_multiply_real1 (&tmp1, l.real, l.real);
1705 if (bad != FFEBAD)
1706 return bad;
1707 bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, l.imaginary);
1708 if (bad != FFEBAD)
1709 return bad;
1710 bad = ffetarget_add_real1 (&tmp, tmp1, tmp2);
1711 if (bad != FFEBAD)
1712 return bad;
1713 bad = ffetarget_divide_real1 (&l.real, l.real, tmp);
1714 if (bad != FFEBAD)
1715 return bad;
1716 bad = ffetarget_divide_real1 (&l.imaginary, l.imaginary, tmp);
1717 if (bad != FFEBAD)
1718 return bad;
1719 bad = ffetarget_uminus_real1 (&l.imaginary, l.imaginary);
1720 if (bad != FFEBAD)
1721 return bad;
1722 }
1723
1724 ffetarget_real1_two (&two);
1725
1726 while ((r & 1) == 0)
1727 {
1728 bad = ffetarget_multiply_real1 (&tmp1, l.real, l.real);
1729 if (bad != FFEBAD)
1730 return bad;
1731 bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, l.imaginary);
1732 if (bad != FFEBAD)
1733 return bad;
1734 bad = ffetarget_subtract_real1 (&tmp, tmp1, tmp2);
1735 if (bad != FFEBAD)
1736 return bad;
1737 bad = ffetarget_multiply_real1 (&l.imaginary, l.real, l.imaginary);
1738 if (bad != FFEBAD)
1739 return bad;
1740 bad = ffetarget_multiply_real1 (&l.imaginary, l.imaginary, two);
1741 if (bad != FFEBAD)
1742 return bad;
1743 l.real = tmp;
1744 r >>= 1;
1745 }
1746
1747 *res = l;
1748 r >>= 1;
1749
1750 while (r != 0)
1751 {
1752 bad = ffetarget_multiply_real1 (&tmp1, l.real, l.real);
1753 if (bad != FFEBAD)
1754 return bad;
1755 bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, l.imaginary);
1756 if (bad != FFEBAD)
1757 return bad;
1758 bad = ffetarget_subtract_real1 (&tmp, tmp1, tmp2);
1759 if (bad != FFEBAD)
1760 return bad;
1761 bad = ffetarget_multiply_real1 (&l.imaginary, l.real, l.imaginary);
1762 if (bad != FFEBAD)
1763 return bad;
1764 bad = ffetarget_multiply_real1 (&l.imaginary, l.imaginary, two);
1765 if (bad != FFEBAD)
1766 return bad;
1767 l.real = tmp;
1768 if ((r & 1) == 1)
1769 {
1770 bad = ffetarget_multiply_real1 (&tmp1, res->real, l.real);
1771 if (bad != FFEBAD)
1772 return bad;
1773 bad = ffetarget_multiply_real1 (&tmp2, res->imaginary,
1774 l.imaginary);
1775 if (bad != FFEBAD)
1776 return bad;
1777 bad = ffetarget_subtract_real1 (&tmp, tmp1, tmp2);
1778 if (bad != FFEBAD)
1779 return bad;
1780 bad = ffetarget_multiply_real1 (&tmp1, res->imaginary, l.real);
1781 if (bad != FFEBAD)
1782 return bad;
1783 bad = ffetarget_multiply_real1 (&tmp2, res->real, l.imaginary);
1784 if (bad != FFEBAD)
1785 return bad;
1786 bad = ffetarget_add_real1 (&res->imaginary, tmp1, tmp2);
1787 if (bad != FFEBAD)
1788 return bad;
1789 res->real = tmp;
1790 }
1791 r >>= 1;
1792 }
1793
1794 return FFEBAD;
1795 }
1796
1797 /* ffetarget_power_complexdouble_integerdefault -- Power function
1798
1799 See prototype. */
1800
1801 #if FFETARGET_okCOMPLEXDOUBLE
1802 ffebad
ffetarget_power_complexdouble_integerdefault(ffetargetComplexDouble * res,ffetargetComplexDouble l,ffetargetIntegerDefault r)1803 ffetarget_power_complexdouble_integerdefault (ffetargetComplexDouble *res,
1804 ffetargetComplexDouble l, ffetargetIntegerDefault r)
1805 {
1806 ffebad bad;
1807 ffetargetRealDouble tmp;
1808 ffetargetRealDouble tmp1;
1809 ffetargetRealDouble tmp2;
1810 ffetargetRealDouble two;
1811
1812 if (ffetarget_iszero_real2 (l.real)
1813 && ffetarget_iszero_real2 (l.imaginary))
1814 {
1815 ffetarget_real2_zero (&res->real);
1816 ffetarget_real2_zero (&res->imaginary);
1817 return FFEBAD;
1818 }
1819
1820 if (r == 0)
1821 {
1822 ffetarget_real2_one (&res->real);
1823 ffetarget_real2_zero (&res->imaginary);
1824 return FFEBAD;
1825 }
1826
1827 if (r < 0)
1828 {
1829 r = -r;
1830 bad = ffetarget_multiply_real2 (&tmp1, l.real, l.real);
1831 if (bad != FFEBAD)
1832 return bad;
1833 bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, l.imaginary);
1834 if (bad != FFEBAD)
1835 return bad;
1836 bad = ffetarget_add_real2 (&tmp, tmp1, tmp2);
1837 if (bad != FFEBAD)
1838 return bad;
1839 bad = ffetarget_divide_real2 (&l.real, l.real, tmp);
1840 if (bad != FFEBAD)
1841 return bad;
1842 bad = ffetarget_divide_real2 (&l.imaginary, l.imaginary, tmp);
1843 if (bad != FFEBAD)
1844 return bad;
1845 bad = ffetarget_uminus_real2 (&l.imaginary, l.imaginary);
1846 if (bad != FFEBAD)
1847 return bad;
1848 }
1849
1850 ffetarget_real2_two (&two);
1851
1852 while ((r & 1) == 0)
1853 {
1854 bad = ffetarget_multiply_real2 (&tmp1, l.real, l.real);
1855 if (bad != FFEBAD)
1856 return bad;
1857 bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, l.imaginary);
1858 if (bad != FFEBAD)
1859 return bad;
1860 bad = ffetarget_subtract_real2 (&tmp, tmp1, tmp2);
1861 if (bad != FFEBAD)
1862 return bad;
1863 bad = ffetarget_multiply_real2 (&l.imaginary, l.real, l.imaginary);
1864 if (bad != FFEBAD)
1865 return bad;
1866 bad = ffetarget_multiply_real2 (&l.imaginary, l.imaginary, two);
1867 if (bad != FFEBAD)
1868 return bad;
1869 l.real = tmp;
1870 r >>= 1;
1871 }
1872
1873 *res = l;
1874 r >>= 1;
1875
1876 while (r != 0)
1877 {
1878 bad = ffetarget_multiply_real2 (&tmp1, l.real, l.real);
1879 if (bad != FFEBAD)
1880 return bad;
1881 bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, l.imaginary);
1882 if (bad != FFEBAD)
1883 return bad;
1884 bad = ffetarget_subtract_real2 (&tmp, tmp1, tmp2);
1885 if (bad != FFEBAD)
1886 return bad;
1887 bad = ffetarget_multiply_real2 (&l.imaginary, l.real, l.imaginary);
1888 if (bad != FFEBAD)
1889 return bad;
1890 bad = ffetarget_multiply_real2 (&l.imaginary, l.imaginary, two);
1891 if (bad != FFEBAD)
1892 return bad;
1893 l.real = tmp;
1894 if ((r & 1) == 1)
1895 {
1896 bad = ffetarget_multiply_real2 (&tmp1, res->real, l.real);
1897 if (bad != FFEBAD)
1898 return bad;
1899 bad = ffetarget_multiply_real2 (&tmp2, res->imaginary,
1900 l.imaginary);
1901 if (bad != FFEBAD)
1902 return bad;
1903 bad = ffetarget_subtract_real2 (&tmp, tmp1, tmp2);
1904 if (bad != FFEBAD)
1905 return bad;
1906 bad = ffetarget_multiply_real2 (&tmp1, res->imaginary, l.real);
1907 if (bad != FFEBAD)
1908 return bad;
1909 bad = ffetarget_multiply_real2 (&tmp2, res->real, l.imaginary);
1910 if (bad != FFEBAD)
1911 return bad;
1912 bad = ffetarget_add_real2 (&res->imaginary, tmp1, tmp2);
1913 if (bad != FFEBAD)
1914 return bad;
1915 res->real = tmp;
1916 }
1917 r >>= 1;
1918 }
1919
1920 return FFEBAD;
1921 }
1922
1923 #endif
1924 /* ffetarget_power_integerdefault_integerdefault -- Power function
1925
1926 See prototype. */
1927
1928 ffebad
ffetarget_power_integerdefault_integerdefault(ffetargetIntegerDefault * res,ffetargetIntegerDefault l,ffetargetIntegerDefault r)1929 ffetarget_power_integerdefault_integerdefault (ffetargetIntegerDefault *res,
1930 ffetargetIntegerDefault l, ffetargetIntegerDefault r)
1931 {
1932 if (l == 0)
1933 {
1934 *res = 0;
1935 return FFEBAD;
1936 }
1937
1938 if (r == 0)
1939 {
1940 *res = 1;
1941 return FFEBAD;
1942 }
1943
1944 if (r < 0)
1945 {
1946 if (l == 1)
1947 *res = 1;
1948 else if (l == 0)
1949 *res = 1;
1950 else if (l == -1)
1951 *res = ((-r) & 1) == 0 ? 1 : -1;
1952 else
1953 *res = 0;
1954 return FFEBAD;
1955 }
1956
1957 while ((r & 1) == 0)
1958 {
1959 l *= l;
1960 r >>= 1;
1961 }
1962
1963 *res = l;
1964 r >>= 1;
1965
1966 while (r != 0)
1967 {
1968 l *= l;
1969 if ((r & 1) == 1)
1970 *res *= l;
1971 r >>= 1;
1972 }
1973
1974 return FFEBAD;
1975 }
1976
1977 /* ffetarget_power_realdefault_integerdefault -- Power function
1978
1979 See prototype. */
1980
1981 ffebad
ffetarget_power_realdefault_integerdefault(ffetargetRealDefault * res,ffetargetRealDefault l,ffetargetIntegerDefault r)1982 ffetarget_power_realdefault_integerdefault (ffetargetRealDefault *res,
1983 ffetargetRealDefault l, ffetargetIntegerDefault r)
1984 {
1985 ffebad bad;
1986
1987 if (ffetarget_iszero_real1 (l))
1988 {
1989 ffetarget_real1_zero (res);
1990 return FFEBAD;
1991 }
1992
1993 if (r == 0)
1994 {
1995 ffetarget_real1_one (res);
1996 return FFEBAD;
1997 }
1998
1999 if (r < 0)
2000 {
2001 ffetargetRealDefault one;
2002
2003 ffetarget_real1_one (&one);
2004 r = -r;
2005 bad = ffetarget_divide_real1 (&l, one, l);
2006 if (bad != FFEBAD)
2007 return bad;
2008 }
2009
2010 while ((r & 1) == 0)
2011 {
2012 bad = ffetarget_multiply_real1 (&l, l, l);
2013 if (bad != FFEBAD)
2014 return bad;
2015 r >>= 1;
2016 }
2017
2018 *res = l;
2019 r >>= 1;
2020
2021 while (r != 0)
2022 {
2023 bad = ffetarget_multiply_real1 (&l, l, l);
2024 if (bad != FFEBAD)
2025 return bad;
2026 if ((r & 1) == 1)
2027 {
2028 bad = ffetarget_multiply_real1 (res, *res, l);
2029 if (bad != FFEBAD)
2030 return bad;
2031 }
2032 r >>= 1;
2033 }
2034
2035 return FFEBAD;
2036 }
2037
2038 /* ffetarget_power_realdouble_integerdefault -- Power function
2039
2040 See prototype. */
2041
2042 ffebad
ffetarget_power_realdouble_integerdefault(ffetargetRealDouble * res,ffetargetRealDouble l,ffetargetIntegerDefault r)2043 ffetarget_power_realdouble_integerdefault (ffetargetRealDouble *res,
2044 ffetargetRealDouble l,
2045 ffetargetIntegerDefault r)
2046 {
2047 ffebad bad;
2048
2049 if (ffetarget_iszero_real2 (l))
2050 {
2051 ffetarget_real2_zero (res);
2052 return FFEBAD;
2053 }
2054
2055 if (r == 0)
2056 {
2057 ffetarget_real2_one (res);
2058 return FFEBAD;
2059 }
2060
2061 if (r < 0)
2062 {
2063 ffetargetRealDouble one;
2064
2065 ffetarget_real2_one (&one);
2066 r = -r;
2067 bad = ffetarget_divide_real2 (&l, one, l);
2068 if (bad != FFEBAD)
2069 return bad;
2070 }
2071
2072 while ((r & 1) == 0)
2073 {
2074 bad = ffetarget_multiply_real2 (&l, l, l);
2075 if (bad != FFEBAD)
2076 return bad;
2077 r >>= 1;
2078 }
2079
2080 *res = l;
2081 r >>= 1;
2082
2083 while (r != 0)
2084 {
2085 bad = ffetarget_multiply_real2 (&l, l, l);
2086 if (bad != FFEBAD)
2087 return bad;
2088 if ((r & 1) == 1)
2089 {
2090 bad = ffetarget_multiply_real2 (res, *res, l);
2091 if (bad != FFEBAD)
2092 return bad;
2093 }
2094 r >>= 1;
2095 }
2096
2097 return FFEBAD;
2098 }
2099
2100 /* ffetarget_print_binary -- Output typeless binary integer
2101
2102 ffetargetTypeless val;
2103 ffetarget_typeless_binary(dmpout,val); */
2104
2105 void
ffetarget_print_binary(FILE * f,ffetargetTypeless value)2106 ffetarget_print_binary (FILE *f, ffetargetTypeless value)
2107 {
2108 char *p;
2109 char digits[sizeof (value) * CHAR_BIT + 1];
2110
2111 if (f == NULL)
2112 f = dmpout;
2113
2114 p = &digits[ARRAY_SIZE (digits) - 1];
2115 *p = '\0';
2116 do
2117 {
2118 *--p = (value & 1) + '0';
2119 value >>= 1;
2120 } while (value == 0);
2121
2122 fputs (p, f);
2123 }
2124
2125 /* ffetarget_print_character1 -- Output character string
2126
2127 ffetargetCharacter1 val;
2128 ffetarget_print_character1(dmpout,val); */
2129
2130 void
ffetarget_print_character1(FILE * f,ffetargetCharacter1 value)2131 ffetarget_print_character1 (FILE *f, ffetargetCharacter1 value)
2132 {
2133 unsigned char *p;
2134 ffetargetCharacterSize i;
2135
2136 fputc ('\'', dmpout);
2137 for (i = 0, p = value.text; i < value.length; ++i, ++p)
2138 ffetarget_print_char_ (f, *p);
2139 fputc ('\'', dmpout);
2140 }
2141
2142 /* ffetarget_print_hollerith -- Output hollerith string
2143
2144 ffetargetHollerith val;
2145 ffetarget_print_hollerith(dmpout,val); */
2146
2147 void
ffetarget_print_hollerith(FILE * f,ffetargetHollerith value)2148 ffetarget_print_hollerith (FILE *f, ffetargetHollerith value)
2149 {
2150 unsigned char *p;
2151 ffetargetHollerithSize i;
2152
2153 fputc ('\'', dmpout);
2154 for (i = 0, p = value.text; i < value.length; ++i, ++p)
2155 ffetarget_print_char_ (f, *p);
2156 fputc ('\'', dmpout);
2157 }
2158
2159 /* ffetarget_print_octal -- Output typeless octal integer
2160
2161 ffetargetTypeless val;
2162 ffetarget_print_octal(dmpout,val); */
2163
2164 void
ffetarget_print_octal(FILE * f,ffetargetTypeless value)2165 ffetarget_print_octal (FILE *f, ffetargetTypeless value)
2166 {
2167 char *p;
2168 char digits[sizeof (value) * CHAR_BIT / 3 + 1];
2169
2170 if (f == NULL)
2171 f = dmpout;
2172
2173 p = &digits[ARRAY_SIZE (digits) - 3];
2174 *p = '\0';
2175 do
2176 {
2177 *--p = (value & 3) + '0';
2178 value >>= 3;
2179 } while (value == 0);
2180
2181 fputs (p, f);
2182 }
2183
2184 /* ffetarget_print_hex -- Output typeless hex integer
2185
2186 ffetargetTypeless val;
2187 ffetarget_print_hex(dmpout,val); */
2188
2189 void
ffetarget_print_hex(FILE * f,ffetargetTypeless value)2190 ffetarget_print_hex (FILE *f, ffetargetTypeless value)
2191 {
2192 char *p;
2193 char digits[sizeof (value) * CHAR_BIT / 4 + 1];
2194 static const char hexdigits[16] = "0123456789ABCDEF";
2195
2196 if (f == NULL)
2197 f = dmpout;
2198
2199 p = &digits[ARRAY_SIZE (digits) - 3];
2200 *p = '\0';
2201 do
2202 {
2203 *--p = hexdigits[value & 4];
2204 value >>= 4;
2205 } while (value == 0);
2206
2207 fputs (p, f);
2208 }
2209
2210 /* ffetarget_real1 -- Convert token to a single-precision real number
2211
2212 See prototype.
2213
2214 Pass NULL for any token not provided by the user, but a valid Fortran
2215 real number must be provided somehow. For example, it is ok for
2216 exponent_sign_token and exponent_digits_token to be NULL as long as
2217 exponent_token not only starts with "E" or "e" but also contains at least
2218 one digit following it. Token use counts not affected overall. */
2219
2220 #if FFETARGET_okREAL1
2221 bool
ffetarget_real1(ffetargetReal1 * value,ffelexToken integer,ffelexToken decimal,ffelexToken fraction,ffelexToken exponent,ffelexToken exponent_sign,ffelexToken exponent_digits)2222 ffetarget_real1 (ffetargetReal1 *value, ffelexToken integer,
2223 ffelexToken decimal, ffelexToken fraction,
2224 ffelexToken exponent, ffelexToken exponent_sign,
2225 ffelexToken exponent_digits)
2226 {
2227 size_t sz = 1; /* Allow room for '\0' byte at end. */
2228 char *ptr = &ffetarget_string_[0];
2229 char *p = ptr;
2230 char *q;
2231
2232 #define dotok(x) if (x != NULL) ++sz;
2233 #define dotoktxt(x) if (x != NULL) sz += ffelex_token_length(x)
2234
2235 dotoktxt (integer);
2236 dotok (decimal);
2237 dotoktxt (fraction);
2238 dotoktxt (exponent);
2239 dotok (exponent_sign);
2240 dotoktxt (exponent_digits);
2241
2242 #undef dotok
2243 #undef dotoktxt
2244
2245 if (sz > ARRAY_SIZE (ffetarget_string_))
2246 p = ptr = (char *) malloc_new_ks (malloc_pool_image (), "ffetarget_real1",
2247 sz);
2248
2249 #define dotoktxt(x) if (x != NULL) \
2250 { \
2251 for (q = ffelex_token_text(x); *q != '\0'; ++q) \
2252 *p++ = *q; \
2253 }
2254
2255 dotoktxt (integer);
2256
2257 if (decimal != NULL)
2258 *p++ = '.';
2259
2260 dotoktxt (fraction);
2261 dotoktxt (exponent);
2262
2263 if (exponent_sign != NULL)
2264 {
2265 if (ffelex_token_type (exponent_sign) == FFELEX_typePLUS)
2266 *p++ = '+';
2267 else
2268 {
2269 assert (ffelex_token_type (exponent_sign) == FFELEX_typeMINUS);
2270 *p++ = '-';
2271 }
2272 }
2273
2274 dotoktxt (exponent_digits);
2275
2276 #undef dotoktxt
2277
2278 *p = '\0';
2279
2280 {
2281 REAL_VALUE_TYPE rv;
2282 rv = FFETARGET_ATOF_ (ptr, SFmode);
2283 ffetarget_make_real1 (value, rv);
2284 }
2285
2286 if (sz > ARRAY_SIZE (ffetarget_string_))
2287 malloc_kill_ks (malloc_pool_image (), ptr, sz);
2288
2289 return TRUE;
2290 }
2291
2292 #endif
2293 /* ffetarget_real2 -- Convert token to a single-precision real number
2294
2295 See prototype.
2296
2297 Pass NULL for any token not provided by the user, but a valid Fortran
2298 real number must be provided somehow. For example, it is ok for
2299 exponent_sign_token and exponent_digits_token to be NULL as long as
2300 exponent_token not only starts with "E" or "e" but also contains at least
2301 one digit following it. Token use counts not affected overall. */
2302
2303 #if FFETARGET_okREAL2
2304 bool
ffetarget_real2(ffetargetReal2 * value,ffelexToken integer,ffelexToken decimal,ffelexToken fraction,ffelexToken exponent,ffelexToken exponent_sign,ffelexToken exponent_digits)2305 ffetarget_real2 (ffetargetReal2 *value, ffelexToken integer,
2306 ffelexToken decimal, ffelexToken fraction,
2307 ffelexToken exponent, ffelexToken exponent_sign,
2308 ffelexToken exponent_digits)
2309 {
2310 size_t sz = 1; /* Allow room for '\0' byte at end. */
2311 char *ptr = &ffetarget_string_[0];
2312 char *p = ptr;
2313 char *q;
2314
2315 #define dotok(x) if (x != NULL) ++sz;
2316 #define dotoktxt(x) if (x != NULL) sz += ffelex_token_length(x)
2317
2318 dotoktxt (integer);
2319 dotok (decimal);
2320 dotoktxt (fraction);
2321 dotoktxt (exponent);
2322 dotok (exponent_sign);
2323 dotoktxt (exponent_digits);
2324
2325 #undef dotok
2326 #undef dotoktxt
2327
2328 if (sz > ARRAY_SIZE (ffetarget_string_))
2329 p = ptr = (char *) malloc_new_ks (malloc_pool_image (), "ffetarget_real1", sz);
2330
2331 #define dotoktxt(x) if (x != NULL) \
2332 { \
2333 for (q = ffelex_token_text(x); *q != '\0'; ++q) \
2334 *p++ = *q; \
2335 }
2336 #define dotoktxtexp(x) if (x != NULL) \
2337 { \
2338 *p++ = 'E'; \
2339 for (q = ffelex_token_text(x) + 1; *q != '\0'; ++q) \
2340 *p++ = *q; \
2341 }
2342
2343 dotoktxt (integer);
2344
2345 if (decimal != NULL)
2346 *p++ = '.';
2347
2348 dotoktxt (fraction);
2349 dotoktxtexp (exponent);
2350
2351 if (exponent_sign != NULL)
2352 {
2353 if (ffelex_token_type (exponent_sign) == FFELEX_typePLUS)
2354 *p++ = '+';
2355 else
2356 {
2357 assert (ffelex_token_type (exponent_sign) == FFELEX_typeMINUS);
2358 *p++ = '-';
2359 }
2360 }
2361
2362 dotoktxt (exponent_digits);
2363
2364 #undef dotoktxt
2365
2366 *p = '\0';
2367
2368 {
2369 REAL_VALUE_TYPE rv;
2370 rv = FFETARGET_ATOF_ (ptr, DFmode);
2371 ffetarget_make_real2 (value, rv);
2372 }
2373
2374 if (sz > ARRAY_SIZE (ffetarget_string_))
2375 malloc_kill_ks (malloc_pool_image (), ptr, sz);
2376
2377 return TRUE;
2378 }
2379
2380 #endif
2381 bool
ffetarget_typeless_binary(ffetargetTypeless * xvalue,ffelexToken token)2382 ffetarget_typeless_binary (ffetargetTypeless *xvalue, ffelexToken token)
2383 {
2384 char *p;
2385 char c;
2386 ffetargetTypeless value = 0;
2387 ffetargetTypeless new_value = 0;
2388 bool bad_digit = FALSE;
2389 bool overflow = FALSE;
2390
2391 p = ffelex_token_text (token);
2392
2393 for (c = *p; c != '\0'; c = *++p)
2394 {
2395 new_value <<= 1;
2396 if ((new_value >> 1) != value)
2397 overflow = TRUE;
2398 if (ISDIGIT (c))
2399 new_value += c - '0';
2400 else
2401 bad_digit = TRUE;
2402 value = new_value;
2403 }
2404
2405 if (bad_digit)
2406 {
2407 ffebad_start (FFEBAD_INVALID_TYPELESS_BINARY_DIGIT);
2408 ffebad_here (0, ffelex_token_where_line (token),
2409 ffelex_token_where_column (token));
2410 ffebad_finish ();
2411 }
2412 else if (overflow)
2413 {
2414 ffebad_start (FFEBAD_TYPELESS_OVERFLOW);
2415 ffebad_here (0, ffelex_token_where_line (token),
2416 ffelex_token_where_column (token));
2417 ffebad_finish ();
2418 }
2419
2420 *xvalue = value;
2421
2422 return !bad_digit && !overflow;
2423 }
2424
2425 bool
ffetarget_typeless_octal(ffetargetTypeless * xvalue,ffelexToken token)2426 ffetarget_typeless_octal (ffetargetTypeless *xvalue, ffelexToken token)
2427 {
2428 char *p;
2429 char c;
2430 ffetargetTypeless value = 0;
2431 ffetargetTypeless new_value = 0;
2432 bool bad_digit = FALSE;
2433 bool overflow = FALSE;
2434
2435 p = ffelex_token_text (token);
2436
2437 for (c = *p; c != '\0'; c = *++p)
2438 {
2439 new_value <<= 3;
2440 if ((new_value >> 3) != value)
2441 overflow = TRUE;
2442 if (ISDIGIT (c))
2443 new_value += c - '0';
2444 else
2445 bad_digit = TRUE;
2446 value = new_value;
2447 }
2448
2449 if (bad_digit)
2450 {
2451 ffebad_start (FFEBAD_INVALID_TYPELESS_OCTAL_DIGIT);
2452 ffebad_here (0, ffelex_token_where_line (token),
2453 ffelex_token_where_column (token));
2454 ffebad_finish ();
2455 }
2456 else if (overflow)
2457 {
2458 ffebad_start (FFEBAD_TYPELESS_OVERFLOW);
2459 ffebad_here (0, ffelex_token_where_line (token),
2460 ffelex_token_where_column (token));
2461 ffebad_finish ();
2462 }
2463
2464 *xvalue = value;
2465
2466 return !bad_digit && !overflow;
2467 }
2468
2469 bool
ffetarget_typeless_hex(ffetargetTypeless * xvalue,ffelexToken token)2470 ffetarget_typeless_hex (ffetargetTypeless *xvalue, ffelexToken token)
2471 {
2472 char *p;
2473 char c;
2474 ffetargetTypeless value = 0;
2475 ffetargetTypeless new_value = 0;
2476 bool bad_digit = FALSE;
2477 bool overflow = FALSE;
2478
2479 p = ffelex_token_text (token);
2480
2481 for (c = *p; c != '\0'; c = *++p)
2482 {
2483 new_value <<= 4;
2484 if ((new_value >> 4) != value)
2485 overflow = TRUE;
2486 if (hex_p (c))
2487 new_value += hex_value (c);
2488 else
2489 bad_digit = TRUE;
2490 value = new_value;
2491 }
2492
2493 if (bad_digit)
2494 {
2495 ffebad_start (FFEBAD_INVALID_TYPELESS_HEX_DIGIT);
2496 ffebad_here (0, ffelex_token_where_line (token),
2497 ffelex_token_where_column (token));
2498 ffebad_finish ();
2499 }
2500 else if (overflow)
2501 {
2502 ffebad_start (FFEBAD_TYPELESS_OVERFLOW);
2503 ffebad_here (0, ffelex_token_where_line (token),
2504 ffelex_token_where_column (token));
2505 ffebad_finish ();
2506 }
2507
2508 *xvalue = value;
2509
2510 return !bad_digit && !overflow;
2511 }
2512
2513 void
ffetarget_verify_character1(mallocPool pool,ffetargetCharacter1 val)2514 ffetarget_verify_character1 (mallocPool pool, ffetargetCharacter1 val)
2515 {
2516 if (val.length != 0)
2517 malloc_verify_kp (pool, val.text, val.length);
2518 }
2519
2520 /* This is like memcpy. It is needed because some systems' header files
2521 don't declare memcpy as a function but instead
2522 "#define memcpy(to,from,len) something". */
2523
2524 void *
ffetarget_memcpy_(void * dst,void * src,size_t len)2525 ffetarget_memcpy_ (void *dst, void *src, size_t len)
2526 {
2527 #ifdef CROSS_COMPILE
2528 /* HOST_WORDS_BIG_ENDIAN corresponds to both WORDS_BIG_ENDIAN and
2529 BYTES_BIG_ENDIAN (i.e. there are no HOST_ macros to represent a
2530 difference in the two latter). */
2531 int host_words_big_endian =
2532 #ifndef HOST_WORDS_BIG_ENDIAN
2533 0
2534 #else
2535 HOST_WORDS_BIG_ENDIAN
2536 #endif
2537 ;
2538
2539 /* This is just hands thrown up in the air over bits coming through this
2540 function representing a number being memcpy:d as-is from host to
2541 target. We can't generally adjust endianness here since we don't
2542 know whether it's an integer or floating point number; they're passed
2543 differently. Better to not emit code at all than to emit wrong code.
2544 We will get some false hits because some data coming through here
2545 seems to be just character vectors, but often enough it's numbers,
2546 for instance in g77.f-torture/execute/980628-[4-6].f and alpha2.f.
2547 Still, we compile *some* code. FIXME: Rewrite handling of numbers. */
2548 if (!WORDS_BIG_ENDIAN != !host_words_big_endian
2549 || !BYTES_BIG_ENDIAN != !host_words_big_endian)
2550 sorry ("data initializer on host with different endianness");
2551
2552 #endif /* CROSS_COMPILE */
2553
2554 return (void *) memcpy (dst, src, len);
2555 }
2556
2557 /* ffetarget_num_digits_ -- Determine number of non-space characters in token
2558
2559 ffetarget_num_digits_(token);
2560
2561 All non-spaces are assumed to be binary, octal, or hex digits. */
2562
2563 int
ffetarget_num_digits_(ffelexToken token)2564 ffetarget_num_digits_ (ffelexToken token)
2565 {
2566 int i;
2567 char *c;
2568
2569 switch (ffelex_token_type (token))
2570 {
2571 case FFELEX_typeNAME:
2572 case FFELEX_typeNUMBER:
2573 return ffelex_token_length (token);
2574
2575 case FFELEX_typeCHARACTER:
2576 i = 0;
2577 for (c = ffelex_token_text (token); *c != '\0'; ++c)
2578 {
2579 if (*c != ' ')
2580 ++i;
2581 }
2582 return i;
2583
2584 default:
2585 assert ("weird token" == NULL);
2586 return 1;
2587 }
2588 }
2589