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
ficlPrimitiveFConstant(ficlVm * vm)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 (void) ficlDictionaryAppendWord(dictionary, name,
64 (ficlPrimitive)ficlInstructionFConstantParen, FICL_WORD_DEFAULT);
65 ficlDictionaryAppendCell(dictionary, ficlStackPop(vm->floatStack));
66 }
67
68
69 ficlWord *
ficlDictionaryAppendFConstant(ficlDictionary * dictionary,char * name,ficlFloat value)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 *
ficlDictionarySetFConstant(ficlDictionary * dictionary,char * name,ficlFloat value)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
ficlPrimitiveF2Constant(ficlVm * vm)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 (void) 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 *
ficlDictionaryAppendF2Constant(ficlDictionary * dictionary,char * name,ficlFloat value)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 *
ficlDictionarySetF2Constant(ficlDictionary * dictionary,char * name,ficlFloat value)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
ficlPrimitiveFDot(ficlVm * vm)132 ficlPrimitiveFDot(ficlVm *vm)
133 {
134 ficlFloat f;
135
136 FICL_STACK_CHECK(vm->floatStack, 1, 0);
137
138 f = ficlStackPopFloat(vm->floatStack);
139 (void) 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
ficlPrimitiveEDot(ficlVm * vm)148 ficlPrimitiveEDot(ficlVm *vm)
149 {
150 ficlFloat f;
151
152 FICL_STACK_CHECK(vm->floatStack, 1, 0);
153
154 f = ficlStackPopFloat(vm->floatStack);
155 (void) 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
ficlFloatStackDisplayCallback(void * c,ficlCell * cell)171 ficlFloatStackDisplayCallback(void *c, ficlCell *cell)
172 {
173 struct stackContext *context = (struct stackContext *)c;
174 char buffer[80];
175 #ifdef _LP64
176 (void) snprintf(buffer, sizeof (buffer),
177 "[0x%016lx %3d] %20e (0x%016lx)\n",
178 (unsigned long) cell, context->count++, cell->f, cell->u);
179 #else
180 (void) snprintf(buffer, sizeof (buffer), "[0x%08x %3d] %12e (0x%08x)\n",
181 (unsigned)cell, context->count++, cell->f, cell->u);
182 #endif
183 ficlVmTextOut(context->vm, buffer);
184 return (FICL_TRUE);
185 }
186
187 void
ficlVmDisplayFloatStack(ficlVm * vm)188 ficlVmDisplayFloatStack(ficlVm *vm)
189 {
190 struct stackContext context;
191 context.vm = vm;
192 context.count = 0;
193 ficlStackDisplay(vm->floatStack, ficlFloatStackDisplayCallback,
194 &context);
195 }
196
197 /*
198 * Do float stack depth.
199 * fdepth ( -- n )
200 */
201 static void
ficlPrimitiveFDepth(ficlVm * vm)202 ficlPrimitiveFDepth(ficlVm *vm)
203 {
204 int i;
205
206 FICL_STACK_CHECK(vm->dataStack, 0, 1);
207
208 i = ficlStackDepth(vm->floatStack);
209 ficlStackPushInteger(vm->dataStack, i);
210 }
211
212 /*
213 * Compile a floating point literal.
214 */
215 static void
ficlPrimitiveFLiteralImmediate(ficlVm * vm)216 ficlPrimitiveFLiteralImmediate(ficlVm *vm)
217 {
218 ficlDictionary *dictionary = ficlVmGetDictionary(vm);
219 ficlCell cell;
220
221 FICL_STACK_CHECK(vm->floatStack, 1, 0);
222
223 cell = ficlStackPop(vm->floatStack);
224 if (cell.f == 1.0f) {
225 ficlDictionaryAppendUnsigned(dictionary, ficlInstructionF1);
226 } else if (cell.f == 0.0f) {
227 ficlDictionaryAppendUnsigned(dictionary, ficlInstructionF0);
228 } else if (cell.f == -1.0f) {
229 ficlDictionaryAppendUnsigned(dictionary, ficlInstructionFNeg1);
230 } else {
231 ficlDictionaryAppendUnsigned(dictionary,
232 ficlInstructionFLiteralParen);
233 ficlDictionaryAppendCell(dictionary, cell);
234 }
235 }
236
237 /*
238 * F l o a t P a r s e S t a t e
239 * Enum to determine the current segement of a floating point number
240 * being parsed.
241 */
242 #define NUMISNEG 1
243 #define EXPISNEG 2
244
245 typedef enum _floatParseState
246 {
247 FPS_START,
248 FPS_ININT,
249 FPS_INMANT,
250 FPS_STARTEXP,
251 FPS_INEXP
252 } FloatParseState;
253
254 /*
255 * f i c l P a r s e F l o a t N u m b e r
256 * vm -- Virtual Machine pointer.
257 * s -- String to parse.
258 * Returns 1 if successful, 0 if not.
259 */
260 int
ficlVmParseFloatNumber(ficlVm * vm,ficlString s)261 ficlVmParseFloatNumber(ficlVm *vm, ficlString s)
262 {
263 unsigned char c;
264 unsigned char digit;
265 char *trace;
266 ficlUnsigned length;
267 ficlFloat power;
268 ficlFloat accum = 0.0f;
269 ficlFloat mant = 0.1f;
270 ficlInteger exponent = 0;
271 char flag = 0;
272 FloatParseState estate = FPS_START;
273
274 FICL_STACK_CHECK(vm->floatStack, 0, 1);
275
276 /*
277 * floating point numbers only allowed in base 10
278 */
279 if (vm->base != 10)
280 return (0);
281
282 trace = FICL_STRING_GET_POINTER(s);
283 length = FICL_STRING_GET_LENGTH(s);
284
285 /* Loop through the string's characters. */
286 while ((length--) && ((c = *trace++) != 0)) {
287 switch (estate) {
288 /* At start of the number so look for a sign. */
289 case FPS_START:
290 estate = FPS_ININT;
291 if (c == '-') {
292 flag |= NUMISNEG;
293 break;
294 }
295 if (c == '+') {
296 break;
297 }
298 /* FALLTHROUGH */
299 /*
300 * Converting integer part of number.
301 * Only allow digits, decimal and 'E'.
302 */
303 case FPS_ININT:
304 if (c == '.') {
305 estate = FPS_INMANT;
306 } else if ((c == 'e') || (c == 'E')) {
307 estate = FPS_STARTEXP;
308 } else {
309 digit = (unsigned char)(c - '0');
310 if (digit > 9)
311 return (0);
312
313 accum = accum * 10 + digit;
314 }
315 break;
316 /*
317 * Processing the fraction part of number.
318 * Only allow digits and 'E'
319 */
320 case FPS_INMANT:
321 if ((c == 'e') || (c == 'E')) {
322 estate = FPS_STARTEXP;
323 } else {
324 digit = (unsigned char)(c - '0');
325 if (digit > 9)
326 return (0);
327
328 accum += digit * mant;
329 mant *= 0.1f;
330 }
331 break;
332 /* Start processing the exponent part of number. */
333 /* Look for sign. */
334 case FPS_STARTEXP:
335 estate = FPS_INEXP;
336
337 if (c == '-') {
338 flag |= EXPISNEG;
339 break;
340 } else if (c == '+') {
341 break;
342 }
343 /* FALLTHROUGH */
344 /*
345 * Processing the exponent part of number.
346 * Only allow digits.
347 */
348 case FPS_INEXP:
349 digit = (unsigned char)(c - '0');
350 if (digit > 9)
351 return (0);
352
353 exponent = exponent * 10 + digit;
354
355 break;
356 }
357 }
358
359 /* If parser never made it to the exponent this is not a float. */
360 if (estate < FPS_STARTEXP)
361 return (0);
362
363 /* Set the sign of the number. */
364 if (flag & NUMISNEG)
365 accum = -accum;
366
367 /* If exponent is not 0 then adjust number by it. */
368 if (exponent != 0) {
369 /* Determine if exponent is negative. */
370 if (flag & EXPISNEG) {
371 exponent = -exponent;
372 }
373 /* power = 10^x */
374 #if defined(_LP64)
375 power = (ficlFloat)pow(10.0, exponent);
376 #else
377 power = (ficlFloat)powf(10.0, exponent);
378 #endif
379 accum *= power;
380 }
381
382 ficlStackPushFloat(vm->floatStack, accum);
383 if (vm->state == FICL_VM_STATE_COMPILE)
384 ficlPrimitiveFLiteralImmediate(vm);
385
386 return (1);
387 }
388 #endif /* FICL_WANT_FLOAT */
389
390 #if FICL_WANT_LOCALS
391 static void
ficlPrimitiveFLocalParen(ficlVm * vm)392 ficlPrimitiveFLocalParen(ficlVm *vm)
393 {
394 ficlLocalParen(vm, 0, 1);
395 }
396
397 static void
ficlPrimitiveF2LocalParen(ficlVm * vm)398 ficlPrimitiveF2LocalParen(ficlVm *vm)
399 {
400 ficlLocalParen(vm, 1, 1);
401 }
402 #endif /* FICL_WANT_LOCALS */
403
404 /*
405 * Add float words to a system's dictionary.
406 * system -- Pointer to the Ficl system to add float words to.
407 */
408 void
ficlSystemCompileFloat(ficlSystem * system)409 ficlSystemCompileFloat(ficlSystem *system)
410 {
411 ficlDictionary *dictionary = ficlSystemGetDictionary(system);
412 ficlDictionary *environment = ficlSystemGetEnvironment(system);
413 #if FICL_WANT_FLOAT
414 ficlCell data;
415 #endif
416
417 FICL_SYSTEM_ASSERT(system, dictionary);
418 FICL_SYSTEM_ASSERT(system, environment);
419
420 #if FICL_WANT_LOCALS
421 (void) ficlDictionarySetPrimitive(dictionary, "(flocal)",
422 ficlPrimitiveFLocalParen, FICL_WORD_COMPILE_ONLY);
423 (void) ficlDictionarySetPrimitive(dictionary, "(f2local)",
424 ficlPrimitiveF2LocalParen, FICL_WORD_COMPILE_ONLY);
425 #endif /* FICL_WANT_LOCALS */
426
427 #if FICL_WANT_FLOAT
428 (void) ficlDictionarySetPrimitive(dictionary, "fconstant",
429 ficlPrimitiveFConstant, FICL_WORD_DEFAULT);
430 (void) ficlDictionarySetPrimitive(dictionary, "fvalue",
431 ficlPrimitiveFConstant, FICL_WORD_DEFAULT);
432 (void) ficlDictionarySetPrimitive(dictionary, "f2constant",
433 ficlPrimitiveF2Constant, FICL_WORD_DEFAULT);
434 (void) ficlDictionarySetPrimitive(dictionary, "f2value",
435 ficlPrimitiveF2Constant, FICL_WORD_DEFAULT);
436 (void) ficlDictionarySetPrimitive(dictionary, "fdepth",
437 ficlPrimitiveFDepth, FICL_WORD_DEFAULT);
438 (void) ficlDictionarySetPrimitive(dictionary, "fliteral",
439 ficlPrimitiveFLiteralImmediate, FICL_WORD_IMMEDIATE);
440 (void) ficlDictionarySetPrimitive(dictionary, "f.",
441 ficlPrimitiveFDot, FICL_WORD_DEFAULT);
442 (void) ficlDictionarySetPrimitive(dictionary, "f.s",
443 ficlVmDisplayFloatStack, FICL_WORD_DEFAULT);
444 (void) ficlDictionarySetPrimitive(dictionary, "fe.",
445 ficlPrimitiveEDot, FICL_WORD_DEFAULT);
446
447 /*
448 * Missing words:
449 *
450 * d>f
451 * f>d
452 * falign
453 * faligned
454 * float+
455 * floats
456 * floor
457 * fmax
458 * fmin
459 */
460
461 #if defined(_LP64)
462 data.f = MAXDOUBLE;
463 #else
464 data.f = MAXFLOAT;
465 #endif
466 (void) ficlDictionarySetConstant(environment, "max-float", data.i);
467 /* not all required words are present */
468 (void) ficlDictionarySetConstant(environment, "floating", FICL_FALSE);
469 (void) ficlDictionarySetConstant(environment, "floating-ext",
470 FICL_FALSE);
471 (void) ficlDictionarySetConstant(environment, "floating-stack",
472 system->stackSize);
473 #else
474 (void) ficlDictionarySetConstant(environment, "floating", FICL_FALSE);
475 #endif
476 }
477