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