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