lib/cffi-glue.c

   1 #ifdef __APPLE__
   2 #include <stdlib.h>
   3 #else
   4 #include <malloc.h>
   5 #endif
   6
   7 #include <string.h>
   8
   9 #include "linalg.h"
  10
  11 typedef char *PTR;
  12
  13 extern double unirand(), gamma();
  14 extern double normalcdf(), normalquant(), normaldens(), normalrand();
  15 extern double bnormcdf();
  16 extern double cauchycdf(), cauchyquant(), cauchydens(), cauchyrand();
  17 extern double gammacdf(), gammaquant(), gammadens(), gammarand();
  18 extern double chisqcdf(), chisqquant(), chisqdens(), chisqrand();
  19 extern double betacdf(), betaquant(), betadens(), betarand();
  20 extern double tcdf(), tquant(), tdens(), trand();
  21 extern double fcdf(), fquant(), fdens(), frand();
  22 extern double poissoncdf(), poissonpmf();
  23 extern int poissonquant(), poissonrand();
  24 extern double binomialcdf(), binomialpmf();
  25 extern int binomialquant(), binomialrand();
  26
  27 void xlfail(char *);
  28
  29 extern int chol_decomp_front();
  30 extern int lu_decomp_front();
  31 extern int lu_solve_front();
  32 extern int lu_inverse_front();
  33 extern int sv_decomp_front();
  34 extern int qr_decomp_front();
  35 extern int rcondest_front();
  36 extern int make_rotation_front();
  37 extern int eigen_front();
  38 extern int range_to_rseq();
  39 extern int spline_front();
  40 extern int kernel_dens_front();
  41 extern int kernel_smooth_front();
  42 extern int base_lowess_front();
  43 extern int fft_front();
  44 extern int numgrad_front();
  45 extern int numhess_front();
  46 extern int minfo_maximize();
  47
  48 /***********************************************************************/
  49 /****                        Basic Utilities                        ****/
  50 /***********************************************************************/
  51
  52 /***********************************************************************/
  53 /**                    Callback Support Functions                     **/
  54 /***********************************************************************/
  55
  56 static int ccl_integer_value;
  57 static double ccl_double_value;
  58 static PTR ccl_ptr_value;
  59 void ccl_store_integer(int x)  { ccl_integer_value = x; }
  60 void ccl_store_double(double x)  { ccl_double_value = x; }
  61 void ccl_store_ptr(PTR x) { ccl_ptr_value = x; }
  62
  63 /***************************************************************************/
  64 /**                       Lisp-Managed Calloc/Free                        **/
  65 /***************************************************************************/
  66
  67 #ifdef DODO
  68 static void (*new_ptr)();
  69 static void (*free_ptr)();
  70
  71 register_new_ptr(f) void (*f)(); { new_ptr = f; }
  72 register_free_ptr(f) void (*f)(); { free_ptr = f; }
  73
  74 char *calloc(n, m)
  75         int n, m;
  76 {
  77   int i, N = n * m;
  78   char *p;
  79
  80   (*new_ptr)(N);
  81   p = (char *) ccl_ptr_value;
  82   for (i = 0; i < N; i++) p[i] = 0;
  83   return(p);
  84 }
  85
  86 malloc() { xlfail("malloc not available yet"); }
  87 realloc() { xlfail("realloc not available yet"); }
  88
  89 void free(p)
  90         char *p;
  91 {
  92   (*free_ptr)(p);
  93 }
  94 #endif /* DODO*/
  95
  96 /***************************************************************************/
  97 /**                                                                       **/
  98 /**                     Storage Allocation Functions                      **/
  99 /**                                                                       **/
 100 /***************************************************************************/
 101
 102 PTR
 103 la_base_allocate(unsigned n, unsigned m)
 104 {
 105   char *p = calloc(n, m);
 106   if (p == nil) xlfail("allocation failed");
 107   return((PTR) p);
 108 }
 109
 110 int
 111 la_base_free_alloc(PTR p)
 112 {
 113   if (p) free((char *) p);
 114   return(0);
 115 }
 116
 117 int
 118 la_mode_size(int mode)
 119 {
 120   switch (mode) {
 121   case IN: return(sizeof(int));
 122   case RE: return(sizeof(double));
 123   case CX: return(sizeof(Complex));
 124   }
 125   return(0);
 126 }
 127
 128 /***************************************************************************/
 129 /**                                                                       **/
 130 /**                    Callbacks for Internal Storage                     **/
 131 /**                                                                       **/
 132 /***************************************************************************/
 133
 134 int (*ccl_la_allocate)(), (*ccl_la_free_alloc)();
 135
 136 void register_la_allocate(f) int (*f)(); { ccl_la_allocate = f; }
 137 void register_la_free_alloc(f) int (*f)(); { ccl_la_free_alloc = f; }
 138
 139 PTR
 140 la_allocate(int n, int m)
 141 {
 142   (*ccl_la_allocate)(n, m);
 143   return(ccl_ptr_value);
 144 }
 145
 146 void
 147 la_free_alloc(PTR p)
 148 {
 149   (*ccl_la_free_alloc)(p);
 150 }
 151
 152 /***************************************************************************/
 153 /**                                                                       **/
 154 /**                     Storage Access Functions                          **/
 155 /**                                                                       **/
 156 /***************************************************************************/
 157
 158 int
 159 la_get_integer(PTR p, int i)
 160 {
 161   return(*(((int *) p) + i));
 162 }
 163
 164 double
 165 la_get_double(PTR p, int i)
 166 {
 167   return(*(((double *) p) + i));
 168 }
 169
 170 double
 171 la_get_complex_real(PTR p, int i)
 172 {
 173   Complex *c = ((Complex *) p) + i;
 174   return(c->real);
 175 }
 176
 177 double
 178 la_get_complex_imag(PTR p, int i)
 179 {
 180   Complex *c = ((Complex *) p) + i;
 181   return(c->imag);
 182 }
 183
 184 PTR
 185 la_get_pointer(PTR p, int i)
 186 {
 187   return(*(((PTR *) p) + i));
 188 }
 189
 190 /***************************************************************************/
 191 /**                                                                       **/
 192 /**                     Storage Mutation Functions                        **/
 193 /**                                                                       **/
 194 /***************************************************************************/
 195
 196 int
 197 la_put_integer(PTR p, int i, int x)
 198 {
 199   *(((int *) p) + i) = x;
 200   return(0);
 201 }
 202
 203 int la_put_double(PTR p, int i, double x)
 204 {
 205   *(((double *) p) + i) = x;
 206   return(0);
 207 }
 208
 209 int
 210 la_put_complex(PTR p, int i, double x, double y)
 211 {
 212   Complex *c = ((Complex *) p) + i;
 213   c->real = x;
 214   c->imag = y;
 215   return(0);
 216 }
 217
 218 int
 219 la_put_pointer(PTR p, int i, PTR x)
 220 {
 221   *(((PTR *) p) + i) = x;
 222   return(0);
 223 }
 224
 225 /***********************************************************************/
 226 /**                                                                   **/
 227 /**               XLISP Internal Error Message Emulation              **/
 228 /**                                                                   **/
 229 /***********************************************************************/
 230
 231 char buf[1000];
 232
 233 static int (*ccl_set_buf_char_fptr)();
 234 void register_set_buf_char(f) int (*f)(); { ccl_set_buf_char_fptr = f; }
 235 void set_buf_char(int n, int c)  { (*ccl_set_buf_char_fptr)(n, c); }
 236
 237 static int (*ccl_print_buffer)();
 238 void register_print_buffer(f) int (*f)(); { ccl_print_buffer = f; }
 239 void print_buffer(int n, int m) { (*ccl_print_buffer)(n, m); }
 240
 241 static int bufpos = 0;
 242
 243 static void
 244 resetbuf()
 245 {
 246   bufpos = 0;
 247 }
 248
 249 static void
 250 prbuf(char *s)
 251 {
 252   int i, n;
 253
 254   n = strlen(s);
 255   for (i = 0; i <n; i++, bufpos++) set_buf_char(bufpos, s[i]);
 256   set_buf_char(bufpos, 0);
 257 }
 258
 259 void
 260 xlfail(char *s)
 261 {
 262   resetbuf();
 263   prbuf(s);
 264   print_buffer(bufpos, 1);
 265 }
 266
 267 void
 268 stdputstr(char *s)
 269 {
 270   resetbuf();
 271   prbuf(s);
 272   print_buffer(bufpos, 0);
 273 }
 274
 275 void
 276 bufputstr(char *s)
 277 {
 278   resetbuf();
 279   prbuf(s);
 280 }
 281
 282 /***************************************************************************/
 283 /****                                                                   ****/
 284 /*****             Lisp Interfaces to Linear Algebra Routines           ****/
 285 /****                                                                   ****/
 286 /***************************************************************************/
 287
 288 int
 289 ccl_chol_decomp_front(PTR mat, int n, PTR dpars)
 290 {
 291   return(chol_decomp_front(mat, n, dpars));
 292 }
 293
 294 int
 295 ccl_lu_decomp_front(PTR mat, int n, PTR iv, int mode, PTR dp)
 296 {
 297   return(lu_decomp_front(mat, n, iv, mode, dp));
 298 }
 299
 300 int
 301 ccl_lu_solve_front(PTR a, int n, PTR indx, PTR b, int mode)
 302 {
 303   return(lu_solve_front(a, n, indx, b, mode));
 304 }
 305
 306 int
 307 ccl_lu_inverse_front(PTR pmat, int n, PTR piv, PTR pv, int mode, PTR pinv)
 308 {
 309   return(lu_inverse_front(pmat, n, piv, pv, mode, pinv));
 310 }
 311
 312 int
 313 ccl_sv_decomp_front(PTR mat, int m, int n, PTR w, PTR v)
 314 {
 315   return(sv_decomp_front(mat, m, n, w, v));
 316 }
 317
 318
 319 int
 320 ccl_qr_decomp_front(PTR mat, int m, int n, PTR v, PTR jpvt, int pivot)
 321 {
 322   return(qr_decomp_front(mat, m, n, v, jpvt, pivot));
 323 }
 324
 325 double
 326 ccl_rcondest_front(PTR mat, int n)
 327 {
 328   return(rcondest_front(mat, n));
 329 }
 330
 331 int
 332 ccl_make_rotation_front(int n, PTR rot, PTR x, PTR y, int use_alpha, double alpha)
 333 {
 334   return(make_rotation_front(n, rot, x, y, use_alpha, alpha));
 335 }
 336
 337 int
 338 ccl_eigen_front(PTR a, int n, PTR w, PTR z, PTR fv1)
 339 {
 340   return(eigen_front(a, n, w, z, fv1));
 341 }
 342
 343 int
 344 ccl_range_to_rseq(int n, PTR px, int ns, PTR pxs)
 345 {
 346   return(range_to_rseq(n, px, ns, pxs));
 347 }
 348
 349 int
 350 ccl_spline_front(int n, PTR x, PTR y, int ns, PTR xs, PTR ys, PTR work)
 351 {
 352   return(spline_front(n, x, y, ns, xs, ys, work));
 353 }
 354
 355 int
 356 ccl_kernel_dens_front(PTR x, int n, double width, PTR xs, PTR ys, int ns, int code)
 357 {
 358   return(kernel_dens_front(x, n, width, xs, ys, ns, code));
 359 }
 360
 361 int
 362 ccl_kernel_smooth_front(PTR x, PTR y, int n, double width, PTR xs, PTR ys, int ns, int code)
 363 {
 364   return(kernel_smooth_front(x, y, n, width, xs, ys, ns, code));
 365 }
 366
 367 int
 368 ccl_base_lowess_front(PTR x, PTR y, int n, double f,
 369                       int nsteps, double delta, PTR ys, PTR rw, PTR res)
 370 {
 371   return(base_lowess_front(x, y, n, f, nsteps, delta, ys, rw, res));
 372 }
 373
 374 int
 375 ccl_fft_front(int n, PTR x, PTR work, int isign)
 376 {
 377   return(fft_front(n, x, work, isign));
 378 }
 379
 380 static int (*ccl_maximize_callback)();
 381
 382 void
 383 register_maximize_callback(f)
 384      int (*f)();
 385 {
 386   ccl_maximize_callback = f;
 387 }
 388
 389 void
 390 maximize_callback(int n, PTR px, PTR pfval, PTR pgrad, PTR phess, PTR pderivs)
 391 {
 392   (*ccl_maximize_callback)(n, px, pfval, pgrad, phess, pderivs);
 393 }
 394
 395 int
 396 ccl_numgrad_front(int n, PTR px, PTR pgrad, double h, PTR pscale)
 397 {
 398   return(numgrad_front(n, px, pgrad, h, pscale));
 399 }
 400
 401 int
 402 ccl_numhess_front(int n, PTR px, PTR pf, PTR pgrad, PTR phess, double h, PTR pscale)
 403 {
 404   return(numhess_front(n, px, pf, pgrad, phess, h, pscale));
 405 }
 406
 407 int
 408 ccl_minfo_maximize(PTR px, PTR pfvals, PTR pscale, PTR pip, PTR pdp, int verbose)
 409 {
 410   return(minfo_maximize(px, pfvals, pscale, pip, pdp, verbose));
 411 }
 412
 413 /***********************************************************************/
 414 /***********************************************************************/
 415 /****                                                               ****/
 416 /****                   Probability Distributions                   ****/
 417 /****                                                               ****/
 418 /***********************************************************************/
 419 /***********************************************************************/
 420
 421 static int (*ccl_uni_fptr)();
 422 void register_uni(f) int (*f)(); { ccl_uni_fptr = f; }
 423 double uni() { (*ccl_uni_fptr)(); return(ccl_double_value); }
 424
 425 double ccl_gamma(double x) { return(gamma(x)); }
 426
 427 double ccl_normalcdf(double x)  { return(normalcdf(x)); }
 428 double ccl_normalquant(double x) { return(normalquant(x)); }
 429 double ccl_normaldens(double x) { return(normaldens(x)); }
 430 double ccl_normalrand() { return(normalrand()); }
 431 double ccl_bnormcdf(double x, double y, double z)  {
 432   return(bnormcdf(x,y,z));
 433 }
 434
 435 double ccl_cauchycdf(double x)  { return(cauchycdf(x)); }
 436 double ccl_cauchyquant(double x)  { return(cauchyquant(x)); }
 437 double ccl_cauchydens(double x)  { return(cauchydens(x)); }
 438 double ccl_cauchyrand() { return(cauchyrand()); }
 439
 440 double ccl_gammacdf(double x, double y)  { return(gammacdf(x, y)); }
 441 double ccl_gammaquant(double x, double y)  { return(gammaquant(x, y)); }
 442 double ccl_gammadens(double x, double y)  { return(gammadens(x, y)); }
 443 double ccl_gammarand(double x)  { return(gammarand(x)); }
 444
 445 double ccl_chisqcdf(double x, double y)  { return(chisqcdf(x, y)); }
 446 double ccl_chisqquant(double x, double y)  { return(chisqquant(x, y)); }
 447 double ccl_chisqdens(double x, double y)  { return(chisqdens(x, y)); }
 448 double ccl_chisqrand(double x)  { return(chisqrand(x)); }
 449
 450 double ccl_betacdf(double x, double y, double z)  { return(betacdf(x, y, z)); }
 451 double ccl_betaquant(double x, double y, double z)  { return(betaquant(x, y, z)); }
 452 double ccl_betadens(double x, double y, double z)  { return(betadens(x, y, z)); }
 453 double ccl_betarand(double x, double y)  { return(betarand(x, y)); }
 454
 455 double ccl_tcdf(double x, double y)  { return(tcdf(x, y)); }
 456 double ccl_tquant(double x, double y)  { return(tquant(x, y)); }
 457 double ccl_tdens(double x, double y)  { return(tdens(x, y)); }
 458 double ccl_trand(double x)  { return(trand(x)); }
 459
 460 double ccl_fcdf(double x, double y, double z)  { return(fcdf(x, y, z)); }
 461 double ccl_fquant(double x, double y, double z)  { return(fquant(x, y, z)); }
 462 double ccl_fdens(double x, double y, double z)  { return(fdens(x, y, z)); }
 463 double ccl_frand(double x, double y)  { return(frand(x, y)); }
 464
 465 double ccl_poissoncdf(double x, double y)  { return(poissoncdf(x, y)); }
 466 int ccl_poissonquant(double x, double y)  { return(poissonquant(x, y)); }
 467 double ccl_poissonpmf(int x, double y)  { return(poissonpmf(x, y)); }
 468 int ccl_poissonrand(double x)  { return(poissonrand(x)); }
 469
 470 double ccl_binomialcdf(double x, int y, double z) { return(binomialcdf(x, y, z)); }
 471 int ccl_binomialquant(double x, int y, double z) { return(binomialquant(x, y, z)); }
 472 double ccl_binomialpmf(int x, int y, double z)  { return(binomialpmf(x, y, z)); }
 473 int ccl_binomialrand(int x, double y)  { return(binomialrand(x, y)); }