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();
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();
48 /***********************************************************************/
49 /**** Basic Utilities ****/
50 /***********************************************************************/
52 /***********************************************************************/
53 /** Callback Support Functions **/
54 /***********************************************************************/
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
; }
63 /***************************************************************************/
64 /** Lisp-Managed Calloc/Free **/
65 /***************************************************************************/
68 static void (*new_ptr
)();
69 static void (*free_ptr
)();
71 register_new_ptr(f
) void (*f
)(); { new_ptr
= f
; }
72 register_free_ptr(f
) void (*f
)(); { free_ptr
= f
; }
81 p
= (char *) ccl_ptr_value
;
82 for (i
= 0; i
< N
; i
++) p
[i
] = 0;
86 malloc() { xlfail("malloc not available yet"); }
87 realloc() { xlfail("realloc not available yet"); }
96 /***************************************************************************/
98 /** Storage Allocation Functions **/
100 /***************************************************************************/
103 la_base_allocate(unsigned n
, unsigned m
)
105 char *p
= calloc(n
, m
);
106 if (p
== nil
) xlfail("allocation failed");
111 la_base_free_alloc(PTR p
)
113 if (p
) free((char *) p
);
118 la_mode_size(int mode
)
121 case IN
: return(sizeof(int));
122 case RE
: return(sizeof(double));
123 case CX
: return(sizeof(Complex
));
128 /***************************************************************************/
130 /** Callbacks for Internal Storage **/
132 /***************************************************************************/
134 int (*ccl_la_allocate
)(), (*ccl_la_free_alloc
)();
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
; }
140 la_allocate(int n
, int m
)
142 (*ccl_la_allocate
)(n
, m
);
143 return(ccl_ptr_value
);
149 (*ccl_la_free_alloc
)(p
);
152 /***************************************************************************/
154 /** Storage Access Functions **/
156 /***************************************************************************/
159 la_get_integer(PTR p
, int i
)
161 return(*(((int *) p
) + i
));
165 la_get_double(PTR p
, int i
)
167 return(*(((double *) p
) + i
));
171 la_get_complex_real(PTR p
, int i
)
173 Complex
*c
= ((Complex
*) p
) + i
;
178 la_get_complex_imag(PTR p
, int i
)
180 Complex
*c
= ((Complex
*) p
) + i
;
185 la_get_pointer(PTR p
, int i
)
187 return(*(((PTR
*) p
) + i
));
190 /***************************************************************************/
192 /** Storage Mutation Functions **/
194 /***************************************************************************/
197 la_put_integer(PTR p
, int i
, int x
)
199 *(((int *) p
) + i
) = x
;
203 int la_put_double(PTR p
, int i
, double x
)
205 *(((double *) p
) + i
) = x
;
210 la_put_complex(PTR p
, int i
, double x
, double y
)
212 Complex
*c
= ((Complex
*) p
) + i
;
219 la_put_pointer(PTR p
, int i
, PTR x
)
221 *(((PTR
*) p
) + i
) = x
;
225 /***********************************************************************/
227 /** XLISP Internal Error Message Emulation **/
229 /***********************************************************************/
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
); }
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
); }
241 static int bufpos
= 0;
255 for (i
= 0; i
<n
; i
++, bufpos
++) set_buf_char(bufpos
, s
[i
]);
256 set_buf_char(bufpos
, 0);
264 print_buffer(bufpos
, 1);
272 print_buffer(bufpos
, 0);
282 /***************************************************************************/
284 /***** Lisp Interfaces to Linear Algebra Routines ****/
286 /***************************************************************************/
289 ccl_chol_decomp_front(PTR mat
, int n
, PTR dpars
)
291 return(chol_decomp_front(mat
, n
, dpars
));
295 ccl_lu_decomp_front(PTR mat
, int n
, PTR iv
, int mode
, PTR dp
)
297 return(lu_decomp_front(mat
, n
, iv
, mode
, dp
));
301 ccl_lu_solve_front(PTR a
, int n
, PTR indx
, PTR b
, int mode
)
303 return(lu_solve_front(a
, n
, indx
, b
, mode
));
307 ccl_lu_inverse_front(PTR pmat
, int n
, PTR piv
, PTR pv
, int mode
, PTR pinv
)
309 return(lu_inverse_front(pmat
, n
, piv
, pv
, mode
, pinv
));
313 ccl_sv_decomp_front(PTR mat
, int m
, int n
, PTR w
, PTR v
)
315 return(sv_decomp_front(mat
, m
, n
, w
, v
));
320 ccl_qr_decomp_front(PTR mat
, int m
, int n
, PTR v
, PTR jpvt
, int pivot
)
322 return(qr_decomp_front(mat
, m
, n
, v
, jpvt
, pivot
));
326 ccl_rcondest_front(PTR mat
, int n
)
328 return(rcondest_front(mat
, n
));
332 ccl_make_rotation_front(int n
, PTR rot
, PTR x
, PTR y
, int use_alpha
, double alpha
)
334 return(make_rotation_front(n
, rot
, x
, y
, use_alpha
, alpha
));
338 ccl_eigen_front(PTR a
, int n
, PTR w
, PTR z
, PTR fv1
)
340 return(eigen_front(a
, n
, w
, z
, fv1
));
344 ccl_range_to_rseq(int n
, PTR px
, int ns
, PTR pxs
)
346 return(range_to_rseq(n
, px
, ns
, pxs
));
350 ccl_spline_front(int n
, PTR x
, PTR y
, int ns
, PTR xs
, PTR ys
, PTR work
)
352 return(spline_front(n
, x
, y
, ns
, xs
, ys
, work
));
356 ccl_kernel_dens_front(PTR x
, int n
, double width
, PTR xs
, PTR ys
, int ns
, int code
)
358 return(kernel_dens_front(x
, n
, width
, xs
, ys
, ns
, code
));
362 ccl_kernel_smooth_front(PTR x
, PTR y
, int n
, double width
, PTR xs
, PTR ys
, int ns
, int code
)
364 return(kernel_smooth_front(x
, y
, n
, width
, xs
, ys
, ns
, code
));
368 ccl_base_lowess_front(PTR x
, PTR y
, int n
, double f
,
369 int nsteps
, double delta
, PTR ys
, PTR rw
, PTR res
)
371 return(base_lowess_front(x
, y
, n
, f
, nsteps
, delta
, ys
, rw
, res
));
375 ccl_fft_front(int n
, PTR x
, PTR work
, int isign
)
377 return(fft_front(n
, x
, work
, isign
));
380 static int (*ccl_maximize_callback
)();
383 register_maximize_callback(f
)
386 ccl_maximize_callback
= f
;
390 maximize_callback(int n
, PTR px
, PTR pfval
, PTR pgrad
, PTR phess
, PTR pderivs
)
392 (*ccl_maximize_callback
)(n
, px
, pfval
, pgrad
, phess
, pderivs
);
396 ccl_numgrad_front(int n
, PTR px
, PTR pgrad
, double h
, PTR pscale
)
398 return(numgrad_front(n
, px
, pgrad
, h
, pscale
));
402 ccl_numhess_front(int n
, PTR px
, PTR pf
, PTR pgrad
, PTR phess
, double h
, PTR pscale
)
404 return(numhess_front(n
, px
, pf
, pgrad
, phess
, h
, pscale
));
408 ccl_minfo_maximize(PTR px
, PTR pfvals
, PTR pscale
, PTR pip
, PTR pdp
, int verbose
)
410 return(minfo_maximize(px
, pfvals
, pscale
, pip
, pdp
, verbose
));
413 /***********************************************************************/
414 /***********************************************************************/
416 /**** Probability Distributions ****/
418 /***********************************************************************/
419 /***********************************************************************/
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
); }
425 double ccl_gamma(double x
) { return(gamma(x
)); }
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
));
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()); }
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
)); }
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
)); }
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
)); }
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
)); }
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
)); }
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
)); }
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
)); }