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