/***********************************************************************//* *//* OCaml *//* *//* Xavier Leroy, projet Cristal, INRIA Rocquencourt *//* *//* Copyright 1996 Institut National de Recherche en Informatique et *//* en Automatique. All rights reserved. This file is distributed *//* under the terms of the GNU Library General Public License, with *//* the special exception on linking described in file ../LICENSE. *//* *//***********************************************************************//* $Id$ *//* The interface of this file is in "mlvalues.h" and "alloc.h" */#include <math.h>#include <stdio.h>#include <stdlib.h>#include <string.h>#include "alloc.h"#include "fail.h"#include "memory.h"#include "mlvalues.h"#include "misc.h"#include "reverse.h"#include "stacks.h"#ifdef _MSC_VER#include <float.h>#define isnan _isnan#define isfinite _finite#endif#ifdef ARCH_ALIGN_DOUBLECAMLexportdoublecaml_Double_val(valueval){union{valuev[2];doubled;}buffer;Assert(sizeof(double)==2*sizeof(value));buffer.v[0]=Field(val,0);buffer.v[1]=Field(val,1);returnbuffer.d;}CAMLexportvoidcaml_Store_double_val(valueval,doubledbl){union{valuev[2];doubled;}buffer;Assert(sizeof(double)==2*sizeof(value));buffer.d=dbl;Field(val,0)=buffer.v[0];Field(val,1)=buffer.v[1];}#endifCAMLexportvaluecaml_copy_double(doubled){valueres;#define Setup_for_gc#define Restore_after_gcAlloc_small(res,Double_wosize,Double_tag);#undef Setup_for_gc#undef Restore_after_gcStore_double_val(res,d);returnres;}CAMLprimvaluecaml_format_float(valuefmt,valuearg){#define MAX_DIGITS 350/* Max number of decimal digits in a "natural" (not artificially padded) representation of a float. Can be quite big for %f format. Max exponent for IEEE format is 308 decimal digits. Rounded up for good measure. */charformat_buffer[MAX_DIGITS+20];intprec,i;char*p;char*dest;valueres;doubled=Double_val(arg);#ifdef HAS_BROKEN_PRINTFif(isfinite(d)){#endifprec=MAX_DIGITS;for(p=String_val(fmt);*p!=0;p++){if(*p>='0'&&*p<='9'){i=atoi(p)+MAX_DIGITS;if(i>prec)prec=i;break;}}for(;*p!=0;p++){if(*p=='.'){i=atoi(p+1)+MAX_DIGITS;if(i>prec)prec=i;break;}}if(prec<sizeof(format_buffer)){dest=format_buffer;}else{dest=caml_stat_alloc(prec);}sprintf(dest,String_val(fmt),d);res=caml_copy_string(dest);if(dest!=format_buffer){caml_stat_free(dest);}#ifdef HAS_BROKEN_PRINTF}else{if(isnan(d)){res=caml_copy_string("nan");}else{if(d>0){res=caml_copy_string("inf");}else{res=caml_copy_string("-inf");}}}#endifreturnres;}/*CAMLprim*/valuecaml_float_of_substring(valuevs,valueidx,valuel){charparse_buffer[64];char*buf,*src,*dst,*end;mlsize_tlen,lenvs;doubled;intnatflen=Long_val(l);intnatfidx=Long_val(idx);lenvs=caml_string_length(vs);len=fidx>=0&&fidx<lenvs&&flen>0&&flen<=lenvs-fidx?flen:0;buf=len<sizeof(parse_buffer)?parse_buffer:caml_stat_alloc(len+1);src=String_val(vs)+fidx;dst=buf;while(len--){charc=*src++;if(c!='_')*dst++=c;}*dst=0;if(dst==buf)gotoerror;d=strtod((constchar*)buf,&end);if(end!=dst)gotoerror;if(buf!=parse_buffer)caml_stat_free(buf);returncaml_copy_double(d);error:if(buf!=parse_buffer)caml_stat_free(buf);caml_failwith("float_of_string");}CAMLprimvaluecaml_float_of_string(valuevs){charparse_buffer[64];char*buf,*src,*dst,*end;mlsize_tlen;doubled;len=caml_string_length(vs);buf=len<sizeof(parse_buffer)?parse_buffer:caml_stat_alloc(len+1);src=String_val(vs);dst=buf;while(len--){charc=*src++;if(c!='_')*dst++=c;}*dst=0;if(dst==buf)gotoerror;d=strtod((constchar*)buf,&end);if(end!=dst)gotoerror;if(buf!=parse_buffer)caml_stat_free(buf);returncaml_copy_double(d);error:if(buf!=parse_buffer)caml_stat_free(buf);caml_failwith("float_of_string");}CAMLprimvaluecaml_int_of_float(valuef){returnVal_long((intnat)Double_val(f));}CAMLprimvaluecaml_float_of_int(valuen){returncaml_copy_double((double)Long_val(n));}CAMLprimvaluecaml_neg_float(valuef){returncaml_copy_double(-Double_val(f));}CAMLprimvaluecaml_abs_float(valuef){returncaml_copy_double(fabs(Double_val(f)));}CAMLprimvaluecaml_add_float(valuef,valueg){returncaml_copy_double(Double_val(f)+Double_val(g));}CAMLprimvaluecaml_sub_float(valuef,valueg){returncaml_copy_double(Double_val(f)-Double_val(g));}CAMLprimvaluecaml_mul_float(valuef,valueg){returncaml_copy_double(Double_val(f)*Double_val(g));}CAMLprimvaluecaml_div_float(valuef,valueg){returncaml_copy_double(Double_val(f)/Double_val(g));}CAMLprimvaluecaml_exp_float(valuef){returncaml_copy_double(exp(Double_val(f)));}CAMLprimvaluecaml_floor_float(valuef){returncaml_copy_double(floor(Double_val(f)));}CAMLprimvaluecaml_fmod_float(valuef1,valuef2){returncaml_copy_double(fmod(Double_val(f1),Double_val(f2)));}CAMLprimvaluecaml_frexp_float(valuef){CAMLparam1(f);CAMLlocal2(res,mantissa);intexponent;mantissa=caml_copy_double(frexp(Double_val(f),&exponent));res=caml_alloc_tuple(2);Field(res,0)=mantissa;Field(res,1)=Val_int(exponent);CAMLreturn(res);}CAMLprimvaluecaml_ldexp_float(valuef,valuei){returncaml_copy_double(ldexp(Double_val(f),Int_val(i)));}CAMLprimvaluecaml_log_float(valuef){returncaml_copy_double(log(Double_val(f)));}CAMLprimvaluecaml_log10_float(valuef){returncaml_copy_double(log10(Double_val(f)));}CAMLprimvaluecaml_modf_float(valuef){doublefrem;CAMLparam1(f);CAMLlocal3(res,quo,rem);quo=caml_copy_double(modf(Double_val(f),&frem));rem=caml_copy_double(frem);res=caml_alloc_tuple(2);Field(res,0)=quo;Field(res,1)=rem;CAMLreturn(res);}CAMLprimvaluecaml_sqrt_float(valuef){returncaml_copy_double(sqrt(Double_val(f)));}CAMLprimvaluecaml_power_float(valuef,valueg){returncaml_copy_double(pow(Double_val(f),Double_val(g)));}CAMLprimvaluecaml_sin_float(valuef){returncaml_copy_double(sin(Double_val(f)));}CAMLprimvaluecaml_sinh_float(valuef){returncaml_copy_double(sinh(Double_val(f)));}CAMLprimvaluecaml_cos_float(valuef){returncaml_copy_double(cos(Double_val(f)));}CAMLprimvaluecaml_cosh_float(valuef){returncaml_copy_double(cosh(Double_val(f)));}CAMLprimvaluecaml_tan_float(valuef){returncaml_copy_double(tan(Double_val(f)));}CAMLprimvaluecaml_tanh_float(valuef){returncaml_copy_double(tanh(Double_val(f)));}CAMLprimvaluecaml_asin_float(valuef){returncaml_copy_double(asin(Double_val(f)));}CAMLprimvaluecaml_acos_float(valuef){returncaml_copy_double(acos(Double_val(f)));}CAMLprimvaluecaml_atan_float(valuef){returncaml_copy_double(atan(Double_val(f)));}CAMLprimvaluecaml_atan2_float(valuef,valueg){returncaml_copy_double(atan2(Double_val(f),Double_val(g)));}CAMLprimvaluecaml_ceil_float(valuef){returncaml_copy_double(ceil(Double_val(f)));}CAMLexportdoublecaml_hypot(doublex,doubley){#ifdef HAS_C99_FLOAT_OPSreturnhypot(x,y);#elsedoubletmp,ratio;if(x!=x)returnx;/* NaN */if(y!=y)returny;/* NaN */x=fabs(x);y=fabs(y);if(x<y){tmp=x;x=y;y=tmp;}if(x==0.0)return0.0;ratio=y/x;returnx*sqrt(1.0+ratio*ratio);#endif}CAMLprimvaluecaml_hypot_float(valuef,valueg){returncaml_copy_double(caml_hypot(Double_val(f),Double_val(g)));}/* These emulations of expm1() and log1p() are due to William Kahan. See http://www.plunk.org/~hatch/rightway.php */CAMLexportdoublecaml_expm1(doublex){#ifdef HAS_C99_FLOAT_OPSreturnexpm1(x);#elsedoubleu=exp(x);if(u==1.)returnx;if(u-1.==-1.)return-1.;return(u-1.)*x/log(u);#endif}CAMLexportdoublecaml_log1p(doublex){#ifdef HAS_C99_FLOAT_OPSreturnlog1p(x);#elsedoubleu=1.+x;if(u==1.)returnx;elsereturnlog(u)*x/(u-1.);#endif}CAMLprimvaluecaml_expm1_float(valuef){returncaml_copy_double(caml_expm1(Double_val(f)));}CAMLprimvaluecaml_log1p_float(valuef){returncaml_copy_double(caml_log1p(Double_val(f)));}uniondouble_as_two_int32{doubled;#if defined(ARCH_BIG_ENDIAN) || (defined(__arm__) && !defined(__ARM_EABI__))struct{uint32h;uint32l;}i;#elsestruct{uint32l;uint32h;}i;#endif};CAMLexportdoublecaml_copysign(doublex,doubley){#ifdef HAS_C99_FLOAT_OPSreturncopysign(x,y);#elseuniondouble_as_two_int32ux,uy;ux.d=x;uy.d=y;ux.i.h&=0x7FFFFFFFU;ux.i.h|=(uy.i.h&0x80000000U);returnux.d;#endif}CAMLprimvaluecaml_copysign_float(valuef,valueg){returncaml_copy_double(caml_copysign(Double_val(f),Double_val(g)));}CAMLprimvaluecaml_eq_float(valuef,valueg){returnVal_bool(Double_val(f)==Double_val(g));}CAMLprimvaluecaml_neq_float(valuef,valueg){returnVal_bool(Double_val(f)!=Double_val(g));}CAMLprimvaluecaml_le_float(valuef,valueg){returnVal_bool(Double_val(f)<=Double_val(g));}CAMLprimvaluecaml_lt_float(valuef,valueg){returnVal_bool(Double_val(f)<Double_val(g));}CAMLprimvaluecaml_ge_float(valuef,valueg){returnVal_bool(Double_val(f)>=Double_val(g));}CAMLprimvaluecaml_gt_float(valuef,valueg){returnVal_bool(Double_val(f)>Double_val(g));}CAMLprimvaluecaml_float_compare(valuevf,valuevg){doublef=Double_val(vf);doubleg=Double_val(vg);if(f==g)returnVal_int(0);if(f<g)returnVal_int(-1);if(f>g)returnVal_int(1);/* One or both of f and g is NaN. Order according to the convention NaN = NaN and NaN < x for all other floats x. */if(f==f)returnVal_int(1);/* f is not NaN, g is NaN */if(g==g)returnVal_int(-1);/* g is not NaN, f is NaN */returnVal_int(0);/* both f and g are NaN */}enum{FP_normal,FP_subnormal,FP_zero,FP_infinite,FP_nan};CAMLprimvaluecaml_classify_float(valuevd){/* Cygwin 1.3 has problems with fpclassify (PR#1293), so don't use it */#if defined(fpclassify) && !defined(__CYGWIN32__) && !defined(__MINGW32__)switch(fpclassify(Double_val(vd))){caseFP_NAN:returnVal_int(FP_nan);caseFP_INFINITE:returnVal_int(FP_infinite);caseFP_ZERO:returnVal_int(FP_zero);caseFP_SUBNORMAL:returnVal_int(FP_subnormal);default:/* case FP_NORMAL */returnVal_int(FP_normal);}#elseuniondouble_as_two_int32u;uint32h,l;u.d=Double_val(vd);h=u.i.h;l=u.i.l;l=l|(h&0xFFFFF);h=h&0x7FF00000;if((h|l)==0)returnVal_int(FP_zero);if(h==0)returnVal_int(FP_subnormal);if(h==0x7FF00000){if(l==0)returnVal_int(FP_infinite);elsereturnVal_int(FP_nan);}returnVal_int(FP_normal);#endif}/* The [caml_init_ieee_float] function should initialize floating-point hardware so that it behaves as much as possible like the IEEE standard. In particular, return special numbers like Infinity and NaN instead of signalling exceptions. Currently, everyone is in IEEE mode at program startup, except FreeBSD prior to 4.0R. */#ifdef __FreeBSD__#include <osreldate.h>#if (__FreeBSD_version < 400017)#include <floatingpoint.h>#endif#endifvoidcaml_init_ieee_floats(void){#if defined(__FreeBSD__) && (__FreeBSD_version < 400017)fpsetmask(0);#endif}