/
pointer.lisp
85 lines (73 loc) · 2.38 KB
/
pointer.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
;; pointer
(in-package :cl-sipc-mem)
(defstruct pointer
memory
size)
(defun pointer-from-string (str)
"String to pointer"
(let ((ptr (foreign-string-alloc str)))
(make-pointer :memory ptr :size (foreign-funcall "strlen" :pointer ptr :int))))
(defun pointer-from-seq (vec &optional (type :unsigned-char))
"Vector or list to pointer"
(let ((ptr (foreign-alloc type :initial-contents vec)))
(make-pointer :memory ptr :size (* (foreign-type-size type) (length vec)))))
(defun pointer-from (value &optional (type :unsigned-char))
"Value to new allocated pointer"
(pointer-from-sequence (list value) type))
(defmacro with-pointer (desc from &body body)
"with pointer allocated
desc can have name, type allocated, C type.
available types:
:string -- List string
:sequence -- array from list or vector
:single -- single element
:infer (defualt) -- infer type from value
example:
(with-pointer (string-ptr) lisp-string
body...)
(with-pointer (string-ptr-explicit :string) lisp-string
body...)
(with-pointer (vector :sequence :int) vector-of-ints
body...)
(with-pointer (vector :infer :char) vector-of-chars
body...)
"
(let ((name (car desc))
(type0 (or (cadr desc) :infer))
(type (or (caddr desc) :unsigned-char))
(pointer-from-type-infer (gensym)))
(let ((makeptr
(cond ((eql type0 :string) `(pointer-from-string ,from))
((eql type0 :sequence) `(pointer-from-seq ,from ,type))
((eql type0 :single) `(pointer-from ,from ,type))
(t `(,pointer-from-type-infer ,from ,type)))))
`(flet ((,pointer-from-type-infer (fr ty)
(cond ((stringp fr) (pointer-from-string fr))
((or (vectorp fr)
(listp fr)) (pointer-from-seq fr ty))
(t (pointer-from fr ty)))))
(let* ((,name ,makeptr)
(result
(progn ,@body)))
(pointer-free ,name)
result)))))
(defun pointer-free (ptr)
"Free pointer"
(foreign-free (pointer-memory ptr)))
(defun pointer-to-array (ptr &optional (type :unsigned-char))
"pointer to Lisp vector"
(let ((vec (make-array (pointer-size ptr) :initial-element 0)))
(loop for x from 0 below (pointer-size ptr)
do (setf (aref vec x) (mem-aref (pointer-memory ptr) type x)))
vec))
(mapc #'export '(
pointer
pointer-memory
pointer-p
pointer-size
pointer-from-string
pointer-from-seq
pointer-from
with-pointer
pointer-to-array
pointer-free))