Lhogho  0.0.028
 All Data Structures Files Functions Variables Typedefs Macros Pages
numbers.c
Go to the documentation of this file.
1 //
2 // Project: Lhogho
3 // File: numbers.c
4 //
5 // Copyright (C) 2007 P.Boytchev
6 //
7 // Revision history:
8 // 2007-06-09 - file created from atoms.c
9 // 2007-06-25 - atom_to_float()
10 // 2007-07-08 - fixed bug #1749858 INF and NaN in Windows
11 // 2007-08-13 - atom_to_int()
12 // 2007-11-05 - atom_to_integer()
13 // 2007-11-26 - fixed bug #1838504 User commands without inputs are miscompiled
14 // 2007-12-21 - fixed bug #1851865 Locale information not considered
15 // 2009-07-15 - fixed request #2804558 Correct display of integers>999999
16 // 2012-02-06 - Fixed bug #3484953 Printing power 10 200 crashes
17 //
18 //
19 // This program is free software; you can redistribute it and/or modify
20 // it under the terms of the GNU General Public License as published by
21 // the Free Software Foundation; either version 2 of the License, or
22 // (at your option) any later version.
23 //
24 // This program is distributed in the hope that it will be useful,
25 // but WITHOUT ANY WARRANTY; without even the implied warranty of
26 // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
27 // GNU General Public License for more details.
28 //
29 // You should have received a copy of the GNU General Public License
30 // along with this program; if not, write to the Free Software
31 // Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
32 //
33 
34 #undef __STRICT_ANSI__
35 
36 
37 #include <assert.h> // assert()
38 #include <errno.h> // errno, ENOMEM
39 #include <stdio.h> // fopen(), fread(), fclose()
40 #include <stdlib.h> // malloc()
41 #include <string.h> // memcpy()
42 #include <locale.h> // LC_ALL
43 #include <math.h>
44 
45 #include "globals.h"
46 #include "compiler.h"
47 
48 #ifdef UNICODE_CHARS
49  #include <wchar.h>
50 #endif
51 
52 #include "atoms.h"
53 #include "numbers.h"
54 #include "words.h"
55 #include "lists.h"
56 #include "errors.h"
57 #include "pools.h"
58 #include "unicode.h"
59 #include "translate.h"
60 #include "vars.h"
61 #include "parser.h"
62 #include "options.h"
63 
64 
65 #ifdef LINUX
66 #ifndef signbit
67 extern int signbit( float64_t x );
68 #endif
69 #endif
70 
71 
72 #define EPSILON 1E-64
73 
74 
75 //===================================================
82 //===================================================
84 {
86 }
87 
88 
89 
90 
91 //===================================================
98 //===================================================
99 atom_t new_integer( int64_t data )
100 {
102 
103  REF(a) = 1;
104  ID(a) = INTEGER_ID;
105  INTEGER(a) = data;
106 
107  #ifdef DEBUG_ATOM
108  printf("<ATOM> [%08x] integer=%I64d\n",(int)a,data);
109  #endif //DEBUG_ATOM
110 
111  #ifdef ADVANCED
112  stats[ID(a)].allocs++;
113  if( stats[ID(a)].max<(stats[ID(a)].allocs-stats[ID(a)].deallocs) )
114  stats[ID(a)].max=(stats[ID(a)].allocs-stats[ID(a)].deallocs);
115  stats_free--;
116  #endif //ADVANCED
117 
118  #ifdef DEBUG_RUNTIME_ATOMS
120  {
121  outter( TEXT("<RUNTIME> new "), -1 );
122  dump_atom_address( a );
123  dump_atom( a, 1 );
124  outter( TEXT("\n"), -1 );
125  }
126  #endif
127  #ifdef DEBUG_COMPILETIME_ATOMS
128  if( compiling_code )
129  {
130  outter( TEXT("<COMPILETIME> new "), -1 );
131  dump_atom_address( a );
132  dump_atom( a, 1 );
133  outter( TEXT("\n"), -1 );
134  }
135  #endif
136 
137  return a;
138 }
139 
140 
141 
142 
143 //===================================================
151 //===================================================
153 {
155 
156  REF(a) = 1;
157  ID(a) = FLOAT_ID;
158  FLOAT(a) = data;
159 
160 //if( IS_FLOAT(a) )
161 //{
162 //printf("SET.FLT[%08x] %0.14f ref %d\n", (int)a, FLOAT(a), REF(a) );
163 //}
164 
165  #ifdef DEBUG_ATOM
166  printf("<ATOM> [%08x] float=%Lf\n",(int)a,data);
167  #endif //DEBUG_ATOM
168 
169  #ifdef ADVANCED
170  stats[ID(a)].allocs++;
171  if( stats[ID(a)].max<(stats[ID(a)].allocs-stats[ID(a)].deallocs) )
172  stats[ID(a)].max=(stats[ID(a)].allocs-stats[ID(a)].deallocs);
173  stats_free--;
174  #endif //ADVANCED
175 
176  #ifdef DEBUG_RUNTIME_ATOMS
178  {
179  outter( TEXT("<RUNTIME> new "), -1 );
180  dump_atom_address( a );
181  dump_atom( a, 1 );
182  outter( TEXT("\n"), -1 );
183  }
184  #endif
185  #ifdef DEBUG_COMPILETIME_ATOMS
186  if( compiling_code )
187  {
188  outter( TEXT("<COMPILETIME> new "), -1 );
189  dump_atom_address( a );
190  dump_atom( a, 1 );
191  outter( TEXT("\n"), -1 );
192  }
193  #endif
194 
195  return a;
196 }
197 
198 
199 
200 
201 //===================================================
208 //===================================================
209 void dump_integer( atom_t a, int level )
210 {
211  if( IS_UNBOUND(a) )
212  {
213  outter( TEXT("(unbound)"), 9 );
214  outter_size += 9;
215  }
216  else
217  if( IS_STOPPED(a) )
218  {
219  outter( TEXT("(stopped)"), 9 );
220  outter_size += 9;
221  }
222  else
223  {
224  #define DUMP_BUF_SIZE 128
225  char_t buf[DUMP_BUF_SIZE];
226  int n;
227 
228  n = SPRINTF( buf, DUMP_BUF_SIZE, FORMAT_INT, INTEGER(a) );
229 
230  int limit = print_width_limit;
231 
232  if( 0<=limit && limit<10 ) limit=10;
233 
234  if( 0<=limit && limit<n )
235  {
236  outter( buf, limit );
237  outter( TEXT("..."), 3 );
238  outter_size += limit+3;
239  }
240  else
241  {
242  outter( buf, n );
243  outter_size += n;
244  }
245 
246  #undef DUMP_BUF_SIZE
247  }
248 }
249 
250 
251 
252 
253 //===================================================
259 //===================================================
260 void dump_integer_const( int a )
261 {
262  #define DUMP_BUF_SIZE 128
263  char_t buf[DUMP_BUF_SIZE];
264  int n;
265 
266  n = SPRINTF( buf, DUMP_BUF_SIZE, TEXT("%d"), a );
267  outter( buf, n );
268 
269  #undef DUMP_BUF_SIZE
270 }
271 
272 
273 #if defined(DEBUG_RUNTIME_ATOMS) || defined(DEBUG_COMPILETIME_ATOMS)
274 //===================================================
280 //===================================================
281 void dump_atom_address( atom_t a )
282 {
283  #define DUMP_BUF_SIZE 128
284  char_t buf[DUMP_BUF_SIZE];
285  int n;
286 
287  n = SPRINTF( buf, DUMP_BUF_SIZE, TEXT(" [%x]"), (int)a );
288  outter( buf, n );
289  if( REF(a)>300 )
290  outter( TEXT(":?"), 2 );
291  else
292  {
293  n = SPRINTF( buf, DUMP_BUF_SIZE, TEXT(":%d = "), REF(a) );
294  outter( buf, n );
295  }
296 
297  #undef DUMP_BUF_SIZE
298 }
299 #endif //DEBUG_RUNTIME_ATOMS || DEBUG_COMPILETIME_ATOMS
300 
301 
302 
303 //===================================================
310 //===================================================
311 void dump_float( atom_t a, int level )
312 {
313  // In Window infinities are printed as "1.#INF" instead
314  // of just "inf", and "-1.#IND" instead of "nan". So let's fix this.
315  // In some Linuxes sqrt(-1) is "nan" in others it is "-nan".
316  // Let's make "-nan" be "nan"
317  #ifdef WINDOWS
318  if( isinf(FLOAT(a))!=0 && FLOAT(a)>0 )
319  {
320  outter( TEXT("inf"), 3 );
321  outter_size += 3;
322  return;
323  }
324 
325  if( isinf(FLOAT(a))!=0 && FLOAT(a)<0 )
326  {
327  outter( TEXT("-inf"), 4 );
328  outter_size += 4;
329  return;
330  }
331  #endif //WINDOWS
332 
333  // Convert "-nan" to "nan"
334  if( isnan(FLOAT(a))!=0 )
335  {
336  outter( TEXT("nan"), 3 );
337  outter_size += 3;
338  return;
339  }
340 
341  #define DUMP_BUF_SIZE 128
342  char_t buf[DUMP_BUF_SIZE];
343  int n;
344  float64_t x = FLOAT(a);
345  if( x==0 && signbit(x) ) x = 0;
346 
347  // remove trailing zeros and decimal point
348  if( (x>=1e23) || (x<=-1e23) || ((x>=-1e-23) && (x<=1e-23)) )
349  n = SPRINTF( buf, DUMP_BUF_SIZE, FORMAT_EXTRA_FP, x );
350  else
351  {
352  n = SPRINTF( buf, DUMP_BUF_SIZE, FORMAT_FP, x );
353 
354  //if( !buf[n-1] ) n--; // remove trailing null character (should not appear, but it does!)
355  while( buf[n-1]==L'0' ) n--; // remove trailing zero
356  if( buf[n-1]==L'.' ) n--; // remove default decimal point
357  if( (unsigned char)buf[n-1]<128
358  && buf[n-1]==*(locale_info->decimal_point) ) n--;
359  }
360 
361 
362  int limit = print_width_limit;
363 
364  if( 0<=limit && limit<10 ) limit=10;
365 
366  if( 0<=limit && limit<n )
367  {
368  outter( buf, limit );
369  outter( TEXT("..."), 3 );
370  outter_size += limit+3;
371  }
372  else
373  {
374  outter( buf, n );
375  outter_size += n;
376  }
377 
378 
379  #undef DUMP_BUF_SIZE
380 }
381 
382 
383 
384 
385 //===================================================
397 //===================================================
399 {
400  // test for unbound
401  if( IS_UNBOUND(a) )
402  {
403  return 0;
404  }
405 
406  // convert integer->float
407  if( IS_INTEGER(a) )
408  {
409  *np = INTEGER(a);
410  return 1;
411  }
412 
413  // convert float->float
414  if( IS_FLOAT(a) )
415  {
416  *np = FLOAT(a);
417  return 1;
418  }
419 
420  // fail if not a word
421  if( !IS_ANY_WORD(a) )
422  {
423  return 0;
424  }
425 
426  // convert word->float
427  int cnt = LENGTH(a);
428  chars_t ptr = STRING(a);
429  char_t chr = *(ptr+cnt);
430  char_t *end;
431  *(ptr+cnt) = TEXT('\0'); /* set artificial end of string */
432 
433  if( (*ptr==TEXT('0')) && ((*(ptr+1)==TEXT('x')) || (*(ptr+1)==TEXT('X'))))
434  { // it is a hex number
435  *np = STRTOL(ptr,&end);
436  }
437  else
438  { // it is a dec number
439  *np = STRTOD(ptr,&end);
440  }
441  *(ptr+cnt) = chr; /* recover the original string */
442 
443  // test for successful conversion
444  if( end-ptr==cnt ) return 1;
445 
446 
447  // test for infinities/nonanumbers in Windows
448 #ifdef WINDOWS
449  if( LENGTH(a)==3 &&
450  same_strings(1,STRING(a),TEXT("inf"),3) )
451  {
452  *np = INFINITY;
453  return 1;
454  }
455  if( LENGTH(a)==4 &&
456  same_strings(1,STRING(a),TEXT("-inf"),4) )
457  {
458  *np = -INFINITY;
459  return 1;
460  }
461  if( LENGTH(a)==3 &&
462  same_strings(1,STRING(a),TEXT("nan"),3) )
463  {
464  *np = NAN;
465  return 1;
466  }
467 #endif //WINDOWS
468 
469  return 0;
470 }
471 
472 
473 
474 
475 //===================================================
487 //===================================================
488 int atom_to_int( atom_t a, int64_t* np )
489 {
490  // test for unbound
491  if( IS_UNBOUND(a) )
492  {
493  return 0;
494  }
495 
496  // convert integer->float
497  if( IS_INTEGER(a) )
498  {
499  *np = INTEGER(a);
500  return 1;
501  }
502 
503  // convert float->float
504  if( IS_FLOAT(a) )
505  {
506  *np = FLOAT(a);
507  return abs(*np-FLOAT(a))<EPSILON;
508  }
509 
510  // fail if not a word
511  if( !IS_ANY_WORD(a) )
512  {
513  return 0;
514  }
515 
516  // convert word->float
517  int cnt = LENGTH(a);
518  chars_t ptr = STRING(a);
519  char_t chr = *(ptr+cnt);
520  char_t *end;
521  *(ptr+cnt) = TEXT('\0'); /* set artificial end of string */
522  *np = STRTOL(ptr,&end);
523  *(ptr+cnt) = chr; /* recover the original string */
524 
525  // test for successful conversion
526  if( end-ptr==cnt ) return 1;
527 
528  return 0;
529 }
530 
531 
532 
533 //===================================================
545 //===================================================
546 int atom_to_integer( atom_t a, int* np )
547 {
548  *np = -1;
549 
550  // test for unbound
551  if( IS_UNBOUND(a) )
552  {
553  return 0;
554  }
555 
556  // convert integer->float
557  if( IS_INTEGER(a) )
558  {
559  *np = INTEGER(a);
560  return 1;
561  }
562 
563  // convert float->float
564  if( IS_FLOAT(a) )
565  {
566  *np = FLOAT(a);
567  return abs(*np-FLOAT(a))<EPSILON;
568  }
569 
570  // fail if not a word
571  if( !IS_ANY_WORD(a) )
572  {
573  return 0;
574  }
575 
576  // convert word->float
577  int cnt = LENGTH(a);
578  chars_t ptr = STRING(a);
579  char_t chr = *(ptr+cnt);
580  char_t *end;
581  *(ptr+cnt) = TEXT('\0'); /* set artificial end of string */
582  *np = STRTOL(ptr,&end);
583  *(ptr+cnt) = chr; /* recover the original string */
584 
585  // test for successful conversion
586  if( end-ptr==cnt ) return 1;
587 
588  return 0;
589 }

[ HOME | INDEX | ATOMS | VARS | REFERENCE ]
Lhogho Developer's Documentation
Wed Jul 10 2013