You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

85 lines
2.4 KiB

;; pointer
(in-package :cl-sipc)
(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 '( make-pointer
pointer
pointer-memory
pointer-p
pointer-size
pointer-from-string
pointer-from-seq
pointer-from
with-pointer
pointer-to-array
pointer-free))