1 ;;;; ladata -- Data handling functions for linear algebra interface
3 ;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for
13 (in-package lisp-stat-basics
)
15 (in-package 'lisp-stat-basics
)
17 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
19 ;;;; Data Mode Functions
21 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
24 ;;;; These constants need to be redefined if IN, RE or CX in linalg.h
27 (defconstant mode-in
0)
28 (defconstant mode-re
1)
29 (defconstant mode-cx
2)
38 (defun la-data-mode (data)
39 (let ((data (compound-data-seq data
))
43 (let ((n (length data
)))
47 (setf mode
(max mode
(mode-of (aref data i
)))))))
48 ((consp data
) (dolist (x data mode
) (setf mode
(max mode
(mode-of x
)))))
49 (t (error "bad sequence - ~s" data
)))))
52 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
54 ;;;; Internal Allocation Funcitons
56 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
58 (defvar *la-allocations
* nil
)
60 (defun la-allocate (n m
)
61 (let ((p (la-base-allocate n m
)))
62 (if (null-ptr-p p
) (error "allocation failed"))
63 (if (member p
*la-allocations
* :test
#'ptr-eq
)
64 (error "pointer is already on the list"))
65 (push p
*la-allocations
*)
69 (when (and (not (null-ptr-p p
)) (member p
*la-allocations
* :test
#'ptr-eq
))
70 (setf *la-allocations
* (delete p
*la-allocations
* :test
#'ptr-eq
))
73 (defun la-cleanup-allocations ()
74 (let ((allocs (copy-list *la-allocations
*)))
75 (dolist (p allocs
) (la-free p
))))
77 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
79 ;;;; C Vector and Array Allocation
81 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
83 (defun la-vector(n mode
) (la-allocate n
(la-mode-size mode
)))
84 (defun la-free-vector (v) (la-free v
))
86 (defun la-matrix (n m mode
)
87 (let ((matrix (la-allocate n
(la-mode-size mode-in
))))
89 (la-put-pointer matrix i
(la-allocate m
(la-mode-size mode
))))
92 (defun la-free-matrix (matrix n
)
94 (la-free (la-get-pointer matrix i
)))
98 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
100 ;;;; C to/from Lisp Data Conversion
102 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
104 (defun la-data-to-vector (data mode
)
105 (check-sequence data
)
106 (let* ((n (length data
))
107 (vec (la-vector n mode
))
108 (d (make-next-element data
)))
114 (la-put-integer vec i
(get-next-element d i
))))
118 (la-put-double vec i
(get-next-element d i
))))
122 (let ((x (get-next-element d i
)))
123 (la-put-complex vec i
(realpart x
) (imagpart x
))))))
126 (defun la-data-to-matrix (data mode
)
128 (let* ((n (num-rows data
))
130 (mat (la-matrix n m mode
)))
131 (declare (fixnum n m
))
136 (let ((vec (la-get-pointer mat i
)))
138 (la-put-integer vec j
(aref data i j
))))))
142 (let ((vec (la-get-pointer mat i
)))
144 (la-put-double vec j
(aref data i j
))))))
148 (let ((vec (la-get-pointer mat i
)))
150 (let ((x (aref data i j
)))
151 (la-put-complex vec i
(realpart x
) (imagpart x
))))))))
154 (defun la-vector-to-data (vec n mode data
)
156 (check-sequence data
)
157 (let ((d (make-next-element data
))
159 ((= mode mode-in
) #'la-get-integer
)
160 ((= mode mode-re
) #'la-get-double
)
161 ((= mode mode-cx
) #'la-get-complex
))))
164 (set-next-element d i
(funcall gf vec i
))))
167 (defun la-matrix-to-data (mat n m mode result
)
168 (declare (fixnum n m
))
169 (check-matrix result
)
171 ((= mode mode-in
) #'la-get-integer
)
172 ((= mode mode-re
) #'la-get-double
)
173 ((= mode mode-cx
) #'la-get-complex
))))
176 (let ((vec (la-get-pointer mat i
)))
179 (setf (aref result i j
) (funcall gf vec j
))))))