]> 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
980701-0.f, 980701-1.f: New test 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
a6fa6420 220 /* The easy case: similar alignment requirements. */
5ff904cd
JL		 221 if (*updated_alignment == alignment)
222 {
223 if (modulo > *updated_modulo)
224 pad = alignment - (modulo - *updated_modulo);
225 else
226 pad = *updated_modulo - modulo;
a6fa6420
CB		 227 if (offset < 0)
228 /* De-negatize offset, since % wouldn't do the expected thing. */
229 offset = alignment - ((- offset) % alignment);
5ff904cd
JL		 230 pad = (offset + pad) % alignment;
231 if (pad != 0)
232 pad = alignment - pad;
233 return pad;
234 }
235
236 /* Sigh, find LCM (Least Common Multiple) for the two alignment factors. */
237
238 for (ua = *updated_alignment, ucnt = 1;
239 ua % alignment != 0;
240 ua += *updated_alignment)
241 ++ucnt;
242
243 cnt = ua / alignment;
244
a6fa6420
CB		 245 if (offset < 0)
246 /* De-negatize offset, since % wouldn't do the expected thing. */
247 offset = ua - ((- offset) % ua);
248
249 /* Set to largest value. */
250 min_pad = ~(ffetargetAlign) 0;
5ff904cd
JL		 251
252 /* Find all combinations of modulo values the two alignment requirements
253 have; pick the combination that results in the smallest padding
254 requirement. Of course, if a zero-pad requirement is encountered, just
255 use that one. */
256
257 for (um = *updated_modulo, i = 0; i < ucnt; um += *updated_alignment, ++i)
258 {
259 for (m = modulo, j = 0; j < cnt; m += alignment, ++j)
260 {
a6fa6420
CB		 261 /* This code is similar to the "easy case" code above. */
262 if (m > um)
5ff904cd
JL		 263 pad = ua - (m - um);
264 else
265 pad = um - m;
266 pad = (offset + pad) % ua;
a6fa6420
CB		 267 if (pad == 0)
268 {
269 /* A zero pad means we've got something useful. */
5ff904cd
JL		 270 *updated_alignment = ua;
271 *updated_modulo = um;
272 return 0;
273 }
a6fa6420 274 pad = ua - pad;
5ff904cd
JL		 275 if (pad < min_pad)
276 { /* New minimum padding value. */
277 min_pad = pad;
278 min_m = um;
279 }
280 }
281 }
282
283 *updated_alignment = ua;
284 *updated_modulo = min_m;
285 return min_pad;
286}
287
86fc7a6c
CB		 288/* Always append a null byte to the end, in case this is wanted in
289 a special case such as passing a string as a FORMAT or %REF.
290 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
291 because it isn't a "feature" that is self-documenting. Use the
292 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
293 in the code. */
294
5ff904cd
JL		 295#if FFETARGET_okCHARACTER1
296bool
297ffetarget_character1 (ffetargetCharacter1 *val, ffelexToken character,
298 mallocPool pool)
299{
300 val->length = ffelex_token_length (character);
301 if (val->length == 0)
302 val->text = NULL;
303 else
304 {
86fc7a6c 305 val->text = malloc_new_kp (pool, "ffetargetCharacter1", val->length + 1);
5ff904cd 306 memcpy (val->text, ffelex_token_text (character), val->length);
86fc7a6c 307 val->text[val->length] = '\0';
5ff904cd
JL		 308 }
309
310 return TRUE;
311}
312
313#endif
314/* Produce orderable comparison between two constants
315
316 Compare lengths, if equal then use memcmp. */
317
318#if FFETARGET_okCHARACTER1
319int
320ffetarget_cmp_character1 (ffetargetCharacter1 l, ffetargetCharacter1 r)
321{
322 if (l.length < r.length)
323 return -1;
324 if (l.length > r.length)
325 return 1;
326 if (l.length == 0)
327 return 0;
328 return memcmp (l.text, r.text, l.length);
329}
330
331#endif
332/* ffetarget_concatenate_character1 -- Perform CONCAT op on two constants
333
86fc7a6c
CB		 334 Always append a null byte to the end, in case this is wanted in
335 a special case such as passing a string as a FORMAT or %REF.
336 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
337 because it isn't a "feature" that is self-documenting. Use the
338 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
339 in the code. */
5ff904cd
JL		 340
341#if FFETARGET_okCHARACTER1
342ffebad
343ffetarget_concatenate_character1 (ffetargetCharacter1 *res,
344 ffetargetCharacter1 l, ffetargetCharacter1 r, mallocPool pool,
345 ffetargetCharacterSize *len)
346{
347 res->length = *len = l.length + r.length;
348 if (*len == 0)
349 res->text = NULL;
350 else
351 {
86fc7a6c 352 res->text = malloc_new_kp (pool, "ffetargetCharacter1(CONCAT)", *len + 1);
5ff904cd
JL		 353 if (l.length != 0)
354 memcpy (res->text, l.text, l.length);
355 if (r.length != 0)
356 memcpy (res->text + l.length, r.text, r.length);
86fc7a6c 357 res->text[*len] = '\0';
5ff904cd
JL		 358 }
359
360 return FFEBAD;
361}
362
363#endif
364/* ffetarget_eq_character1 -- Perform relational comparison on char constants
365
366 Compare lengths, if equal then use memcmp. */
367
368#if FFETARGET_okCHARACTER1
369ffebad
370ffetarget_eq_character1 (bool *res, ffetargetCharacter1 l,
371 ffetargetCharacter1 r)
372{
373 assert (l.length == r.length);
374 *res = (memcmp (l.text, r.text, l.length) == 0);
375 return FFEBAD;
376}
377
378#endif
379/* ffetarget_le_character1 -- Perform relational comparison on char constants
380
381 Compare lengths, if equal then use memcmp. */
382
383#if FFETARGET_okCHARACTER1
384ffebad
385ffetarget_le_character1 (bool *res, ffetargetCharacter1 l,
386 ffetargetCharacter1 r)
387{
388 assert (l.length == r.length);
389 *res = (memcmp (l.text, r.text, l.length) <= 0);
390 return FFEBAD;
391}
392
393#endif
394/* ffetarget_lt_character1 -- Perform relational comparison on char constants
395
396 Compare lengths, if equal then use memcmp. */
397
398#if FFETARGET_okCHARACTER1
399ffebad
400ffetarget_lt_character1 (bool *res, ffetargetCharacter1 l,
401 ffetargetCharacter1 r)
402{
403 assert (l.length == r.length);
404 *res = (memcmp (l.text, r.text, l.length) < 0);
405 return FFEBAD;
406}
407
408#endif
409/* ffetarget_ge_character1 -- Perform relational comparison on char constants
410
411 Compare lengths, if equal then use memcmp. */
412
413#if FFETARGET_okCHARACTER1
414ffebad
415ffetarget_ge_character1 (bool *res, ffetargetCharacter1 l,
416 ffetargetCharacter1 r)
417{
418 assert (l.length == r.length);
419 *res = (memcmp (l.text, r.text, l.length) >= 0);
420 return FFEBAD;
421}
422
423#endif
424/* ffetarget_gt_character1 -- Perform relational comparison on char constants
425
426 Compare lengths, if equal then use memcmp. */
427
428#if FFETARGET_okCHARACTER1
429ffebad
430ffetarget_gt_character1 (bool *res, ffetargetCharacter1 l,
431 ffetargetCharacter1 r)
432{
433 assert (l.length == r.length);
434 *res = (memcmp (l.text, r.text, l.length) > 0);
435 return FFEBAD;
436}
437#endif
438
439#if FFETARGET_okCHARACTER1
440bool
441ffetarget_iszero_character1 (ffetargetCharacter1 constant)
442{
443 ffetargetCharacterSize i;
444
445 for (i = 0; i < constant.length; ++i)
446 if (constant.text[i] != 0)
447 return FALSE;
448 return TRUE;
449}
450#endif
451
452bool
453ffetarget_iszero_hollerith (ffetargetHollerith constant)
454{
455 ffetargetHollerithSize i;
456
457 for (i = 0; i < constant.length; ++i)
458 if (constant.text[i] != 0)
459 return FALSE;
460 return TRUE;
461}
462
463/* ffetarget_layout -- Do storage requirement analysis for entity
464
465 Return the alignment/modulo requirements along with the size, given the
466 data type info and the number of elements an array (1 for a scalar). */
467
468void
469ffetarget_layout (char *error_text UNUSED, ffetargetAlign *alignment,
470 ffetargetAlign *modulo, ffetargetOffset *size,
471 ffeinfoBasictype bt, ffeinfoKindtype kt,
472 ffetargetCharacterSize charsize,
473 ffetargetIntegerDefault num_elements)
474{
475 bool ok; /* For character type. */
476 ffetargetOffset numele; /* Converted from num_elements. */
477 ffetype type;
478
479 type = ffeinfo_type (bt, kt);
480 assert (type != NULL);
481
482 *alignment = ffetype_alignment (type);
483 *modulo = ffetype_modulo (type);
484 if (bt == FFEINFO_basictypeCHARACTER)
485 {
486 ok = ffetarget_offset_charsize (size, charsize, ffetype_size (type));
487#ifdef ffetarget_offset_overflow
488 if (!ok)
489 ffetarget_offset_overflow (error_text);
490#endif
491 }
492 else
493 *size = ffetype_size (type);
494
495 if ((num_elements < 0)
496 || !ffetarget_offset (&numele, num_elements)
497 || !ffetarget_offset_multiply (size, *size, numele))
498 {
499 ffetarget_offset_overflow (error_text);
500 *alignment = 1;
501 *modulo = 0;
502 *size = 0;
503 }
504}
505
506/* ffetarget_ne_character1 -- Perform relational comparison on char constants
507
508 Compare lengths, if equal then use memcmp. */
509
510#if FFETARGET_okCHARACTER1
511ffebad
512ffetarget_ne_character1 (bool *res, ffetargetCharacter1 l,
513 ffetargetCharacter1 r)
514{
515 assert (l.length == r.length);
516 *res = (memcmp (l.text, r.text, l.length) != 0);
517 return FFEBAD;
518}
519
520#endif
521/* ffetarget_substr_character1 -- Perform SUBSTR op on three constants
522
86fc7a6c
CB		 523 Always append a null byte to the end, in case this is wanted in
524 a special case such as passing a string as a FORMAT or %REF.
525 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
526 because it isn't a "feature" that is self-documenting. Use the
527 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
528 in the code. */
5ff904cd
JL		 529
530#if FFETARGET_okCHARACTER1
531ffebad
532ffetarget_substr_character1 (ffetargetCharacter1 *res,
533 ffetargetCharacter1 l,
534 ffetargetCharacterSize first,
535 ffetargetCharacterSize last, mallocPool pool,
536 ffetargetCharacterSize *len)
537{
538 if (last < first)
539 {
540 res->length = *len = 0;
541 res->text = NULL;
542 }
543 else
544 {
545 res->length = *len = last - first + 1;
86fc7a6c 546 res->text = malloc_new_kp (pool, "ffetargetCharacter1(SUBSTR)", *len + 1);
5ff904cd 547 memcpy (res->text, l.text + first - 1, *len);
86fc7a6c 548 res->text[*len] = '\0';
5ff904cd
JL		 549 }
550
551 return FFEBAD;
552}
553
554#endif
555/* ffetarget_cmp_hollerith -- Produce orderable comparison between two
556 constants
557
558 Compare lengths, if equal then use memcmp. */
559
560int
561ffetarget_cmp_hollerith (ffetargetHollerith l, ffetargetHollerith r)
562{
563 if (l.length < r.length)
564 return -1;
565 if (l.length > r.length)
566 return 1;
567 return memcmp (l.text, r.text, l.length);
568}
569
570ffebad
571ffetarget_convert_any_character1_ (char *res, size_t size,
572 ffetargetCharacter1 l)
573{
574 if (size <= (size_t) l.length)
575 {
576 char *p;
577 ffetargetCharacterSize i;
578
579 memcpy (res, l.text, size);
580 for (p = &l.text[0] + size, i = l.length - size;
581 i > 0;
582 ++p, --i)
583 if (*p != ' ')
584 return FFEBAD_TRUNCATING_CHARACTER;
585 }
586 else
587 {
588 memcpy (res, l.text, size);
589 memset (res + l.length, ' ', size - l.length);
590 }
591
592 return FFEBAD;
593}
594
595ffebad
596ffetarget_convert_any_hollerith_ (char *res, size_t size,
597 ffetargetHollerith l)
598{
599 if (size <= (size_t) l.length)
600 {
601 char *p;
602 ffetargetCharacterSize i;
603
604 memcpy (res, l.text, size);
605 for (p = &l.text[0] + size, i = l.length - size;
606 i > 0;
607 ++p, --i)
608 if (*p != ' ')
609 return FFEBAD_TRUNCATING_HOLLERITH;
610 }
611 else
612 {
613 memcpy (res, l.text, size);
614 memset (res + l.length, ' ', size - l.length);
615 }
616
617 return FFEBAD;
618}
619
620ffebad
621ffetarget_convert_any_typeless_ (char *res, size_t size,
622 ffetargetTypeless l)
623{
624 unsigned long long int l1;
625 unsigned long int l2;
626 unsigned int l3;
627 unsigned short int l4;
628 unsigned char l5;
629 size_t size_of;
630 char *p;
631
632 if (size >= sizeof (l1))
633 {
634 l1 = l;
635 p = (char *) &l1;
636 size_of = sizeof (l1);
637 }
638 else if (size >= sizeof (l2))
639 {
640 l2 = l;
641 p = (char *) &l2;
642 size_of = sizeof (l2);
643 l1 = l2;
644 }
645 else if (size >= sizeof (l3))
646 {
647 l3 = l;
648 p = (char *) &l3;
649 size_of = sizeof (l3);
650 l1 = l3;
651 }
652 else if (size >= sizeof (l4))
653 {
654 l4 = l;
655 p = (char *) &l4;
656 size_of = sizeof (l4);
657 l1 = l4;
658 }
659 else if (size >= sizeof (l5))
660 {
661 l5 = l;
662 p = (char *) &l5;
663 size_of = sizeof (l5);
664 l1 = l5;
665 }
666 else
667 {
668 assert ("stumped by conversion from typeless!" == NULL);
669 abort ();
670 }
671
672 if (size <= size_of)
673 {
674 int i = size_of - size;
675
676 memcpy (res, p + i, size);
677 for (; i > 0; ++p, --i)
678 if (*p != '\0')
679 return FFEBAD_TRUNCATING_TYPELESS;
680 }
681 else
682 {
683 int i = size - size_of;
684
685 memset (res, 0, i);
686 memcpy (res + i, p, size_of);
687 }
688
689 if (l1 != l)
690 return FFEBAD_TRUNCATING_TYPELESS;
691 return FFEBAD;
692}
693
86fc7a6c
CB		 694/* Always append a null byte to the end, in case this is wanted in
695 a special case such as passing a string as a FORMAT or %REF.
696 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
697 because it isn't a "feature" that is self-documenting. Use the
698 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
699 in the code. */
700
5ff904cd
JL		 701#if FFETARGET_okCHARACTER1
702ffebad
703ffetarget_convert_character1_character1 (ffetargetCharacter1 *res,
704 ffetargetCharacterSize size,
705 ffetargetCharacter1 l,
706 mallocPool pool)
707{
708 res->length = size;
709 if (size == 0)
710 res->text = NULL;
711 else
712 {
86fc7a6c 713 res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1);
5ff904cd
JL		 714 if (size <= l.length)
715 memcpy (res->text, l.text, size);
716 else
717 {
718 memcpy (res->text, l.text, l.length);
719 memset (res->text + l.length, ' ', size - l.length);
720 }
86fc7a6c 721 res->text[size] = '\0';
5ff904cd
JL		 722 }
723
724 return FFEBAD;
725}
726
727#endif
86fc7a6c
CB		 728
729/* Always append a null byte to the end, in case this is wanted in
730 a special case such as passing a string as a FORMAT or %REF.
731 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
732 because it isn't a "feature" that is self-documenting. Use the
733 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
734 in the code. */
735
5ff904cd
JL		 736#if FFETARGET_okCHARACTER1
737ffebad
738ffetarget_convert_character1_hollerith (ffetargetCharacter1 *res,
739 ffetargetCharacterSize size,
740 ffetargetHollerith l, mallocPool pool)
741{
742 res->length = size;
743 if (size == 0)
744 res->text = NULL;
745 else
746 {
86fc7a6c
CB		 747 res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1);
748 res->text[size] = '\0';
5ff904cd
JL		 749 if (size <= l.length)
750 {
751 char *p;
752 ffetargetCharacterSize i;
753
754 memcpy (res->text, l.text, size);
755 for (p = &l.text[0] + size, i = l.length - size;
756 i > 0;
757 ++p, --i)
758 if (*p != ' ')
759 return FFEBAD_TRUNCATING_HOLLERITH;
760 }
761 else
762 {
763 memcpy (res->text, l.text, l.length);
764 memset (res->text + l.length, ' ', size - l.length);
765 }
766 }
767
768 return FFEBAD;
769}
770
771#endif
86fc7a6c
CB		 772/* ffetarget_convert_character1_integer4 -- Raw conversion.
773
774 Always append a null byte to the end, in case this is wanted in
775 a special case such as passing a string as a FORMAT or %REF.
776 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
777 because it isn't a "feature" that is self-documenting. Use the
778 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
779 in the code. */
5ff904cd
JL		 780
781#if FFETARGET_okCHARACTER1
782ffebad
783ffetarget_convert_character1_integer4 (ffetargetCharacter1 *res,
784 ffetargetCharacterSize size,
785 ffetargetInteger4 l, mallocPool pool)
786{
787 long long int l1;
788 long int l2;
789 int l3;
790 short int l4;
791 char l5;
792 size_t size_of;
793 char *p;
794
795 if (((size_t) size) >= sizeof (l1))
796 {
797 l1 = l;
798 p = (char *) &l1;
799 size_of = sizeof (l1);
800 }
801 else if (((size_t) size) >= sizeof (l2))
802 {
803 l2 = l;
804 p = (char *) &l2;
805 size_of = sizeof (l2);
806 l1 = l2;
807 }
808 else if (((size_t) size) >= sizeof (l3))
809 {
810 l3 = l;
811 p = (char *) &l3;
812 size_of = sizeof (l3);
813 l1 = l3;
814 }
815 else if (((size_t) size) >= sizeof (l4))
816 {
817 l4 = l;
818 p = (char *) &l4;
819 size_of = sizeof (l4);
820 l1 = l4;
821 }
822 else if (((size_t) size) >= sizeof (l5))
823 {
824 l5 = l;
825 p = (char *) &l5;
826 size_of = sizeof (l5);
827 l1 = l5;
828 }
829 else
830 {
831 assert ("stumped by conversion from integer1!" == NULL);
832 abort ();
833 }
834
835 res->length = size;
836 if (size == 0)
837 res->text = NULL;
838 else
839 {
86fc7a6c
CB		 840 res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1);
841 res->text[size] = '\0';
5ff904cd
JL		 842 if (((size_t) size) <= size_of)
843 {
844 int i = size_of - size;
845
846 memcpy (res->text, p + i, size);
847 for (; i > 0; ++p, --i)
848 if (*p != 0)
849 return FFEBAD_TRUNCATING_NUMERIC;
850 }
851 else
852 {
853 int i = size - size_of;
854
855 memset (res->text, 0, i);
856 memcpy (res->text + i, p, size_of);
857 }
858 }
859
860 if (l1 != l)
861 return FFEBAD_TRUNCATING_NUMERIC;
862 return FFEBAD;
863}
864
865#endif
86fc7a6c
CB		 866/* ffetarget_convert_character1_logical4 -- Raw conversion.
867
868 Always append a null byte to the end, in case this is wanted in
869 a special case such as passing a string as a FORMAT or %REF.
870 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
871 because it isn't a "feature" that is self-documenting. Use the
872 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
873 in the code. */
5ff904cd
JL		 874
875#if FFETARGET_okCHARACTER1
876ffebad
877ffetarget_convert_character1_logical4 (ffetargetCharacter1 *res,
878 ffetargetCharacterSize size,
879 ffetargetLogical4 l, mallocPool pool)
880{
881 long long int l1;
882 long int l2;
883 int l3;
884 short int l4;
885 char l5;
886 size_t size_of;
887 char *p;
888
889 if (((size_t) size) >= sizeof (l1))
890 {
891 l1 = l;
892 p = (char *) &l1;
893 size_of = sizeof (l1);
894 }
895 else if (((size_t) size) >= sizeof (l2))
896 {
897 l2 = l;
898 p = (char *) &l2;
899 size_of = sizeof (l2);
900 l1 = l2;
901 }
902 else if (((size_t) size) >= sizeof (l3))
903 {
904 l3 = l;
905 p = (char *) &l3;
906 size_of = sizeof (l3);
907 l1 = l3;
908 }
909 else if (((size_t) size) >= sizeof (l4))
910 {
911 l4 = l;
912 p = (char *) &l4;
913 size_of = sizeof (l4);
914 l1 = l4;
915 }
916 else if (((size_t) size) >= sizeof (l5))
917 {
918 l5 = l;
919 p = (char *) &l5;
920 size_of = sizeof (l5);
921 l1 = l5;
922 }
923 else
924 {
925 assert ("stumped by conversion from logical1!" == NULL);
926 abort ();
927 }
928
929 res->length = size;
930 if (size == 0)
931 res->text = NULL;
932 else
933 {
86fc7a6c
CB		 934 res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1);
935 res->text[size] = '\0';
5ff904cd
JL		 936 if (((size_t) size) <= size_of)
937 {
938 int i = size_of - size;
939
940 memcpy (res->text, p + i, size);
941 for (; i > 0; ++p, --i)
942 if (*p != 0)
943 return FFEBAD_TRUNCATING_NUMERIC;
944 }
945 else
946 {
947 int i = size - size_of;
948
949 memset (res->text, 0, i);
950 memcpy (res->text + i, p, size_of);
951 }
952 }
953
954 if (l1 != l)
955 return FFEBAD_TRUNCATING_NUMERIC;
956 return FFEBAD;
957}
958
959#endif
86fc7a6c
CB		 960/* ffetarget_convert_character1_typeless -- Raw conversion.
961
962 Always append a null byte to the end, in case this is wanted in
963 a special case such as passing a string as a FORMAT or %REF.
964 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
965 because it isn't a "feature" that is self-documenting. Use the
966 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
967 in the code. */
5ff904cd
JL		 968
969#if FFETARGET_okCHARACTER1
970ffebad
971ffetarget_convert_character1_typeless (ffetargetCharacter1 *res,
972 ffetargetCharacterSize size,
973 ffetargetTypeless l, mallocPool pool)
974{
975 unsigned long long int l1;
976 unsigned long int l2;
977 unsigned int l3;
978 unsigned short int l4;
979 unsigned char l5;
980 size_t size_of;
981 char *p;
982
983 if (((size_t) size) >= sizeof (l1))
984 {
985 l1 = l;
986 p = (char *) &l1;
987 size_of = sizeof (l1);
988 }
989 else if (((size_t) size) >= sizeof (l2))
990 {
991 l2 = l;
992 p = (char *) &l2;
993 size_of = sizeof (l2);
994 l1 = l2;
995 }
996 else if (((size_t) size) >= sizeof (l3))
997 {
998 l3 = l;
999 p = (char *) &l3;
1000 size_of = sizeof (l3);
1001 l1 = l3;
1002 }
1003 else if (((size_t) size) >= sizeof (l4))
1004 {
1005 l4 = l;
1006 p = (char *) &l4;
1007 size_of = sizeof (l4);
1008 l1 = l4;
1009 }
1010 else if (((size_t) size) >= sizeof (l5))
1011 {
1012 l5 = l;
1013 p = (char *) &l5;
1014 size_of = sizeof (l5);
1015 l1 = l5;
1016 }
1017 else
1018 {
1019 assert ("stumped by conversion from typeless!" == NULL);
1020 abort ();
1021 }
1022
1023 res->length = size;
1024 if (size == 0)
1025 res->text = NULL;
1026 else
1027 {
86fc7a6c
CB		 1028 res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1);
1029 res->text[size] = '\0';
5ff904cd
JL		 1030 if (((size_t) size) <= size_of)
1031 {
1032 int i = size_of - size;
1033
1034 memcpy (res->text, p + i, size);
1035 for (; i > 0; ++p, --i)
1036 if (*p != 0)
1037 return FFEBAD_TRUNCATING_TYPELESS;
1038 }
1039 else
1040 {
1041 int i = size - size_of;
1042
1043 memset (res->text, 0, i);
1044 memcpy (res->text + i, p, size_of);
1045 }
1046 }
1047
1048 if (l1 != l)
1049 return FFEBAD_TRUNCATING_TYPELESS;
1050 return FFEBAD;
1051}
1052
1053#endif
1054/* ffetarget_divide_complex1 -- Divide function
1055
1056 See prototype. */
1057
1058#if FFETARGET_okCOMPLEX1
1059ffebad
1060ffetarget_divide_complex1 (ffetargetComplex1 *res, ffetargetComplex1 l,
1061 ffetargetComplex1 r)
1062{
1063 ffebad bad;
1064 ffetargetReal1 tmp1, tmp2, tmp3, tmp4;
1065
1066 bad = ffetarget_multiply_real1 (&tmp1, r.real, r.real);
1067 if (bad != FFEBAD)
1068 return bad;
1069 bad = ffetarget_multiply_real1 (&tmp2, r.imaginary, r.imaginary);
1070 if (bad != FFEBAD)
1071 return bad;
1072 bad = ffetarget_add_real1 (&tmp3, tmp1, tmp2);
1073 if (bad != FFEBAD)
1074 return bad;
1075
1076 if (ffetarget_iszero_real1 (tmp3))
1077 {
1078 ffetarget_real1_zero (&(res)->real);
1079 ffetarget_real1_zero (&(res)->imaginary);
1080 return FFEBAD_DIV_BY_ZERO;
1081 }
1082
1083 bad = ffetarget_multiply_real1 (&tmp1, l.real, r.real);
1084 if (bad != FFEBAD)
1085 return bad;
1086 bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, r.imaginary);
1087 if (bad != FFEBAD)
1088 return bad;
1089 bad = ffetarget_add_real1 (&tmp4, tmp1, tmp2);
1090 if (bad != FFEBAD)
1091 return bad;
1092 bad = ffetarget_divide_real1 (&res->real, tmp4, tmp3);
1093 if (bad != FFEBAD)
1094 return bad;
1095
1096 bad = ffetarget_multiply_real1 (&tmp1, r.real, l.imaginary);
1097 if (bad != FFEBAD)
1098 return bad;
1099 bad = ffetarget_multiply_real1 (&tmp2, l.real, r.imaginary);
1100 if (bad != FFEBAD)
1101 return bad;
1102 bad = ffetarget_subtract_real1 (&tmp4, tmp1, tmp2);
1103 if (bad != FFEBAD)
1104 return bad;
1105 bad = ffetarget_divide_real1 (&res->imaginary, tmp4, tmp3);
1106
1107 return FFEBAD;
1108}
1109
1110#endif
1111/* ffetarget_divide_complex2 -- Divide function
1112
1113 See prototype. */
1114
1115#if FFETARGET_okCOMPLEX2
1116ffebad
1117ffetarget_divide_complex2 (ffetargetComplex2 *res, ffetargetComplex2 l,
1118 ffetargetComplex2 r)
1119{
1120 ffebad bad;
1121 ffetargetReal2 tmp1, tmp2, tmp3, tmp4;
1122
1123 bad = ffetarget_multiply_real2 (&tmp1, r.real, r.real);
1124 if (bad != FFEBAD)
1125 return bad;
1126 bad = ffetarget_multiply_real2 (&tmp2, r.imaginary, r.imaginary);
1127 if (bad != FFEBAD)
1128 return bad;
1129 bad = ffetarget_add_real2 (&tmp3, tmp1, tmp2);
1130 if (bad != FFEBAD)
1131 return bad;
1132
1133 if (ffetarget_iszero_real2 (tmp3))
1134 {
1135 ffetarget_real2_zero (&(res)->real);
1136 ffetarget_real2_zero (&(res)->imaginary);
1137 return FFEBAD_DIV_BY_ZERO;
1138 }
1139
1140 bad = ffetarget_multiply_real2 (&tmp1, l.real, r.real);
1141 if (bad != FFEBAD)
1142 return bad;
1143 bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, r.imaginary);
1144 if (bad != FFEBAD)
1145 return bad;
1146 bad = ffetarget_add_real2 (&tmp4, tmp1, tmp2);
1147 if (bad != FFEBAD)
1148 return bad;
1149 bad = ffetarget_divide_real2 (&res->real, tmp4, tmp3);
1150 if (bad != FFEBAD)
1151 return bad;
1152
1153 bad = ffetarget_multiply_real2 (&tmp1, r.real, l.imaginary);
1154 if (bad != FFEBAD)
1155 return bad;
1156 bad = ffetarget_multiply_real2 (&tmp2, l.real, r.imaginary);
1157 if (bad != FFEBAD)
1158 return bad;
1159 bad = ffetarget_subtract_real2 (&tmp4, tmp1, tmp2);
1160 if (bad != FFEBAD)
1161 return bad;
1162 bad = ffetarget_divide_real2 (&res->imaginary, tmp4, tmp3);
1163
1164 return FFEBAD;
1165}
1166
1167#endif
1168/* ffetarget_hollerith -- Convert token to a hollerith constant
1169
86fc7a6c
CB		 1170 Always append a null byte to the end, in case this is wanted in
1171 a special case such as passing a string as a FORMAT or %REF.
1172 Done to save a bit of hassle, nothing more, but it's a kludge anyway,
1173 because it isn't a "feature" that is self-documenting. Use the
1174 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
1175 in the code. */
5ff904cd
JL		 1176
1177bool
1178ffetarget_hollerith (ffetargetHollerith *val, ffelexToken integer,
1179 mallocPool pool)
1180{
1181 val->length = ffelex_token_length (integer);
86fc7a6c 1182 val->text = malloc_new_kp (pool, "ffetargetHollerith", val->length + 1);
5ff904cd 1183 memcpy (val->text, ffelex_token_text (integer), val->length);
86fc7a6c 1184 val->text[val->length] = '\0';
5ff904cd
JL		 1185
1186 return TRUE;
1187}
1188
1189/* ffetarget_integer_bad_magical -- Complain about a magical number
1190
1191 Just calls ffebad with the arguments. */
1192
1193void
1194ffetarget_integer_bad_magical (ffelexToken t)
1195{
1196 ffebad_start (FFEBAD_BAD_MAGICAL);
1197 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1198 ffebad_finish ();
1199}
1200
1201/* ffetarget_integer_bad_magical_binary -- Complain about a magical number
1202
1203 Just calls ffebad with the arguments. */
1204
1205void
1206ffetarget_integer_bad_magical_binary (ffelexToken integer,
1207 ffelexToken minus)
1208{
1209 ffebad_start (FFEBAD_BAD_MAGICAL_BINARY);
1210 ffebad_here (0, ffelex_token_where_line (integer),
1211 ffelex_token_where_column (integer));
1212 ffebad_here (1, ffelex_token_where_line (minus),
1213 ffelex_token_where_column (minus));
1214 ffebad_finish ();
1215}
1216
1217/* ffetarget_integer_bad_magical_precedence -- Complain about a magical
1218 number
1219
1220 Just calls ffebad with the arguments. */
1221
1222void
1223ffetarget_integer_bad_magical_precedence (ffelexToken integer,
1224 ffelexToken uminus,
1225 ffelexToken higher_op)
1226{
1227 ffebad_start (FFEBAD_BAD_MAGICAL_PRECEDENCE);
1228 ffebad_here (0, ffelex_token_where_line (integer),
1229 ffelex_token_where_column (integer));
1230 ffebad_here (1, ffelex_token_where_line (uminus),
1231 ffelex_token_where_column (uminus));
1232 ffebad_here (2, ffelex_token_where_line (higher_op),
1233 ffelex_token_where_column (higher_op));
1234 ffebad_finish ();
1235}
1236
1237/* ffetarget_integer_bad_magical_precedence_binary -- Complain...
1238
1239 Just calls ffebad with the arguments. */
1240
1241void
1242ffetarget_integer_bad_magical_precedence_binary (ffelexToken integer,
1243 ffelexToken minus,
1244 ffelexToken higher_op)
1245{
1246 ffebad_start (FFEBAD_BAD_MAGICAL_PRECEDENCE_BINARY);
1247 ffebad_here (0, ffelex_token_where_line (integer),
1248 ffelex_token_where_column (integer));
1249 ffebad_here (1, ffelex_token_where_line (minus),
1250 ffelex_token_where_column (minus));
1251 ffebad_here (2, ffelex_token_where_line (higher_op),
1252 ffelex_token_where_column (higher_op));
1253 ffebad_finish ();
1254}
1255
1256/* ffetarget_integer1 -- Convert token to an integer
1257
1258 See prototype.
1259
1260 Token use count not affected overall. */
1261
1262#if FFETARGET_okINTEGER1
1263bool
1264ffetarget_integer1 (ffetargetInteger1 *val, ffelexToken integer)
1265{
1266 ffetargetInteger1 x;
1267 char *p;
1268 char c;
1269
1270 assert (ffelex_token_type (integer) == FFELEX_typeNUMBER);
1271
1272 p = ffelex_token_text (integer);
1273 x = 0;
1274
1275 /* Skip past leading zeros. */
1276
1277 while (((c = *p) != '\0') && (c == '0'))
1278 ++p;
1279
1280 /* Interpret rest of number. */
1281
1282 while (c != '\0')
1283 {
1284 if ((x == FFETARGET_integerALMOST_BIG_MAGICAL)
1285 && (c == '0' + FFETARGET_integerFINISH_BIG_MAGICAL)
1286 && (*(p + 1) == '\0'))
1287 {
1288 *val = (ffetargetInteger1) FFETARGET_integerBIG_MAGICAL;
1289 return TRUE;
1290 }
1291 else if (x == FFETARGET_integerALMOST_BIG_MAGICAL)
1292 {
1293 if ((c > '0' + FFETARGET_integerFINISH_BIG_MAGICAL)
1294 || (*(p + 1) != '\0'))
1295 {
1296 ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1297 ffebad_here (0, ffelex_token_where_line (integer),
1298 ffelex_token_where_column (integer));
1299 ffebad_finish ();
1300 *val = 0;
1301 return FALSE;
1302 }
1303 }
1304 else if (x > FFETARGET_integerALMOST_BIG_MAGICAL)
1305 {
1306 ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1307 ffebad_here (0, ffelex_token_where_line (integer),
1308 ffelex_token_where_column (integer));
1309 ffebad_finish ();
1310 *val = 0;
1311 return FALSE;
1312 }
1313 x = x * 10 + c - '0';
1314 c = *(++p);
1315 };
1316
1317 *val = x;
1318 return TRUE;
1319}
1320
1321#endif
1322/* ffetarget_integerbinary -- Convert token to a binary integer
1323
1324 ffetarget_integerbinary x;
1325 if (ffetarget_integerdefault_8(&x,integer_token))
1326 // conversion ok.
1327
1328 Token use count not affected overall. */
1329
1330bool
1331ffetarget_integerbinary (ffetargetIntegerDefault *val, ffelexToken integer)
1332{
1333 ffetargetIntegerDefault x;
1334 char *p;
1335 char c;
1336 bool bad_digit;
1337
1338 assert ((ffelex_token_type (integer) == FFELEX_typeNAME)
1339 || (ffelex_token_type (integer) == FFELEX_typeNUMBER));
1340
1341 p = ffelex_token_text (integer);
1342 x = 0;
1343
1344 /* Skip past leading zeros. */
1345
1346 while (((c = *p) != '\0') && (c == '0'))
1347 ++p;
1348
1349 /* Interpret rest of number. */
1350
1351 bad_digit = FALSE;
1352 while (c != '\0')
1353 {
1354 if ((c >= '0') && (c <= '1'))
1355 c -= '0';
1356 else
1357 {
1358 bad_digit = TRUE;
1359 c = 0;
1360 }
1361
1362#if 0 /* Don't complain about signed overflow; just
1363 unsigned overflow. */
1364 if ((x == FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY)
1365 && (c == FFETARGET_integerFINISH_BIG_OVERFLOW_BINARY)
1366 && (*(p + 1) == '\0'))
1367 {
1368 *val = FFETARGET_integerBIG_OVERFLOW_BINARY;
1369 return TRUE;
1370 }
1371 else
1372#endif
1373#if FFETARGET_integerFINISH_BIG_OVERFLOW_BINARY == 0
1374 if ((x & FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY) != 0)
1375#else
1376 if (x == FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY)
1377 {
1378 if ((c > FFETARGET_integerFINISH_BIG_OVERFLOW_BINARY)
1379 || (*(p + 1) != '\0'))
1380 {
1381 ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1382 ffebad_here (0, ffelex_token_where_line (integer),
1383 ffelex_token_where_column (integer));
1384 ffebad_finish ();
1385 *val = 0;
1386 return FALSE;
1387 }
1388 }
1389 else if (x > FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY)
1390#endif
1391 {
1392 ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1393 ffebad_here (0, ffelex_token_where_line (integer),
1394 ffelex_token_where_column (integer));
1395 ffebad_finish ();
1396 *val = 0;
1397 return FALSE;
1398 }
1399 x = (x << 1) + c;
1400 c = *(++p);
1401 };
1402
1403 if (bad_digit)
1404 {
1405 ffebad_start (FFEBAD_INVALID_BINARY_DIGIT);
1406 ffebad_here (0, ffelex_token_where_line (integer),
1407 ffelex_token_where_column (integer));
1408 ffebad_finish ();
1409 }
1410
1411 *val = x;
1412 return !bad_digit;
1413}
1414
1415/* ffetarget_integerhex -- Convert token to a hex integer
1416
1417 ffetarget_integerhex x;
1418 if (ffetarget_integerdefault_8(&x,integer_token))
1419 // conversion ok.
1420
1421 Token use count not affected overall. */
1422
1423bool
1424ffetarget_integerhex (ffetargetIntegerDefault *val, ffelexToken integer)
1425{
1426 ffetargetIntegerDefault x;
1427 char *p;
1428 char c;
1429 bool bad_digit;
1430
1431 assert ((ffelex_token_type (integer) == FFELEX_typeNAME)
1432 || (ffelex_token_type (integer) == FFELEX_typeNUMBER));
1433
1434 p = ffelex_token_text (integer);
1435 x = 0;
1436
1437 /* Skip past leading zeros. */
1438
1439 while (((c = *p) != '\0') && (c == '0'))
1440 ++p;
1441
1442 /* Interpret rest of number. */
1443
1444 bad_digit = FALSE;
1445 while (c != '\0')
1446 {
1447 if ((c >= 'A') && (c <= 'F'))
1448 c = c - 'A' + 10;
1449 else if ((c >= 'a') && (c <= 'f'))
1450 c = c - 'a' + 10;
1451 else if ((c >= '0') && (c <= '9'))
1452 c -= '0';
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
1520bool
1521ffetarget_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
1610ffebad
1611ffetarget_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
1643ffebad
1644ffetarget_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
1675ffebad
1676ffetarget_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
1802ffebad
1803ffetarget_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
1928ffebad
1929ffetarget_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
1981ffebad
1982ffetarget_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
2042ffebad
2043ffetarget_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
2105void
2106ffetarget_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
2130void
2131ffetarget_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
2147void
2148ffetarget_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
2164void
2165ffetarget_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
2189void
2190ffetarget_print_hex (FILE *f, ffetargetTypeless value)
2191{
2192 char *p;
2193 char digits[sizeof (value) * CHAR_BIT / 4 + 1];
2194 static 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
2221bool
2222ffetarget_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)
567f3d36
KG		 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 }
5ff904cd
JL		 2273
2274 dotoktxt (exponent_digits);
2275
2276#undef dotoktxt
2277
2278 *p = '\0';
2279
2280 ffetarget_make_real1 (value,
2281 FFETARGET_ATOF_ (ptr,
2282 SFmode));
2283
2284 if (sz > ARRAY_SIZE (ffetarget_string_))
2285 malloc_kill_ks (malloc_pool_image (), ptr, sz);
2286
2287 return TRUE;
2288}
2289
2290#endif
2291/* ffetarget_real2 -- Convert token to a single-precision real number
2292
2293 See prototype.
2294
2295 Pass NULL for any token not provided by the user, but a valid Fortran
2296 real number must be provided somehow. For example, it is ok for
2297 exponent_sign_token and exponent_digits_token to be NULL as long as
2298 exponent_token not only starts with "E" or "e" but also contains at least
2299 one digit following it. Token use counts not affected overall. */
2300
2301#if FFETARGET_okREAL2
2302bool
2303ffetarget_real2 (ffetargetReal2 *value, ffelexToken integer,
2304 ffelexToken decimal, ffelexToken fraction,
2305 ffelexToken exponent, ffelexToken exponent_sign,
2306 ffelexToken exponent_digits)
2307{
2308 size_t sz = 1; /* Allow room for '\0' byte at end. */
2309 char *ptr = &ffetarget_string_[0];
2310 char *p = ptr;
2311 char *q;
2312
2313#define dotok(x) if (x != NULL) ++sz;
2314#define dotoktxt(x) if (x != NULL) sz += ffelex_token_length(x)
2315
2316 dotoktxt (integer);
2317 dotok (decimal);
2318 dotoktxt (fraction);
2319 dotoktxt (exponent);
2320 dotok (exponent_sign);
2321 dotoktxt (exponent_digits);
2322
2323#undef dotok
2324#undef dotoktxt
2325
2326 if (sz > ARRAY_SIZE (ffetarget_string_))
2327 p = ptr = (char *) malloc_new_ks (malloc_pool_image (), "ffetarget_real1", sz);
2328
2329#define dotoktxt(x) if (x != NULL) \
2330 { \
2331 for (q = ffelex_token_text(x); *q != '\0'; ++q) \
2332 *p++ = *q; \
2333 }
2334#define dotoktxtexp(x) if (x != NULL) \
2335 { \
2336 *p++ = 'E'; \
2337 for (q = ffelex_token_text(x) + 1; *q != '\0'; ++q) \
2338 *p++ = *q; \
2339 }
2340
2341 dotoktxt (integer);
2342
2343 if (decimal != NULL)
2344 *p++ = '.';
2345
2346 dotoktxt (fraction);
2347 dotoktxtexp (exponent);
2348
2349 if (exponent_sign != NULL)
567f3d36
KG		 2350 {
2351 if (ffelex_token_type (exponent_sign) == FFELEX_typePLUS)
2352 *p++ = '+';
2353 else
2354 {
2355 assert (ffelex_token_type (exponent_sign) == FFELEX_typeMINUS);
2356 *p++ = '-';
2357 }
2358 }
5ff904cd
JL		 2359
2360 dotoktxt (exponent_digits);
2361
2362#undef dotoktxt
2363
2364 *p = '\0';
2365
2366 ffetarget_make_real2 (value,
2367 FFETARGET_ATOF_ (ptr,
2368 DFmode));
2369
2370 if (sz > ARRAY_SIZE (ffetarget_string_))
2371 malloc_kill_ks (malloc_pool_image (), ptr, sz);
2372
2373 return TRUE;
2374}
2375
2376#endif
2377bool
2378ffetarget_typeless_binary (ffetargetTypeless *xvalue, ffelexToken token)
2379{
2380 char *p;
2381 char c;
2382 ffetargetTypeless value = 0;
2383 ffetargetTypeless new_value = 0;
2384 bool bad_digit = FALSE;
2385 bool overflow = FALSE;
2386
2387 p = ffelex_token_text (token);
2388
2389 for (c = *p; c != '\0'; c = *++p)
2390 {
2391 new_value <<= 1;
2392 if ((new_value >> 1) != value)
2393 overflow = TRUE;
8b45da67 2394 if (ISDIGIT (c))
5ff904cd
JL		 2395 new_value += c - '0';
2396 else
2397 bad_digit = TRUE;
2398 value = new_value;
2399 }
2400
2401 if (bad_digit)
2402 {
2403 ffebad_start (FFEBAD_INVALID_TYPELESS_BINARY_DIGIT);
2404 ffebad_here (0, ffelex_token_where_line (token),
2405 ffelex_token_where_column (token));
2406 ffebad_finish ();
2407 }
2408 else if (overflow)
2409 {
2410 ffebad_start (FFEBAD_TYPELESS_OVERFLOW);
2411 ffebad_here (0, ffelex_token_where_line (token),
2412 ffelex_token_where_column (token));
2413 ffebad_finish ();
2414 }
2415
2416 *xvalue = value;
2417
2418 return !bad_digit && !overflow;
2419}
2420
2421bool
2422ffetarget_typeless_octal (ffetargetTypeless *xvalue, ffelexToken token)
2423{
2424 char *p;
2425 char c;
2426 ffetargetTypeless value = 0;
2427 ffetargetTypeless new_value = 0;
2428 bool bad_digit = FALSE;
2429 bool overflow = FALSE;
2430
2431 p = ffelex_token_text (token);
2432
2433 for (c = *p; c != '\0'; c = *++p)
2434 {
2435 new_value <<= 3;
2436 if ((new_value >> 3) != value)
2437 overflow = TRUE;
8b45da67 2438 if (ISDIGIT (c))
5ff904cd
JL		 2439 new_value += c - '0';
2440 else
2441 bad_digit = TRUE;
2442 value = new_value;
2443 }
2444
2445 if (bad_digit)
2446 {
2447 ffebad_start (FFEBAD_INVALID_TYPELESS_OCTAL_DIGIT);
2448 ffebad_here (0, ffelex_token_where_line (token),
2449 ffelex_token_where_column (token));
2450 ffebad_finish ();
2451 }
2452 else if (overflow)
2453 {
2454 ffebad_start (FFEBAD_TYPELESS_OVERFLOW);
2455 ffebad_here (0, ffelex_token_where_line (token),
2456 ffelex_token_where_column (token));
2457 ffebad_finish ();
2458 }
2459
2460 *xvalue = value;
2461
2462 return !bad_digit && !overflow;
2463}
2464
2465bool
2466ffetarget_typeless_hex (ffetargetTypeless *xvalue, ffelexToken token)
2467{
2468 char *p;
2469 char c;
2470 ffetargetTypeless value = 0;
2471 ffetargetTypeless new_value = 0;
2472 bool bad_digit = FALSE;
2473 bool overflow = FALSE;
2474
2475 p = ffelex_token_text (token);
2476
2477 for (c = *p; c != '\0'; c = *++p)
2478 {
2479 new_value <<= 4;
2480 if ((new_value >> 4) != value)
2481 overflow = TRUE;
8b45da67 2482 if (ISDIGIT (c))
5ff904cd
JL		 2483 new_value += c - '0';
2484 else if ((c >= 'A') && (c <= 'F'))
2485 new_value += c - 'A' + 10;
2486 else if ((c >= 'a') && (c <= 'f'))
2487 new_value += c - 'a' + 10;
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
2513void
2514ffetarget_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
2524void *
2525ffetarget_memcpy_ (void *dst, void *src, size_t len)
2526{
2527 return (void *) memcpy (dst, src, len);
2528}
2529
2530/* ffetarget_num_digits_ -- Determine number of non-space characters in token
2531
2532 ffetarget_num_digits_(token);
2533
2534 All non-spaces are assumed to be binary, octal, or hex digits. */
2535
2536int
2537ffetarget_num_digits_ (ffelexToken token)
2538{
2539 int i;
2540 char *c;
2541
2542 switch (ffelex_token_type (token))
2543 {
2544 case FFELEX_typeNAME:
2545 case FFELEX_typeNUMBER:
2546 return ffelex_token_length (token);
2547
2548 case FFELEX_typeCHARACTER:
2549 i = 0;
2550 for (c = ffelex_token_text (token); *c != '\0'; ++c)
2551 {
2552 if (*c != ' ')
2553 ++i;
2554 }
2555 return i;
2556
2557 default:
2558 assert ("weird token" == NULL);
2559 return 1;
2560 }
2561}
GNU Compiler Collection
This page took 0.393361 seconds and 5 git commands to generate.