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.
86 lines
2.4 KiB
86 lines
2.4 KiB
;; 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))
|