1afc2ba1dSToomas Soome /*
2afc2ba1dSToomas Soome * f l o a t . c
3afc2ba1dSToomas Soome * Forth Inspired Command Language
4afc2ba1dSToomas Soome * ANS Forth FLOAT word-set written in C
5afc2ba1dSToomas Soome * Author: Guy Carver & John Sadler (john_sadler@alum.mit.edu)
6afc2ba1dSToomas Soome * Created: Apr 2001
7afc2ba1dSToomas Soome * $Id: float.c,v 1.10 2010/09/13 18:43:04 asau Exp $
8afc2ba1dSToomas Soome */
9afc2ba1dSToomas Soome /*
10afc2ba1dSToomas Soome * Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
11afc2ba1dSToomas Soome * All rights reserved.
12afc2ba1dSToomas Soome *
13afc2ba1dSToomas Soome * Get the latest Ficl release at http://ficl.sourceforge.net
14afc2ba1dSToomas Soome *
15afc2ba1dSToomas Soome * I am interested in hearing from anyone who uses Ficl. If you have
16afc2ba1dSToomas Soome * a problem, a success story, a defect, an enhancement request, or
17afc2ba1dSToomas Soome * if you would like to contribute to the Ficl release, please
18afc2ba1dSToomas Soome * contact me by email at the address above.
19afc2ba1dSToomas Soome *
20afc2ba1dSToomas Soome * L I C E N S E and D I S C L A I M E R
21afc2ba1dSToomas Soome *
22afc2ba1dSToomas Soome * Redistribution and use in source and binary forms, with or without
23afc2ba1dSToomas Soome * modification, are permitted provided that the following conditions
24afc2ba1dSToomas Soome * are met:
25afc2ba1dSToomas Soome * 1. Redistributions of source code must retain the above copyright
26afc2ba1dSToomas Soome * notice, this list of conditions and the following disclaimer.
27afc2ba1dSToomas Soome * 2. Redistributions in binary form must reproduce the above copyright
28afc2ba1dSToomas Soome * notice, this list of conditions and the following disclaimer in the
29afc2ba1dSToomas Soome * documentation and/or other materials provided with the distribution.
30afc2ba1dSToomas Soome *
31afc2ba1dSToomas Soome * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
32afc2ba1dSToomas Soome * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
33afc2ba1dSToomas Soome * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
34afc2ba1dSToomas Soome * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
35afc2ba1dSToomas Soome * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
36afc2ba1dSToomas Soome * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
37afc2ba1dSToomas Soome * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
38afc2ba1dSToomas Soome * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
39afc2ba1dSToomas Soome * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
40afc2ba1dSToomas Soome * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
41afc2ba1dSToomas Soome * SUCH DAMAGE.
42afc2ba1dSToomas Soome */
43afc2ba1dSToomas Soome
44afc2ba1dSToomas Soome #include "ficl.h"
45afc2ba1dSToomas Soome
46afc2ba1dSToomas Soome #if FICL_WANT_FLOAT
47afc2ba1dSToomas Soome #include <math.h>
48afc2ba1dSToomas Soome #include <values.h>
49afc2ba1dSToomas Soome
50afc2ba1dSToomas Soome
51afc2ba1dSToomas Soome /*
52afc2ba1dSToomas Soome * Create a floating point constant.
53afc2ba1dSToomas Soome * fconstant ( r -"name"- )
54afc2ba1dSToomas Soome */
55afc2ba1dSToomas Soome static void
ficlPrimitiveFConstant(ficlVm * vm)56afc2ba1dSToomas Soome ficlPrimitiveFConstant(ficlVm *vm)
57afc2ba1dSToomas Soome {
58afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
59afc2ba1dSToomas Soome ficlString name = ficlVmGetWord(vm);
60afc2ba1dSToomas Soome
61afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->floatStack, 1, 0);
62afc2ba1dSToomas Soome
63*c0bb4f73SToomas Soome (void) ficlDictionaryAppendWord(dictionary, name,
64afc2ba1dSToomas Soome (ficlPrimitive)ficlInstructionFConstantParen, FICL_WORD_DEFAULT);
65afc2ba1dSToomas Soome ficlDictionaryAppendCell(dictionary, ficlStackPop(vm->floatStack));
66afc2ba1dSToomas Soome }
67afc2ba1dSToomas Soome
68afc2ba1dSToomas Soome
69afc2ba1dSToomas Soome ficlWord *
ficlDictionaryAppendFConstant(ficlDictionary * dictionary,char * name,ficlFloat value)70afc2ba1dSToomas Soome ficlDictionaryAppendFConstant(ficlDictionary *dictionary, char *name,
71afc2ba1dSToomas Soome ficlFloat value)
72afc2ba1dSToomas Soome {
73afc2ba1dSToomas Soome ficlString s;
74afc2ba1dSToomas Soome FICL_STRING_SET_FROM_CSTRING(s, name);
75afc2ba1dSToomas Soome return (ficlDictionaryAppendConstantInstruction(dictionary, s,
76afc2ba1dSToomas Soome ficlInstructionFConstantParen, *(ficlInteger *)(&value)));
77afc2ba1dSToomas Soome }
78afc2ba1dSToomas Soome
79afc2ba1dSToomas Soome
80afc2ba1dSToomas Soome ficlWord *
ficlDictionarySetFConstant(ficlDictionary * dictionary,char * name,ficlFloat value)81afc2ba1dSToomas Soome ficlDictionarySetFConstant(ficlDictionary *dictionary, char *name,
82afc2ba1dSToomas Soome ficlFloat value)
83afc2ba1dSToomas Soome {
84afc2ba1dSToomas Soome ficlString s;
85afc2ba1dSToomas Soome FICL_STRING_SET_FROM_CSTRING(s, name);
86afc2ba1dSToomas Soome return (ficlDictionarySetConstantInstruction(dictionary, s,
87afc2ba1dSToomas Soome ficlInstructionFConstantParen, *(ficlInteger *)(&value)));
88afc2ba1dSToomas Soome }
89afc2ba1dSToomas Soome
90afc2ba1dSToomas Soome
91afc2ba1dSToomas Soome
92afc2ba1dSToomas Soome
93afc2ba1dSToomas Soome static void
ficlPrimitiveF2Constant(ficlVm * vm)94afc2ba1dSToomas Soome ficlPrimitiveF2Constant(ficlVm *vm)
95afc2ba1dSToomas Soome {
96afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
97afc2ba1dSToomas Soome ficlString name = ficlVmGetWord(vm);
98afc2ba1dSToomas Soome
99afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->floatStack, 2, 0);
100afc2ba1dSToomas Soome
101*c0bb4f73SToomas Soome (void) ficlDictionaryAppendWord(dictionary, name,
102afc2ba1dSToomas Soome (ficlPrimitive)ficlInstructionF2ConstantParen, FICL_WORD_DEFAULT);
103afc2ba1dSToomas Soome ficlDictionaryAppendCell(dictionary, ficlStackPop(vm->floatStack));
104afc2ba1dSToomas Soome ficlDictionaryAppendCell(dictionary, ficlStackPop(vm->floatStack));
105afc2ba1dSToomas Soome }
106afc2ba1dSToomas Soome
107afc2ba1dSToomas Soome ficlWord *
ficlDictionaryAppendF2Constant(ficlDictionary * dictionary,char * name,ficlFloat value)108afc2ba1dSToomas Soome ficlDictionaryAppendF2Constant(ficlDictionary *dictionary, char *name,
109afc2ba1dSToomas Soome ficlFloat value)
110afc2ba1dSToomas Soome {
111afc2ba1dSToomas Soome ficlString s;
112afc2ba1dSToomas Soome FICL_STRING_SET_FROM_CSTRING(s, name);
113afc2ba1dSToomas Soome return (ficlDictionaryAppend2ConstantInstruction(dictionary, s,
114afc2ba1dSToomas Soome ficlInstructionF2ConstantParen, *(ficl2Integer *)(&value)));
115afc2ba1dSToomas Soome }
116afc2ba1dSToomas Soome
117afc2ba1dSToomas Soome ficlWord *
ficlDictionarySetF2Constant(ficlDictionary * dictionary,char * name,ficlFloat value)118afc2ba1dSToomas Soome ficlDictionarySetF2Constant(ficlDictionary *dictionary, char *name,
119afc2ba1dSToomas Soome ficlFloat value)
120afc2ba1dSToomas Soome {
121afc2ba1dSToomas Soome ficlString s;
122afc2ba1dSToomas Soome FICL_STRING_SET_FROM_CSTRING(s, name);
123afc2ba1dSToomas Soome return (ficlDictionarySet2ConstantInstruction(dictionary, s,
124afc2ba1dSToomas Soome ficlInstructionF2ConstantParen, *(ficl2Integer *)(&value)));
125afc2ba1dSToomas Soome }
126afc2ba1dSToomas Soome
127afc2ba1dSToomas Soome /*
128afc2ba1dSToomas Soome * Display a float in decimal format.
129afc2ba1dSToomas Soome * f. ( r -- )
130afc2ba1dSToomas Soome */
131afc2ba1dSToomas Soome static void
ficlPrimitiveFDot(ficlVm * vm)132afc2ba1dSToomas Soome ficlPrimitiveFDot(ficlVm *vm)
133afc2ba1dSToomas Soome {
134afc2ba1dSToomas Soome ficlFloat f;
135afc2ba1dSToomas Soome
136afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->floatStack, 1, 0);
137afc2ba1dSToomas Soome
138afc2ba1dSToomas Soome f = ficlStackPopFloat(vm->floatStack);
139*c0bb4f73SToomas Soome (void) sprintf(vm->pad, "%#f ", f);
140afc2ba1dSToomas Soome ficlVmTextOut(vm, vm->pad);
141afc2ba1dSToomas Soome }
142afc2ba1dSToomas Soome
143afc2ba1dSToomas Soome /*
144afc2ba1dSToomas Soome * Display a float in engineering format.
145afc2ba1dSToomas Soome * fe. ( r -- )
146afc2ba1dSToomas Soome */
147afc2ba1dSToomas Soome static void
ficlPrimitiveEDot(ficlVm * vm)148afc2ba1dSToomas Soome ficlPrimitiveEDot(ficlVm *vm)
149afc2ba1dSToomas Soome {
150afc2ba1dSToomas Soome ficlFloat f;
151afc2ba1dSToomas Soome
152afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->floatStack, 1, 0);
153afc2ba1dSToomas Soome
154afc2ba1dSToomas Soome f = ficlStackPopFloat(vm->floatStack);
155*c0bb4f73SToomas Soome (void) sprintf(vm->pad, "%#e ", f);
156afc2ba1dSToomas Soome ficlVmTextOut(vm, vm->pad);
157afc2ba1dSToomas Soome }
158afc2ba1dSToomas Soome
159afc2ba1dSToomas Soome /*
160afc2ba1dSToomas Soome * d i s p l a y FS t a c k
161afc2ba1dSToomas Soome * Display the parameter stack (code for "f.s")
162afc2ba1dSToomas Soome * f.s ( -- )
163afc2ba1dSToomas Soome */
164afc2ba1dSToomas Soome struct stackContext
165afc2ba1dSToomas Soome {
166afc2ba1dSToomas Soome ficlVm *vm;
167afc2ba1dSToomas Soome int count;
168afc2ba1dSToomas Soome };
169afc2ba1dSToomas Soome
170afc2ba1dSToomas Soome static ficlInteger
ficlFloatStackDisplayCallback(void * c,ficlCell * cell)171afc2ba1dSToomas Soome ficlFloatStackDisplayCallback(void *c, ficlCell *cell)
172afc2ba1dSToomas Soome {
173afc2ba1dSToomas Soome struct stackContext *context = (struct stackContext *)c;
174afc2ba1dSToomas Soome char buffer[80];
175afc2ba1dSToomas Soome #ifdef _LP64
176*c0bb4f73SToomas Soome (void) snprintf(buffer, sizeof (buffer),
177*c0bb4f73SToomas Soome "[0x%016lx %3d] %20e (0x%016lx)\n",
178afc2ba1dSToomas Soome (unsigned long) cell, context->count++, cell->f, cell->u);
179afc2ba1dSToomas Soome #else
180*c0bb4f73SToomas Soome (void) snprintf(buffer, sizeof (buffer), "[0x%08x %3d] %12e (0x%08x)\n",
181afc2ba1dSToomas Soome (unsigned)cell, context->count++, cell->f, cell->u);
182afc2ba1dSToomas Soome #endif
183afc2ba1dSToomas Soome ficlVmTextOut(context->vm, buffer);
184afc2ba1dSToomas Soome return (FICL_TRUE);
185afc2ba1dSToomas Soome }
186afc2ba1dSToomas Soome
187afc2ba1dSToomas Soome void
ficlVmDisplayFloatStack(ficlVm * vm)188afc2ba1dSToomas Soome ficlVmDisplayFloatStack(ficlVm *vm)
189afc2ba1dSToomas Soome {
190afc2ba1dSToomas Soome struct stackContext context;
191afc2ba1dSToomas Soome context.vm = vm;
192afc2ba1dSToomas Soome context.count = 0;
193afc2ba1dSToomas Soome ficlStackDisplay(vm->floatStack, ficlFloatStackDisplayCallback,
194afc2ba1dSToomas Soome &context);
195afc2ba1dSToomas Soome }
196afc2ba1dSToomas Soome
197afc2ba1dSToomas Soome /*
198afc2ba1dSToomas Soome * Do float stack depth.
199afc2ba1dSToomas Soome * fdepth ( -- n )
200afc2ba1dSToomas Soome */
201afc2ba1dSToomas Soome static void
ficlPrimitiveFDepth(ficlVm * vm)202afc2ba1dSToomas Soome ficlPrimitiveFDepth(ficlVm *vm)
203afc2ba1dSToomas Soome {
204afc2ba1dSToomas Soome int i;
205afc2ba1dSToomas Soome
206afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 0, 1);
207afc2ba1dSToomas Soome
208afc2ba1dSToomas Soome i = ficlStackDepth(vm->floatStack);
209afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack, i);
210afc2ba1dSToomas Soome }
211afc2ba1dSToomas Soome
212afc2ba1dSToomas Soome /*
213afc2ba1dSToomas Soome * Compile a floating point literal.
214afc2ba1dSToomas Soome */
215afc2ba1dSToomas Soome static void
ficlPrimitiveFLiteralImmediate(ficlVm * vm)216afc2ba1dSToomas Soome ficlPrimitiveFLiteralImmediate(ficlVm *vm)
217afc2ba1dSToomas Soome {
218afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm);
219afc2ba1dSToomas Soome ficlCell cell;
220afc2ba1dSToomas Soome
221afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->floatStack, 1, 0);
222afc2ba1dSToomas Soome
223afc2ba1dSToomas Soome cell = ficlStackPop(vm->floatStack);
224afc2ba1dSToomas Soome if (cell.f == 1.0f) {
225afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, ficlInstructionF1);
226afc2ba1dSToomas Soome } else if (cell.f == 0.0f) {
227afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, ficlInstructionF0);
228afc2ba1dSToomas Soome } else if (cell.f == -1.0f) {
229afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, ficlInstructionFNeg1);
230afc2ba1dSToomas Soome } else {
231afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary,
232afc2ba1dSToomas Soome ficlInstructionFLiteralParen);
233afc2ba1dSToomas Soome ficlDictionaryAppendCell(dictionary, cell);
234afc2ba1dSToomas Soome }
235afc2ba1dSToomas Soome }
236afc2ba1dSToomas Soome
237afc2ba1dSToomas Soome /*
238afc2ba1dSToomas Soome * F l o a t P a r s e S t a t e
239afc2ba1dSToomas Soome * Enum to determine the current segement of a floating point number
240afc2ba1dSToomas Soome * being parsed.
241afc2ba1dSToomas Soome */
242afc2ba1dSToomas Soome #define NUMISNEG 1
243afc2ba1dSToomas Soome #define EXPISNEG 2
244afc2ba1dSToomas Soome
245afc2ba1dSToomas Soome typedef enum _floatParseState
246afc2ba1dSToomas Soome {
247afc2ba1dSToomas Soome FPS_START,
248afc2ba1dSToomas Soome FPS_ININT,
249afc2ba1dSToomas Soome FPS_INMANT,
250afc2ba1dSToomas Soome FPS_STARTEXP,
251afc2ba1dSToomas Soome FPS_INEXP
252afc2ba1dSToomas Soome } FloatParseState;
253afc2ba1dSToomas Soome
254afc2ba1dSToomas Soome /*
255afc2ba1dSToomas Soome * f i c l P a r s e F l o a t N u m b e r
256afc2ba1dSToomas Soome * vm -- Virtual Machine pointer.
257afc2ba1dSToomas Soome * s -- String to parse.
258afc2ba1dSToomas Soome * Returns 1 if successful, 0 if not.
259afc2ba1dSToomas Soome */
260afc2ba1dSToomas Soome int
ficlVmParseFloatNumber(ficlVm * vm,ficlString s)261afc2ba1dSToomas Soome ficlVmParseFloatNumber(ficlVm *vm, ficlString s)
262afc2ba1dSToomas Soome {
263afc2ba1dSToomas Soome unsigned char c;
264afc2ba1dSToomas Soome unsigned char digit;
265afc2ba1dSToomas Soome char *trace;
266afc2ba1dSToomas Soome ficlUnsigned length;
267afc2ba1dSToomas Soome ficlFloat power;
268afc2ba1dSToomas Soome ficlFloat accum = 0.0f;
269afc2ba1dSToomas Soome ficlFloat mant = 0.1f;
270afc2ba1dSToomas Soome ficlInteger exponent = 0;
271afc2ba1dSToomas Soome char flag = 0;
272afc2ba1dSToomas Soome FloatParseState estate = FPS_START;
273afc2ba1dSToomas Soome
274afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->floatStack, 0, 1);
275afc2ba1dSToomas Soome
276afc2ba1dSToomas Soome /*
277afc2ba1dSToomas Soome * floating point numbers only allowed in base 10
278afc2ba1dSToomas Soome */
279afc2ba1dSToomas Soome if (vm->base != 10)
280afc2ba1dSToomas Soome return (0);
281afc2ba1dSToomas Soome
282afc2ba1dSToomas Soome trace = FICL_STRING_GET_POINTER(s);
283afc2ba1dSToomas Soome length = FICL_STRING_GET_LENGTH(s);
284afc2ba1dSToomas Soome
285afc2ba1dSToomas Soome /* Loop through the string's characters. */
286afc2ba1dSToomas Soome while ((length--) && ((c = *trace++) != 0)) {
287afc2ba1dSToomas Soome switch (estate) {
288afc2ba1dSToomas Soome /* At start of the number so look for a sign. */
289afc2ba1dSToomas Soome case FPS_START:
290afc2ba1dSToomas Soome estate = FPS_ININT;
291afc2ba1dSToomas Soome if (c == '-') {
292afc2ba1dSToomas Soome flag |= NUMISNEG;
293afc2ba1dSToomas Soome break;
294afc2ba1dSToomas Soome }
295afc2ba1dSToomas Soome if (c == '+') {
296afc2ba1dSToomas Soome break;
297afc2ba1dSToomas Soome }
298d65dfb0aSToomas Soome /* FALLTHROUGH */
299afc2ba1dSToomas Soome /*
300afc2ba1dSToomas Soome * Converting integer part of number.
301afc2ba1dSToomas Soome * Only allow digits, decimal and 'E'.
302afc2ba1dSToomas Soome */
303afc2ba1dSToomas Soome case FPS_ININT:
304afc2ba1dSToomas Soome if (c == '.') {
305afc2ba1dSToomas Soome estate = FPS_INMANT;
306afc2ba1dSToomas Soome } else if ((c == 'e') || (c == 'E')) {
307afc2ba1dSToomas Soome estate = FPS_STARTEXP;
308afc2ba1dSToomas Soome } else {
309afc2ba1dSToomas Soome digit = (unsigned char)(c - '0');
310afc2ba1dSToomas Soome if (digit > 9)
311afc2ba1dSToomas Soome return (0);
312afc2ba1dSToomas Soome
313afc2ba1dSToomas Soome accum = accum * 10 + digit;
314afc2ba1dSToomas Soome }
315afc2ba1dSToomas Soome break;
316afc2ba1dSToomas Soome /*
317afc2ba1dSToomas Soome * Processing the fraction part of number.
318afc2ba1dSToomas Soome * Only allow digits and 'E'
319afc2ba1dSToomas Soome */
320afc2ba1dSToomas Soome case FPS_INMANT:
321afc2ba1dSToomas Soome if ((c == 'e') || (c == 'E')) {
322afc2ba1dSToomas Soome estate = FPS_STARTEXP;
323afc2ba1dSToomas Soome } else {
324afc2ba1dSToomas Soome digit = (unsigned char)(c - '0');
325afc2ba1dSToomas Soome if (digit > 9)
326afc2ba1dSToomas Soome return (0);
327afc2ba1dSToomas Soome
328afc2ba1dSToomas Soome accum += digit * mant;
329afc2ba1dSToomas Soome mant *= 0.1f;
330afc2ba1dSToomas Soome }
331afc2ba1dSToomas Soome break;
332afc2ba1dSToomas Soome /* Start processing the exponent part of number. */
333afc2ba1dSToomas Soome /* Look for sign. */
334afc2ba1dSToomas Soome case FPS_STARTEXP:
335afc2ba1dSToomas Soome estate = FPS_INEXP;
336afc2ba1dSToomas Soome
337afc2ba1dSToomas Soome if (c == '-') {
338afc2ba1dSToomas Soome flag |= EXPISNEG;
339afc2ba1dSToomas Soome break;
340afc2ba1dSToomas Soome } else if (c == '+') {
341afc2ba1dSToomas Soome break;
342afc2ba1dSToomas Soome }
343d65dfb0aSToomas Soome /* FALLTHROUGH */
344afc2ba1dSToomas Soome /*
345afc2ba1dSToomas Soome * Processing the exponent part of number.
346afc2ba1dSToomas Soome * Only allow digits.
347afc2ba1dSToomas Soome */
348afc2ba1dSToomas Soome case FPS_INEXP:
349afc2ba1dSToomas Soome digit = (unsigned char)(c - '0');
350afc2ba1dSToomas Soome if (digit > 9)
351afc2ba1dSToomas Soome return (0);
352afc2ba1dSToomas Soome
353afc2ba1dSToomas Soome exponent = exponent * 10 + digit;
354afc2ba1dSToomas Soome
355afc2ba1dSToomas Soome break;
356afc2ba1dSToomas Soome }
357afc2ba1dSToomas Soome }
358afc2ba1dSToomas Soome
359afc2ba1dSToomas Soome /* If parser never made it to the exponent this is not a float. */
360afc2ba1dSToomas Soome if (estate < FPS_STARTEXP)
361afc2ba1dSToomas Soome return (0);
362afc2ba1dSToomas Soome
363afc2ba1dSToomas Soome /* Set the sign of the number. */
364afc2ba1dSToomas Soome if (flag & NUMISNEG)
365afc2ba1dSToomas Soome accum = -accum;
366afc2ba1dSToomas Soome
367afc2ba1dSToomas Soome /* If exponent is not 0 then adjust number by it. */
368afc2ba1dSToomas Soome if (exponent != 0) {
369afc2ba1dSToomas Soome /* Determine if exponent is negative. */
370afc2ba1dSToomas Soome if (flag & EXPISNEG) {
371afc2ba1dSToomas Soome exponent = -exponent;
372afc2ba1dSToomas Soome }
373afc2ba1dSToomas Soome /* power = 10^x */
374afc2ba1dSToomas Soome #if defined(_LP64)
375afc2ba1dSToomas Soome power = (ficlFloat)pow(10.0, exponent);
376afc2ba1dSToomas Soome #else
377afc2ba1dSToomas Soome power = (ficlFloat)powf(10.0, exponent);
378afc2ba1dSToomas Soome #endif
379afc2ba1dSToomas Soome accum *= power;
380afc2ba1dSToomas Soome }
381afc2ba1dSToomas Soome
382afc2ba1dSToomas Soome ficlStackPushFloat(vm->floatStack, accum);
383afc2ba1dSToomas Soome if (vm->state == FICL_VM_STATE_COMPILE)
384afc2ba1dSToomas Soome ficlPrimitiveFLiteralImmediate(vm);
385afc2ba1dSToomas Soome
386afc2ba1dSToomas Soome return (1);
387afc2ba1dSToomas Soome }
388afc2ba1dSToomas Soome #endif /* FICL_WANT_FLOAT */
389afc2ba1dSToomas Soome
390afc2ba1dSToomas Soome #if FICL_WANT_LOCALS
391afc2ba1dSToomas Soome static void
ficlPrimitiveFLocalParen(ficlVm * vm)392afc2ba1dSToomas Soome ficlPrimitiveFLocalParen(ficlVm *vm)
393afc2ba1dSToomas Soome {
394afc2ba1dSToomas Soome ficlLocalParen(vm, 0, 1);
395afc2ba1dSToomas Soome }
396afc2ba1dSToomas Soome
397afc2ba1dSToomas Soome static void
ficlPrimitiveF2LocalParen(ficlVm * vm)398afc2ba1dSToomas Soome ficlPrimitiveF2LocalParen(ficlVm *vm)
399afc2ba1dSToomas Soome {
400afc2ba1dSToomas Soome ficlLocalParen(vm, 1, 1);
401afc2ba1dSToomas Soome }
402afc2ba1dSToomas Soome #endif /* FICL_WANT_LOCALS */
403afc2ba1dSToomas Soome
404afc2ba1dSToomas Soome /*
405afc2ba1dSToomas Soome * Add float words to a system's dictionary.
406d0b12b66SToomas Soome * system -- Pointer to the Ficl system to add float words to.
407afc2ba1dSToomas Soome */
408afc2ba1dSToomas Soome void
ficlSystemCompileFloat(ficlSystem * system)409afc2ba1dSToomas Soome ficlSystemCompileFloat(ficlSystem *system)
410afc2ba1dSToomas Soome {
411afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlSystemGetDictionary(system);
412afc2ba1dSToomas Soome ficlDictionary *environment = ficlSystemGetEnvironment(system);
413afc2ba1dSToomas Soome #if FICL_WANT_FLOAT
414afc2ba1dSToomas Soome ficlCell data;
415afc2ba1dSToomas Soome #endif
416afc2ba1dSToomas Soome
417afc2ba1dSToomas Soome FICL_SYSTEM_ASSERT(system, dictionary);
418afc2ba1dSToomas Soome FICL_SYSTEM_ASSERT(system, environment);
419afc2ba1dSToomas Soome
420afc2ba1dSToomas Soome #if FICL_WANT_LOCALS
421*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "(flocal)",
422afc2ba1dSToomas Soome ficlPrimitiveFLocalParen, FICL_WORD_COMPILE_ONLY);
423*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "(f2local)",
424afc2ba1dSToomas Soome ficlPrimitiveF2LocalParen, FICL_WORD_COMPILE_ONLY);
425afc2ba1dSToomas Soome #endif /* FICL_WANT_LOCALS */
426afc2ba1dSToomas Soome
427afc2ba1dSToomas Soome #if FICL_WANT_FLOAT
428*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "fconstant",
429afc2ba1dSToomas Soome ficlPrimitiveFConstant, FICL_WORD_DEFAULT);
430*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "fvalue",
431afc2ba1dSToomas Soome ficlPrimitiveFConstant, FICL_WORD_DEFAULT);
432*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "f2constant",
433afc2ba1dSToomas Soome ficlPrimitiveF2Constant, FICL_WORD_DEFAULT);
434*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "f2value",
435afc2ba1dSToomas Soome ficlPrimitiveF2Constant, FICL_WORD_DEFAULT);
436*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "fdepth",
437*c0bb4f73SToomas Soome ficlPrimitiveFDepth, FICL_WORD_DEFAULT);
438*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "fliteral",
439afc2ba1dSToomas Soome ficlPrimitiveFLiteralImmediate, FICL_WORD_IMMEDIATE);
440*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "f.",
441*c0bb4f73SToomas Soome ficlPrimitiveFDot, FICL_WORD_DEFAULT);
442*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "f.s",
443*c0bb4f73SToomas Soome ficlVmDisplayFloatStack, FICL_WORD_DEFAULT);
444*c0bb4f73SToomas Soome (void) ficlDictionarySetPrimitive(dictionary, "fe.",
445*c0bb4f73SToomas Soome ficlPrimitiveEDot, FICL_WORD_DEFAULT);
446afc2ba1dSToomas Soome
447afc2ba1dSToomas Soome /*
448afc2ba1dSToomas Soome * Missing words:
449afc2ba1dSToomas Soome *
450afc2ba1dSToomas Soome * d>f
451afc2ba1dSToomas Soome * f>d
452afc2ba1dSToomas Soome * falign
453afc2ba1dSToomas Soome * faligned
454afc2ba1dSToomas Soome * float+
455afc2ba1dSToomas Soome * floats
456afc2ba1dSToomas Soome * floor
457afc2ba1dSToomas Soome * fmax
458afc2ba1dSToomas Soome * fmin
459afc2ba1dSToomas Soome */
460afc2ba1dSToomas Soome
461afc2ba1dSToomas Soome #if defined(_LP64)
462afc2ba1dSToomas Soome data.f = MAXDOUBLE;
463afc2ba1dSToomas Soome #else
464afc2ba1dSToomas Soome data.f = MAXFLOAT;
465afc2ba1dSToomas Soome #endif
466*c0bb4f73SToomas Soome (void) ficlDictionarySetConstant(environment, "max-float", data.i);
467afc2ba1dSToomas Soome /* not all required words are present */
468*c0bb4f73SToomas Soome (void) ficlDictionarySetConstant(environment, "floating", FICL_FALSE);
469*c0bb4f73SToomas Soome (void) ficlDictionarySetConstant(environment, "floating-ext",
470*c0bb4f73SToomas Soome FICL_FALSE);
471*c0bb4f73SToomas Soome (void) ficlDictionarySetConstant(environment, "floating-stack",
472afc2ba1dSToomas Soome system->stackSize);
473afc2ba1dSToomas Soome #else
474*c0bb4f73SToomas Soome (void) ficlDictionarySetConstant(environment, "floating", FICL_FALSE);
475afc2ba1dSToomas Soome #endif
476afc2ba1dSToomas Soome }
477