5 extern double unirand(), gamma();
6 extern double normalcdf(), normalquant(), normaldens(), normalrand();
7 extern double bnormcdf();
8 extern double cauchycdf(), cauchyquant(), cauchydens(), cauchyrand();
9 extern double gammacdf(), gammaquant(), gammadens(), gammarand();
10 extern double chisqcdf(), chisqquant(), chisqdens(), chisqrand();
11 extern double betacdf(), betaquant(), betadens(), betarand();
12 extern double tcdf(), tquant(), tdens(), trand();
13 extern double fcdf(), fquant(), fdens(), frand();
14 extern double poissoncdf(), poissonpmf();
15 extern int poissonquant(), poissonrand();
16 extern double binomialcdf(), binomialpmf();
17 extern int binomialquant(), binomialrand();
19 /***********************************************************************/
20 /***********************************************************************/
22 /**** Basic Utilities ****/
24 /***********************************************************************/
25 /***********************************************************************/
27 /***********************************************************************/
29 /** Callback Support Functions **/
31 /***********************************************************************/
33 static int ccl_integer_value
;
34 static double ccl_double_value
;
35 static PTR ccl_ptr_value
;
36 ccl_store_integer(x
) int x
; { ccl_integer_value
= x
; }
37 ccl_store_double(x
) double x
; { ccl_double_value
= x
; }
38 ccl_store_ptr(x
) PTR x
; { ccl_ptr_value
= x
; }
40 /***************************************************************************/
42 /** Lisp-Managed Calloc/Free **/
44 /***************************************************************************/
47 static void (*new_ptr
)();
48 static void (*free_ptr
)();
50 register_new_ptr(f
) void (*f
)(); { new_ptr
= f
; }
51 register_free_ptr(f
) void (*f
)(); { free_ptr
= f
; }
60 p
= (char *) ccl_ptr_value
;
61 for (i
= 0; i
< N
; i
++) p
[i
] = 0;
65 malloc() { xlfail("malloc not available yet"); }
66 realloc() { xlfail("realloc not available yet"); }
75 /***************************************************************************/
77 /** Storage Allocation Functions **/
79 /***************************************************************************/
81 PTR
la_base_allocate(n
, m
)
84 char *p
= calloc(n
, m
);
85 if (p
== nil
) xlfail("allocation failed");
89 int la_base_free_alloc(p
)
92 if (p
) free((char *) p
);
96 int la_mode_size(mode
)
100 case IN
: return(sizeof(int));
101 case RE
: return(sizeof(double));
102 case CX
: return(sizeof(Complex
));
107 /***************************************************************************/
109 /** Callbacks for Internal Storage **/
111 /***************************************************************************/
113 int (*ccl_la_allocate
)(), (*ccl_la_free_alloc
)();
115 register_la_allocate(f
) int (*f
)(); { ccl_la_allocate
= f
; }
116 register_la_free_alloc(f
) int (*f
)(); { ccl_la_free_alloc
= f
; }
118 PTR
la_allocate(n
, m
)
121 (*ccl_la_allocate
)(n
, m
);
122 return(ccl_ptr_value
);
128 (*ccl_la_free_alloc
)(p
);
131 /***************************************************************************/
133 /** Storage Access Functions **/
135 /***************************************************************************/
137 int la_get_integer(p
, i
)
141 return(*(((int *) p
) + i
));
144 double la_get_double(p
, i
)
148 return(*(((double *) p
) + i
));
151 double la_get_complex_real(p
, i
)
155 Complex
*c
= ((Complex
*) p
) + i
;
159 double la_get_complex_imag(p
, i
)
163 Complex
*c
= ((Complex
*) p
) + i
;
167 PTR
la_get_pointer(p
, i
)
171 return(*(((PTR
*) p
) + i
));
174 /***************************************************************************/
176 /** Storage Mutation Functions **/
178 /***************************************************************************/
180 int la_put_integer(p
, i
, x
)
184 *(((int *) p
) + i
) = x
;
188 int la_put_double(p
, i
, x
)
193 *(((double *) p
) + i
) = x
;
197 int la_put_complex(p
, i
, x
, y
)
202 Complex
*c
= ((Complex
*) p
) + i
;
208 int la_put_pointer(p
, i
, x
)
212 *(((PTR
*) p
) + i
) = x
;
216 /***********************************************************************/
218 /** XLISP Internal Error Message Emulation **/
220 /***********************************************************************/
224 static int (*ccl_set_buf_char_fptr
)();
225 register_set_buf_char(f
) int (*f
)(); { ccl_set_buf_char_fptr
= f
; }
226 set_buf_char(n
, c
) int n
, c
; { (*ccl_set_buf_char_fptr
)(n
, c
); }
228 static int (*ccl_print_buffer
)();
229 register_print_buffer(f
) int (*f
)(); { ccl_print_buffer
= f
; }
230 print_buffer(n
, m
) int n
, m
; { (*ccl_print_buffer
)(n
, m
); }
232 static int bufpos
= 0;
234 static resetbuf() { bufpos
= 0; }
242 for (i
= 0; i
<n
; i
++, bufpos
++) set_buf_char(bufpos
, s
[i
]);
243 set_buf_char(bufpos
, 0);
251 print_buffer(bufpos
, 1);
259 print_buffer(bufpos
, 0);
269 /***************************************************************************/
270 /***************************************************************************/
272 /***** Lisp Interfaces to Linear Algebra Routines ****/
274 /***************************************************************************/
275 /***************************************************************************/
277 ccl_chol_decomp_front(mat
, n
, dpars
)
281 return(chol_decomp_front(mat
, n
, dpars
));
284 ccl_lu_decomp_front(mat
, n
, iv
, mode
, dp
)
288 return(lu_decomp_front(mat
, n
, iv
, mode
, dp
));
291 ccl_lu_solve_front(a
, n
, indx
, b
, mode
)
295 return(lu_solve_front(a
, n
, indx
, b
, mode
));
298 ccl_lu_inverse_front(pmat
, n
, piv
, pv
, mode
, pinv
)
299 PTR pmat
, piv
, pv
, pinv
;
302 return(lu_inverse_front(pmat
, n
, piv
, pv
, mode
, pinv
));
305 ccl_sv_decomp_front(mat
, m
, n
, w
, v
)
309 return(sv_decomp_front(mat
, m
, n
, w
, v
));
312 ccl_qr_decomp_front(mat
, m
, n
, v
, jpvt
, pivot
)
316 return(qr_decomp_front(mat
, m
, n
, v
, jpvt
, pivot
));
319 double ccl_rcondest_front(mat
, n
)
323 return(rcondest_front(mat
, n
));
326 ccl_make_rotation_front(n
, rot
, x
, y
, use_alpha
, alpha
)
331 return(make_rotation_front(n
, rot
, x
, y
, use_alpha
, alpha
));
334 ccl_eigen_front(a
, n
, w
, z
, fv1
)
338 return(eigen_front(a
, n
, w
, z
, fv1
));
341 ccl_range_to_rseq(n
, px
, ns
, pxs
)
345 return(range_to_rseq(n
, px
, ns
, pxs
));
348 ccl_spline_front(n
, x
, y
, ns
, xs
, ys
, work
)
349 PTR x
, y
, xs
, ys
, work
;
352 return(spline_front(n
, x
, y
, ns
, xs
, ys
, work
));
355 ccl_kernel_dens_front(x
, n
, width
, xs
, ys
, ns
, code
)
360 return(kernel_dens_front(x
, n
, width
, xs
, ys
, ns
, code
));
363 ccl_kernel_smooth_front(x
, y
, n
, width
, xs
, ys
, ns
, code
)
368 return(kernel_smooth_front(x
, y
, n
, width
, xs
, ys
, ns
, code
));
371 ccl_base_lowess_front(x
, y
, n
, f
, nsteps
, delta
, ys
, rw
, res
)
372 PTR x
, y
, ys
, rw
, res
;
376 return(base_lowess_front(x
, y
, n
, f
, nsteps
, delta
, ys
, rw
, res
));
379 ccl_fft_front(n
, x
, work
, isign
)
383 return(fft_front(n
, x
, work
, isign
));
386 static int (*ccl_maximize_callback
)();
387 register_maximize_callback(f
) int (*f
)(); { ccl_maximize_callback
= f
; }
388 maximize_callback(n
, px
, pfval
, pgrad
, phess
, pderivs
)
390 PTR px
, pfval
, pgrad
, phess
, pderivs
;
392 (*ccl_maximize_callback
)(n
, px
, pfval
, pgrad
, phess
, pderivs
);
395 ccl_numgrad_front(n
, px
, pgrad
, h
, pscale
)
397 PTR px
, pgrad
, pscale
;
400 return(numgrad_front(n
, px
, pgrad
, h
, pscale
));
403 ccl_numhess_front(n
, px
, pf
, pgrad
, phess
, h
, pscale
)
405 PTR px
, pf
, pgrad
, phess
, pscale
;
408 return(numhess_front(n
, px
, pf
, pgrad
, phess
, h
, pscale
));
411 ccl_minfo_maximize(px
, pfvals
, pscale
, pip
, pdp
, verbose
)
412 PTR px
, pfvals
, pscale
, pip
, pdp
;
415 return(minfo_maximize(px
, pfvals
, pscale
, pip
, pdp
, verbose
));
418 /***********************************************************************/
419 /***********************************************************************/
421 /**** Probability Distributions ****/
423 /***********************************************************************/
424 /***********************************************************************/
426 static int (*ccl_uni_fptr
)();
427 register_uni(f
) int (*f
)(); { ccl_uni_fptr
= f
; }
428 double uni() { (*ccl_uni_fptr
)(); return(ccl_double_value
); }
430 double ccl_gamma(x
) double x
; { return(gamma(x
)); }
432 double ccl_normalcdf(x
) double x
; { return(normalcdf(x
)); }
433 double ccl_normalquant(x
) double x
; { return(normalquant(x
)); }
434 double ccl_normaldens(x
) double x
; { return(normaldens(x
)); }
435 double ccl_normalrand() { return(normalrand()); }
436 double ccl_bnormcdf(x
, y
, z
) double x
, y
, z
; { return(bnormcdf(x
,y
,z
)); }
438 double ccl_cauchycdf(x
) double x
; { return(cauchycdf(x
)); }
439 double ccl_cauchyquant(x
) double x
; { return(cauchyquant(x
)); }
440 double ccl_cauchydens(x
) double x
; { return(cauchydens(x
)); }
441 double ccl_cauchyrand() { return(cauchyrand()); }
443 double ccl_gammacdf(x
, y
) double x
, y
; { return(gammacdf(x
, y
)); }
444 double ccl_gammaquant(x
, y
) double x
, y
; { return(gammaquant(x
, y
)); }
445 double ccl_gammadens(x
, y
) double x
, y
; { return(gammadens(x
, y
)); }
446 double ccl_gammarand(x
) double x
; { return(gammarand(x
)); }
448 double ccl_chisqcdf(x
, y
) double x
, y
; { return(chisqcdf(x
, y
)); }
449 double ccl_chisqquant(x
, y
) double x
, y
; { return(chisqquant(x
, y
)); }
450 double ccl_chisqdens(x
, y
) double x
, y
; { return(chisqdens(x
, y
)); }
451 double ccl_chisqrand(x
) double x
; { return(chisqrand(x
)); }
453 double ccl_betacdf(x
, y
, z
) double x
, y
, z
; { return(betacdf(x
, y
, z
)); }
454 double ccl_betaquant(x
, y
, z
) double x
, y
, z
; { return(betaquant(x
, y
, z
)); }
455 double ccl_betadens(x
, y
, z
) double x
, y
, z
; { return(betadens(x
, y
, z
)); }
456 double ccl_betarand(x
, y
) double x
, y
; { return(betarand(x
, y
)); }
458 double ccl_tcdf(x
, y
) double x
, y
; { return(tcdf(x
, y
)); }
459 double ccl_tquant(x
, y
) double x
, y
; { return(tquant(x
, y
)); }
460 double ccl_tdens(x
, y
) double x
, y
; { return(tdens(x
, y
)); }
461 double ccl_trand(x
) double x
; { return(trand(x
)); }
463 double ccl_fcdf(x
, y
, z
) double x
, y
, z
; { return(fcdf(x
, y
, z
)); }
464 double ccl_fquant(x
, y
, z
) double x
, y
, z
; { return(fquant(x
, y
, z
)); }
465 double ccl_fdens(x
, y
, z
) double x
, y
, z
; { return(fdens(x
, y
, z
)); }
466 double ccl_frand(x
, y
) double x
, y
; { return(frand(x
, y
)); }
468 double ccl_poissoncdf(x
, y
) double x
, y
; { return(poissoncdf(x
, y
)); }
469 int ccl_poissonquant(x
, y
) double x
, y
; { return(poissonquant(x
, y
)); }
470 double ccl_poissonpmf(x
, y
) int x
; double y
; { return(poissonpmf(x
, y
)); }
471 int ccl_poissonrand(x
) double x
; { return(poissonrand(x
)); }
473 double ccl_binomialcdf(x
, y
, z
) double x
, z
; int y
; { return(binomialcdf(x
, y
, z
)); }
474 int ccl_binomialquant(x
, y
, z
) double x
, z
; int y
; { return(binomialquant(x
, y
, z
)); }
475 double ccl_binomialpmf(x
, y
, z
) int x
, y
; double z
; { return(binomialpmf(x
, y
, z
)); }
476 int ccl_binomialrand(x
, y
) int x
; double y
; { return(binomialrand(x
, y
)); }