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