8 extern double unirand(), gamma();
9 extern double normalcdf(), normalquant(), normaldens(), normalrand();
10 extern double bnormcdf();
11 extern double cauchycdf(), cauchyquant(), cauchydens(), cauchyrand();
12 extern double gammacdf(), gammaquant(), gammadens(), gammarand();
13 extern double chisqcdf(), chisqquant(), chisqdens(), chisqrand();
14 extern double betacdf(), betaquant(), betadens(), betarand();
15 extern double tcdf(), tquant(), tdens(), trand();
16 extern double fcdf(), fquant(), fdens(), frand();
17 extern double poissoncdf(), poissonpmf();
18 extern int poissonquant(), poissonrand();
19 extern double binomialcdf(), binomialpmf();
20 extern int binomialquant(), binomialrand();
24 extern int chol_decomp_front();
25 extern int lu_decomp_front();
26 extern int lu_solve_front();
27 extern int lu_inverse_front();
28 extern int sv_decomp_front();
29 extern int qr_decomp_front();
30 extern int rcondest_front();
31 extern int make_rotation_front();
32 extern int eigen_front();
33 extern int range_to_rseq();
34 extern int spline_front();
35 extern int kernel_dens_front();
36 extern int kernel_smooth_front();
37 extern int base_lowess_front();
38 extern int fft_front();
39 extern int numgrad_front();
40 extern int numhess_front();
41 extern int minfo_maximize();
43 /***********************************************************************/
44 /**** Basic Utilities ****/
45 /***********************************************************************/
47 /***********************************************************************/
48 /** Callback Support Functions **/
49 /***********************************************************************/
51 static int ccl_integer_value
;
52 static double ccl_double_value
;
53 static PTR ccl_ptr_value
;
54 void ccl_store_integer(int x
) { ccl_integer_value
= x
; }
55 void ccl_store_double(double x
) { ccl_double_value
= x
; }
56 void ccl_store_ptr(PTR x
) { ccl_ptr_value
= x
; }
58 /***************************************************************************/
59 /** Lisp-Managed Calloc/Free **/
60 /***************************************************************************/
63 static void (*new_ptr
)();
64 static void (*free_ptr
)();
66 register_new_ptr(f
) void (*f
)(); { new_ptr
= f
; }
67 register_free_ptr(f
) void (*f
)(); { free_ptr
= f
; }
76 p
= (char *) ccl_ptr_value
;
77 for (i
= 0; i
< N
; i
++) p
[i
] = 0;
81 malloc() { xlfail("malloc not available yet"); }
82 realloc() { xlfail("realloc not available yet"); }
91 /***************************************************************************/
93 /** Storage Allocation Functions **/
95 /***************************************************************************/
98 la_base_allocate(unsigned n
, unsigned m
)
100 char *p
= calloc(n
, m
);
101 if (p
== nil
) xlfail("allocation failed");
106 la_base_free_alloc(PTR p
)
108 if (p
) free((char *) p
);
113 la_mode_size(int mode
)
116 case IN
: return(sizeof(int));
117 case RE
: return(sizeof(double));
118 case CX
: return(sizeof(Complex
));
123 /***************************************************************************/
125 /** Callbacks for Internal Storage **/
127 /***************************************************************************/
129 int (*ccl_la_allocate
)(), (*ccl_la_free_alloc
)();
131 void register_la_allocate(f
) int (*f
)(); { ccl_la_allocate
= f
; }
132 void register_la_free_alloc(f
) int (*f
)(); { ccl_la_free_alloc
= f
; }
135 la_allocate(int n
, int m
)
137 (*ccl_la_allocate
)(n
, m
);
138 return(ccl_ptr_value
);
144 (*ccl_la_free_alloc
)(p
);
147 /***************************************************************************/
149 /** Storage Access Functions **/
151 /***************************************************************************/
154 la_get_integer(PTR p
, int i
)
156 return(*(((int *) p
) + i
));
160 la_get_double(PTR p
, int i
)
162 return(*(((double *) p
) + i
));
166 la_get_complex_real(PTR p
, int i
)
168 Complex
*c
= ((Complex
*) p
) + i
;
173 la_get_complex_imag(PTR p
, int i
)
175 Complex
*c
= ((Complex
*) p
) + i
;
180 la_get_pointer(PTR p
, int i
)
182 return(*(((PTR
*) p
) + i
));
185 /***************************************************************************/
187 /** Storage Mutation Functions **/
189 /***************************************************************************/
192 la_put_integer(PTR p
, int i
, int x
)
194 *(((int *) p
) + i
) = x
;
198 int la_put_double(PTR p
, int i
, double x
)
200 *(((double *) p
) + i
) = x
;
205 la_put_complex(PTR p
, int i
, double x
, double y
)
207 Complex
*c
= ((Complex
*) p
) + i
;
214 la_put_pointer(PTR p
, int i
, PTR x
)
216 *(((PTR
*) p
) + i
) = x
;
220 /***********************************************************************/
222 /** XLISP Internal Error Message Emulation **/
224 /***********************************************************************/
228 static int (*ccl_set_buf_char_fptr
)();
229 void register_set_buf_char(f
) int (*f
)(); { ccl_set_buf_char_fptr
= f
; }
230 void set_buf_char(int n
, int c
) { (*ccl_set_buf_char_fptr
)(n
, c
); }
232 static int (*ccl_print_buffer
)();
233 void register_print_buffer(f
) int (*f
)(); { ccl_print_buffer
= f
; }
234 void print_buffer(int n
, int m
) { (*ccl_print_buffer
)(n
, m
); }
236 static int bufpos
= 0;
250 for (i
= 0; i
<n
; i
++, bufpos
++) set_buf_char(bufpos
, s
[i
]);
251 set_buf_char(bufpos
, 0);
259 print_buffer(bufpos
, 1);
267 print_buffer(bufpos
, 0);
277 /***************************************************************************/
279 /***** Lisp Interfaces to Linear Algebra Routines ****/
281 /***************************************************************************/
284 ccl_chol_decomp_front(PTR mat
, int n
, PTR dpars
)
286 return(chol_decomp_front(mat
, n
, dpars
));
290 ccl_lu_decomp_front(PTR mat
, int n
, PTR iv
, int mode
, PTR dp
)
292 return(lu_decomp_front(mat
, n
, iv
, mode
, dp
));
296 ccl_lu_solve_front(PTR a
, int n
, PTR indx
, PTR b
, int mode
)
298 return(lu_solve_front(a
, n
, indx
, b
, mode
));
302 ccl_lu_inverse_front(PTR pmat
, int n
, PTR piv
, PTR pv
, int mode
, PTR pinv
)
304 return(lu_inverse_front(pmat
, n
, piv
, pv
, mode
, pinv
));
308 ccl_sv_decomp_front(PTR mat
, int m
, int n
, PTR w
, PTR v
)
310 return(sv_decomp_front(mat
, m
, n
, w
, v
));
315 ccl_qr_decomp_front(PTR mat
, int m
, int n
, PTR v
, PTR jpvt
, int pivot
)
317 return(qr_decomp_front(mat
, m
, n
, v
, jpvt
, pivot
));
321 ccl_rcondest_front(PTR mat
, int n
)
323 return(rcondest_front(mat
, n
));
327 ccl_make_rotation_front(int n
, PTR rot
, PTR x
, PTR y
, int use_alpha
, double alpha
)
329 return(make_rotation_front(n
, rot
, x
, y
, use_alpha
, alpha
));
333 ccl_eigen_front(PTR a
, int n
, PTR w
, PTR z
, PTR fv1
)
335 return(eigen_front(a
, n
, w
, z
, fv1
));
339 ccl_range_to_rseq(int n
, PTR px
, int ns
, PTR pxs
)
341 return(range_to_rseq(n
, px
, ns
, pxs
));
345 ccl_spline_front(int n
, PTR x
, PTR y
, int ns
, PTR xs
, PTR ys
, PTR work
)
347 return(spline_front(n
, x
, y
, ns
, xs
, ys
, work
));
351 ccl_kernel_dens_front(PTR x
, int n
, double width
, PTR xs
, PTR ys
, int ns
, int code
)
353 return(kernel_dens_front(x
, n
, width
, xs
, ys
, ns
, code
));
357 ccl_kernel_smooth_front(PTR x
, PTR y
, int n
, double width
, PTR xs
, PTR ys
, int ns
, int code
)
359 return(kernel_smooth_front(x
, y
, n
, width
, xs
, ys
, ns
, code
));
363 ccl_base_lowess_front(PTR x
, PTR y
, int n
, double f
,
364 int nsteps
, double delta
, PTR ys
, PTR rw
, PTR res
)
366 return(base_lowess_front(x
, y
, n
, f
, nsteps
, delta
, ys
, rw
, res
));
370 ccl_fft_front(int n
, PTR x
, PTR work
, int isign
)
372 return(fft_front(n
, x
, work
, isign
));
375 static int (*ccl_maximize_callback
)();
378 register_maximize_callback(f
)
381 ccl_maximize_callback
= f
;
385 maximize_callback(int n
, PTR px
, PTR pfval
, PTR pgrad
, PTR phess
, PTR pderivs
)
387 (*ccl_maximize_callback
)(n
, px
, pfval
, pgrad
, phess
, pderivs
);
391 ccl_numgrad_front(int n
, PTR px
, PTR pgrad
, double h
, PTR pscale
)
393 return(numgrad_front(n
, px
, pgrad
, h
, pscale
));
397 ccl_numhess_front(int n
, PTR px
, PTR pf
, PTR pgrad
, PTR phess
, double h
, PTR pscale
)
399 return(numhess_front(n
, px
, pf
, pgrad
, phess
, h
, pscale
));
403 ccl_minfo_maximize(PTR px
, PTR pfvals
, PTR pscale
, PTR pip
, PTR pdp
, int verbose
)
405 return(minfo_maximize(px
, pfvals
, pscale
, pip
, pdp
, verbose
));
408 /***********************************************************************/
409 /***********************************************************************/
411 /**** Probability Distributions ****/
413 /***********************************************************************/
414 /***********************************************************************/
416 static int (*ccl_uni_fptr
)();
417 void register_uni(f
) int (*f
)(); { ccl_uni_fptr
= f
; }
418 double uni() { (*ccl_uni_fptr
)(); return(ccl_double_value
); }
420 double ccl_gamma(double x
) { return(gamma(x
)); }
422 double ccl_normalcdf(double x
) { return(normalcdf(x
)); }
423 double ccl_normalquant(double x
) { return(normalquant(x
)); }
424 double ccl_normaldens(double x
) { return(normaldens(x
)); }
425 double ccl_normalrand() { return(normalrand()); }
426 double ccl_bnormcdf(double x
, double y
, double z
) {
427 return(bnormcdf(x
,y
,z
));
430 double ccl_cauchycdf(double x
) { return(cauchycdf(x
)); }
431 double ccl_cauchyquant(double x
) { return(cauchyquant(x
)); }
432 double ccl_cauchydens(double x
) { return(cauchydens(x
)); }
433 double ccl_cauchyrand() { return(cauchyrand()); }
435 double ccl_gammacdf(double x
, double y
) { return(gammacdf(x
, y
)); }
436 double ccl_gammaquant(double x
, double y
) { return(gammaquant(x
, y
)); }
437 double ccl_gammadens(double x
, double y
) { return(gammadens(x
, y
)); }
438 double ccl_gammarand(double x
) { return(gammarand(x
)); }
440 double ccl_chisqcdf(double x
, double y
) { return(chisqcdf(x
, y
)); }
441 double ccl_chisqquant(double x
, double y
) { return(chisqquant(x
, y
)); }
442 double ccl_chisqdens(double x
, double y
) { return(chisqdens(x
, y
)); }
443 double ccl_chisqrand(double x
) { return(chisqrand(x
)); }
445 double ccl_betacdf(double x
, double y
, double z
) { return(betacdf(x
, y
, z
)); }
446 double ccl_betaquant(double x
, double y
, double z
) { return(betaquant(x
, y
, z
)); }
447 double ccl_betadens(double x
, double y
, double z
) { return(betadens(x
, y
, z
)); }
448 double ccl_betarand(double x
, double y
) { return(betarand(x
, y
)); }
450 double ccl_tcdf(double x
, double y
) { return(tcdf(x
, y
)); }
451 double ccl_tquant(double x
, double y
) { return(tquant(x
, y
)); }
452 double ccl_tdens(double x
, double y
) { return(tdens(x
, y
)); }
453 double ccl_trand(double x
) { return(trand(x
)); }
455 double ccl_fcdf(double x
, double y
, double z
) { return(fcdf(x
, y
, z
)); }
456 double ccl_fquant(double x
, double y
, double z
) { return(fquant(x
, y
, z
)); }
457 double ccl_fdens(double x
, double y
, double z
) { return(fdens(x
, y
, z
)); }
458 double ccl_frand(double x
, double y
) { return(frand(x
, y
)); }
460 double ccl_poissoncdf(double x
, double y
) { return(poissoncdf(x
, y
)); }
461 int ccl_poissonquant(double x
, double y
) { return(poissonquant(x
, y
)); }
462 double ccl_poissonpmf(int x
, double y
) { return(poissonpmf(x
, y
)); }
463 int ccl_poissonrand(double x
) { return(poissonrand(x
)); }
465 double ccl_binomialcdf(double x
, int y
, double z
) { return(binomialcdf(x
, y
, z
)); }
466 int ccl_binomialquant(double x
, int y
, double z
) { return(binomialquant(x
, y
, z
)); }
467 double ccl_binomialpmf(int x
, int y
, double z
) { return(binomialpmf(x
, y
, z
)); }
468 int ccl_binomialrand(int x
, double y
) { return(binomialrand(x
, y
)); }