1 ;;;; mclglue -- Interface to C library
3 ;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for
11 (import '(ccl:def-logical-directory ccl
:ff-load ccl
:deffcfun ccl
:defccallable
))
13 (def-logical-directory "mclslib;" "mcls;lib:")
14 (def-logical-directory "clib;" "ccl;:mpw:libraries:clibraries:")
15 (def-logical-directory "mpwlib;" "ccl;:mpw:libraries:libraries:")
17 (defvar mcls-libs
'("mclslib;clib.o"
24 (defvar mcls-libs-881
'("mclslib;clib.o"
32 (ff-load "mclslib;mclglue.c.o"
37 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
38 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
42 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
43 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
45 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
47 ;;;; Callback Support Functions
49 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
51 (deffcfun (ccl-store-integer "ccl_store_integer") (fixnum) :novalue
)
52 (deffcfun (ccl-store-double "ccl_store_double") (float) :novalue
)
53 (deffcfun (ccl-store-ptr "ccl_store_ptr") ((t :ptr
)) :novalue
)
56 ;;;; Lisp-Managed Calloc/Free
60 (defccallable lisp-new-ptr
((n :long
) (:result
:void
))
61 (ccl-store-ptr (ccl:_NewPtr
:d0 n
:a0
)))
62 (deffcfun (register-new-ptr "register_new_ptr") ((t :ptr
)) :novalue
)
63 (register-new-ptr lisp-new-ptr
)
65 (defccallable lisp-free-ptr
((p :ptr
) (:result
:void
))
66 (ccl:_DisposPtr
:a0 p
:d0
))
67 (deffcfun (register-free-ptr "register_free_ptr") ((t :ptr
)) :novalue
)
68 (register-free-ptr lisp-free-ptr
)
71 ;;;; Storage Allocation Functions
74 (defun null-ptr-p (p) (ccl:%null-ptr-p p
))
75 (defun ptr-eq (p q
) (= (ccl:%ptr-to-int p
) (ccl:%ptr-to-int q
)))
77 (deffcfun (ccl-la-base-allocate "la_base_allocate") (fixnum fixnum
) :ptr
)
78 (defun la-base-allocate (n m
) (ccl-la-base-allocate n m
))
80 (deffcfun (ccl-la-base-free-alloc "la_base_free_alloc") ((t :ptr
)) :novalue
)
81 (defun la-base-free (p) (ccl-la-base-free-alloc p
))
83 (deffcfun (ccl-la-mode-size "la_mode_size") (fixnum) :long
)
84 (defun la-mode-size (mode) (ccl-la-mode-size mode
))
87 ;;;; Callbacks for Internal Storage
90 (defccallable lisp-la-allocate
((n :long
) (m :long
) (:result
:void
))
91 (ccl-store-ptr (la-allocate n m
)))
92 (deffcfun (register-la-allocate "register_la_allocate") ((t :ptr
)) :novalue
)
93 (register-la-allocate lisp-la-allocate
)
94 (deffcfun (la "la_allocate") (fixnum fixnum
) :ptr
)
96 (defccallable lisp-la-free-alloc
((p :ptr
) (:result
:void
)) (la-free p
))
97 (deffcfun (register-la-free-alloc "register_la_free_alloc") ((t :ptr
)) :novalue
)
98 (register-la-free-alloc lisp-la-free-alloc
)
99 (deffcfun (lf "la_free_alloc") ((t :ptr
)) :novalue
)
102 ;;;; Storage Access Functions
105 (deffcfun (ccl-la-get-integer "la_get_integer") ((t :ptr
) fixnum
) :long
)
106 (defun la-get-integer (p i
) (ccl-la-get-integer p i
))
108 (deffcfun (ccl-la-get-double "la_get_double") ((t :ptr
) fixnum
) :float
)
109 (defun la-get-double (p i
) (ccl-la-get-double p i
))
111 (deffcfun (ccl-la-get-complex-real "la_get_complex_real") ((t :ptr
) fixnum
) :float
)
112 (defun la-get-complex-real (p i
) (ccl-la-get-complex-real p i
))
114 (deffcfun (ccl-la-get-complex-imag "la_get_complex_imag") ((t :ptr
) fixnum
) :float
)
115 (defun la-get-complex-imag (p i
) (ccl-la-get-complex-imag p i
))
117 (defun la-get-complex (p i
)
118 (complex (la-get-complex-real p i
) (la-get-complex-imag p i
)))
120 (deffcfun (ccl-la-get-pointer "la_get_pointer") ((t :ptr
) fixnum
) :ptr
)
121 (defun la-get-pointer (p i
) (ccl-la-get-pointer p i
))
124 ;;;; Storage Mutation Functions
127 (deffcfun (ccl-la-put-integer "la_put_integer") ((t :ptr
) fixnum fixnum
) :novalue
)
128 (defun la-put-integer (p i x
) (ccl-la-put-integer p i x
))
130 (deffcfun (ccl-la-put-double "la_put_double") ((t :ptr
) fixnum float
) :novalue
)
131 (defun la-put-double (p i x
) (ccl-la-put-double p i
(float x
)))
133 (deffcfun (ccl-la-put-complex "la_put_complex") ((t :ptr
) fixnum float float
) :novalue
)
134 (defun la-put-complex (p i x y
) (ccl-la-put-complex p i
(float x
) (float y
)))
136 (deffcfun (ccl-la-put-pointer "la_put_pointer") ((t :ptr
) fixnum
(t :ptr
)) :novalue
)
137 (defun la-put-pointer (p i q
) (ccl-la-put-pointer p i q
))
139 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
141 ;;;; XLISP Internal Error Message Emulation
143 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
145 (defvar *buf
* (make-string 1000))
147 (defun set-buf-char (i c
) (setf (elt *buf
* i
) (code-char c
)))
149 (defun get-buf (&optional
(n (position (code-char 0) *buf
*)))
152 (deffcfun (register-set-buf-char "register_set_buf_char") ((t :ptr
)) :novalue
)
153 (defccallable ccl-set-buf-char
((n :long
) (c :long
) (:result
:long
))
155 (register-set-buf-char ccl-set-buf-char
)
157 (deffcfun (register-print-buffer "register_print_buffer") ((t :ptr
)) :novalue
)
158 (defccallable ccl-print-buffer
((n :long
) (type :long
) (:result
:long
))
160 (0 (princ (get-buf n
)))
161 (1 (error (get-buf n
))))
163 (register-print-buffer ccl-print-buffer
)
165 (deffcfun (stdputstr "stdputstr") ((string :by-reference
)) :novalue
)
166 (deffcfun (xlfail "xlfail") ((string :by-reference
)) :novalue
)
168 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
169 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
171 ;;;; Lisp Interfaces to Linear Algebra Routines
173 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
174 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
177 ;;;; Cholesky Decomposition
180 (deffcfun (ccl-chol-decomp-front "ccl_chol_decomp_front")
181 ((t :ptr
) fixnum
(t :ptr
))
183 (defun chol-decomp-front (x y z
) (ccl-chol-decomp-front x y z
))
186 ;;;; LU Decomposition
189 (deffcfun (ccl-lu-decomp-front "ccl_lu_decomp_front")
190 ((t :ptr
) fixnum
(t :ptr
) fixnum
(t :ptr
))
192 (defun lu-decomp-front (x y z u v
) (ccl-lu-decomp-front x y z u v
))
194 (deffcfun (ccl-lu-solve-front "ccl_lu_solve_front")
195 ((t :ptr
) fixnum
(t :ptr
) (t :ptr
) fixnum
)
197 (defun lu-solve-front (x y z u v
) (ccl-lu-solve-front x y z u v
))
199 (deffcfun (ccl-lu-inverse-front "ccl_lu_inverse_front")
200 ((t :ptr
) fixnum
(t :ptr
) (t :ptr
) fixnum
(t :ptr
))
202 (defun lu-inverse-front (x y z u v w
) (ccl-lu-inverse-front x y z u v w
))
205 ;;;; SV Decomposition
208 (deffcfun (ccl-sv-decomp-front "ccl_sv_decomp_front")
209 ((t :ptr
) fixnum fixnum
(t :ptr
) (t :ptr
))
211 (defun sv-decomp-front (x y z u v
) (ccl-sv-decomp-front x y z u v
))
214 ;;;; QR Decomposition
217 (deffcfun (ccl-qr-decomp-front "ccl_qr_decomp_front")
218 ((t :ptr
) fixnum fixnum
(t :ptr
) (t :ptr
) fixnum
)
220 (defun qr-decomp-front (x y z u v w
) (ccl-qr-decomp-front x y z u v w
))
223 ;;;; Estimate of Condition Number for Lower Triangular Matrix
226 (deffcfun (ccl-rcondest-front "ccl_rcondest_front") ((t :ptr
) fixnum
) :float
)
227 (defun rcondest-front (x y
) (ccl-rcondest-front x y
))
230 ;;;; Make Rotation Matrix
233 (deffcfun (ccl-make-rotation-front "ccl_make_rotation_front")
234 (fixnum (t :ptr
) (t :ptr
) (t :ptr
) fixnum float
)
236 (defun make-rotation-front (x y z u v w
)
237 (ccl-make-rotation-front x y z u v
(float w
)))
240 ;;;; Eigenvalues and Eigenvectors
243 (deffcfun (ccl-eigen-front "ccl_eigen_front")
244 ((t :ptr
) fixnum
(t :ptr
) (t :ptr
) (t :ptr
))
246 (defun eigen-front (x y z u v
) (ccl-eigen-front x y z u v
))
249 ;;;; Spline Interpolation
252 (deffcfun (ccl-range-to-rseq "ccl_range_to_rseq")
253 (fixnum (t :ptr
) fixnum
(t :ptr
))
255 (defun la-range-to-rseq (x y z u
) (ccl-range-to-rseq x y z u
))
257 (deffcfun (ccl-spline-front "ccl_spline_front")
258 (fixnum (t :ptr
) (t :ptr
) fixnum
(t :ptr
) (t :ptr
) (t :ptr
))
260 (defun spline-front (x y z u v w a
) (ccl-spline-front x y z u v w a
))
263 ;;;; Kernel Density Estimators and Smoothers
266 (deffcfun (ccl-kernel-dens-front "ccl_kernel_dens_front")
267 ((t :ptr
) fixnum float
(t :ptr
) (t :ptr
) fixnum fixnum
)
269 (defun kernel-dens-front (x y z u v w a
)
270 (ccl-kernel-dens-front x y
(float z
) u v w a
))
272 (deffcfun (ccl-kernel-smooth-front "ccl_kernel_smooth_front")
273 ((t :ptr
) (t :ptr
) fixnum float
(t :ptr
) (t :ptr
) fixnum fixnum
)
275 (defun kernel-smooth-front (x y z u v w a b
)
276 (ccl-kernel-smooth-front x y z
(float u
) v w a b
))
279 ;;;; Lowess Smoother Interface
282 (deffcfun (ccl-base-lowess-front "ccl_base_lowess_front")
283 ((t :ptr
) (t :ptr
) fixnum float fixnum float
(t :ptr
) (t :ptr
) (t :ptr
))
285 (defun base-lowess-front (x y z u v w a b c
)
286 (ccl-base-lowess-front x y z
(float u
) v
(float w
) a b c
))
292 (deffcfun (ccl-fft-front "ccl_fft_front") (fixnum (t :ptr
) (t :ptr
) fixnum
) :long
)
293 (defun fft-front (x y z u
) (ccl-fft-front x y z u
))
296 ;;;; Maximization and Numerical Derivatives
299 (defccallable ccl-maximize-callback
((n :long
)
306 (maximize-callback n px pfval pgrad phess pderivs
))
307 (deffcfun (register-maximize-callback "register_maximize_callback")
310 (register-maximize-callback ccl-maximize-callback
)
312 (deffcfun (ccl-numgrad-front "ccl_numgrad_front")
313 (fixnum (t :ptr
) (t :ptr
) float
(t :ptr
))
315 (defun numgrad-front (x y z u v
) (ccl-numgrad-front x y z
(float u
) v
))
317 (deffcfun (ccl-numhess-front "ccl_numhess_front")
318 (fixnum (t :ptr
) (t :ptr
) (t :ptr
) (t :ptr
) float
(t :ptr
))
320 (defun numhess-front (x y z u v w a
) (ccl-numhess-front x y z u v
(float w
) a
))
322 (deffcfun (ccl-minfo-maximize "ccl_minfo_maximize")
323 ((t :ptr
) (t :ptr
) (t :ptr
) (t :ptr
) (t :ptr
) fixnum
)
325 (defun base-minfo-maximize (x y z u v w
) (ccl-minfo-maximize x y z u v w
))
327 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
328 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
330 ;;;; Probability Distributions
332 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
333 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
337 ;;;; C-callable uniform generator
340 (deffcfun (register-uni "register_uni") ((t :ptr
)) :novalue
)
341 (defccallable ccl-uni
((:result
:long
)) (ccl-store-double (random 1.0)) 0)
342 (register-uni ccl-uni
)
344 (defun one-uniform-rand () (random 1.0))
347 ;;;; Log-gamma function
350 (deffcfun (ccl-base-log-gamma "ccl_gamma") (float) :float
)
351 (defun base-log-gamma (x) (ccl-base-log-gamma (float x
)))
354 ;;;; Normal distribution
357 (deffcfun (ccl-base-normal-cdf "ccl_normalcdf") (float) :float
)
358 (defun base-normal-cdf (x) (ccl-base-normal-cdf (float x
)))
359 (deffcfun (ccl-base-normal-quant "ccl_normalquant") (float) :float
)
360 (defun base-normal-quant (x) (ccl-base-normal-quant (float x
)))
361 (deffcfun (ccl-base-normal-dens "ccl_normaldens") (float) :float
)
362 (defun base-normal-dens (x) (ccl-base-normal-dens (float x
)))
363 (deffcfun (one-normal-rand "ccl_normalrand") () :float
)
364 (deffcfun (ccl-base-bivnorm-cdf "ccl_bnormcdf") (float float float
) :float
)
365 (defun base-bivnorm-cdf (x y z
) (ccl-base-bivnorm-cdf (float x
) (float y
) (float z
)))
368 ;;;; Cauchy distribution
371 (deffcfun (ccl-base-cauchy-cdf "ccl_cauchycdf") (float) :float
)
372 (defun base-cauchy-cdf (x) (ccl-base-cauchy-cdf (float x
)))
373 (deffcfun (ccl-base-cauchy-quant "ccl_cauchyquant") (float) :float
)
374 (defun base-cauchy-quant (x) (ccl-base-cauchy-quant (float x
)))
375 (deffcfun (ccl-base-cauchy-dens "ccl_cauchydens") (float) :float
)
376 (defun base-cauchy-dens (x) (ccl-base-cauchy-dens (float x
)))
377 (deffcfun (one-cauchy-rand "ccl_cauchyrand") () :float
)
380 ;;;; Gamma distribution
383 (deffcfun (ccl-base-gamma-cdf "ccl_gammacdf") (float float
) :float
)
384 (defun base-gamma-cdf (x y
) (ccl-base-gamma-cdf (float x
) (float y
)))
385 (deffcfun (ccl-base-gamma-quant "ccl_gammaquant") (float float
) :float
)
386 (defun base-gamma-quant (x y
) (ccl-base-gamma-quant (float x
) (float y
)))
387 (deffcfun (ccl-base-gamma-dens "ccl_gammadens") (float float
) :float
)
388 (defun base-gamma-dens (x y
) (ccl-base-gamma-dens (float x
) (float y
)))
389 (deffcfun (ccl-gamma-rand "ccl_gammarand") (float) :float
)
390 (defun one-gamma-rand (x) (ccl-gamma-rand (float x
)))
393 ;;;; Chi-square distribution
396 (deffcfun (ccl-base-chisq-cdf "ccl_chisqcdf") (float float
) :float
)
397 (defun base-chisq-cdf (x y
) (ccl-base-chisq-cdf (float x
) (float y
)))
398 (deffcfun (ccl-base-chisq-quant "ccl_chisqquant") (float float
) :float
)
399 (defun base-chisq-quant (x y
) (ccl-base-chisq-quant (float x
) (float y
)))
400 (deffcfun (ccl-base-chisq-dens "ccl_chisqdens") (float float
) :float
)
401 (defun base-chisq-dens (x y
) (ccl-base-chisq-dens (float x
) (float y
)))
402 (deffcfun (ccl-chisq-rand "ccl_chisqrand") (float) :float
)
403 (defun one-chisq-rand (x) (ccl-chisq-rand (float x
)))
406 ;;;; Beta distribution
409 (deffcfun (ccl-base-beta-cdf "ccl_betacdf") (float float float
) :float
)
410 (defun base-beta-cdf (x y z
) (ccl-base-beta-cdf (float x
) (float y
) (float z
)))
411 (deffcfun (ccl-base-beta-quant "ccl_betaquant") (float float float
) :float
)
412 (defun base-beta-quant (x y z
) (ccl-base-beta-quant (float x
) (float y
) (float z
)))
413 (deffcfun (ccl-base-beta-dens "ccl_betadens") (float float float
) :float
)
414 (defun base-beta-dens (x y z
) (ccl-base-beta-dens (float x
) (float y
) (float z
)))
415 (deffcfun (ccl-beta-rand "ccl_betarand") (float float
) :float
)
416 (defun one-beta-rand (x y
) (ccl-beta-rand (float x
) (float y
)))
422 (deffcfun (ccl-base-t-cdf "ccl_tcdf") (float float
) :float
)
423 (defun base-t-cdf (x y
) (ccl-base-t-cdf (float x
) (float y
)))
424 (deffcfun (ccl-base-t-quant "ccl_tquant") (float float
) :float
)
425 (defun base-t-quant (x y
) (ccl-base-t-quant (float x
) (float y
)))
426 (deffcfun (ccl-base-t-dens "ccl_tdens") (float float
) :float
)
427 (defun base-t-dens (x y
) (ccl-base-t-dens (float x
) (float y
)))
428 (deffcfun (ccl-t-rand "ccl_trand") (float) :float
)
429 (defun one-t-rand (x) (ccl-t-rand (float x
)))
435 (deffcfun (ccl-base-f-cdf "ccl_fcdf") (float float float
) :float
)
436 (defun base-f-cdf (x y z
) (ccl-base-f-cdf (float x
) (float y
) (float z
)))
437 (deffcfun (ccl-base-f-quant "ccl_fquant") (float float float
) :float
)
438 (defun base-f-quant (x y z
) (ccl-base-f-quant (float x
) (float y
) (float z
)))
439 (deffcfun (ccl-base-f-dens "ccl_fdens") (float float float
) :float
)
440 (defun base-f-dens (x y z
) (ccl-base-f-dens (float x
) (float y
) (float z
)))
441 (deffcfun (ccl-f-rand "ccl_frand") (float float
) :float
)
442 (defun one-f-rand (x y
) (ccl-f-rand (float x
) (float y
)))
445 ;;;; Poisson distribution
448 (deffcfun (ccl-base-poisson-cdf "ccl_poissoncdf") (float float
) :float
)
449 (defun base-poisson-cdf (x y
) (ccl-base-poisson-cdf (float x
) (float y
)))
450 (deffcfun (ccl-base-poisson-quant "ccl_poissonquant") (float float
) :long
)
451 (defun base-poisson-quant (x y
) (ccl-base-poisson-quant (float x
) (float y
)))
452 (deffcfun (ccl-base-poisson-pmf "ccl_poissonpmf") (fixnum float
) :float
)
453 (defun base-poisson-pmf (x y
) (ccl-base-poisson-pmf x
(float y
)))
454 (deffcfun (ccl-poisson-rand "ccl_poissonrand") (float) :long
)
455 (defun one-poisson-rand (x) (ccl-poisson-rand (float x
)))
458 ;;;; Binomial distribution
461 (deffcfun (ccl-base-binomial-cdf "ccl_binomialcdf") (float fixnum float
) :float
)
462 (defun base-binomial-cdf (x y z
) (ccl-base-binomial-cdf (float x
) y
(float z
)))
463 (deffcfun (ccl-base-binomial-quant "ccl_binomialquant") (float fixnum float
) :long
)
464 (defun base-binomial-quant (x y z
) (ccl-base-binomial-quant (float x
) y
(float z
)))
465 (deffcfun (ccl-base-binomial-pmf "ccl_binomialpmf") (fixnum fixnum float
) :float
)
466 (defun base-binomial-pmf (x y z
) (ccl-base-binomial-pmf x y
(float z
)))
467 (deffcfun (ccl-binomial-rand "ccl_binomialrand") (fixnum float
) :long
)
468 (defun one-binomial-rand (x y
) (ccl-binomial-rand x
(float y
)))