Execute the body of WITH-STATIC-VECTOR inside a LOCALLY where necessary.
[iolib:static-vectors.git] / src / impl-allegro.lisp
1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; --- Allegro CL implementation.
4 ;;;
5
6 (in-package :static-vectors)
7
8 (declaim (inline fill-foreign-memory))
9 (defun fill-foreign-memory (pointer length value)
10   "Fill LENGTH octets in foreign memory area POINTER with VALUE."
11   (foreign-funcall "memset" :pointer pointer :int value size-t length :pointer)
12   pointer)
13
14 (declaim (inline replace-foreign-memory))
15 (defun replace-foreign-memory (dst-ptr src-ptr length)
16   "Copy LENGTH octets from foreign memory area SRC-PTR to DST-PTR."
17   (foreign-funcall "memcpy" :pointer dst-ptr :pointer src-ptr size-t length :pointer)
18   dst-ptr)
19
20 (declaim (inline %allocate-static-vector))
21 (defun %allocate-static-vector (length element-type initial-element)
22   (let ((array
23          (make-array length :allocation :static
24                      :element-type element-type)))
25     (when initial-element (fill array initial-element))
26     array))
27
28 (defun make-static-vector (length &key (element-type '(unsigned-byte 8))
29                            (initial-element nil))
30   "Create a simple vector of length LENGTH and type ELEMENT-TYPE which will
31 not be moved by the garbage collector. The vector might be allocated in
32 foreign memory so you must always call FREE-STATIC-VECTOR to free it."
33   (declare (optimize speed))
34   (check-type length non-negative-fixnum)
35   (%allocate-static-vector length element-type initial-element))
36
37 (define-compiler-macro make-static-vector (&whole whole &environment env
38                                            length &key (element-type ''(unsigned-byte 8))
39                                            (initial-element nil))
40   (cond
41     ((constantp element-type env)
42      (let ((element-type (eval element-type)))
43        (if (constantp length env)
44            (let ((%length% (eval length)))
45              (check-type %length% non-negative-fixnum)
46              `(%allocate-static-vector ,%length% ',element-type ,initial-element))
47            (with-gensyms (%length%)
48              `(let ((,%length% ,length))
49                 (check-type ,%length% non-negative-fixnum)
50                 (%allocate-static-vector ,%length% ',element-type ,initial-element))))))
51     (t whole)))
52
53 (declaim (inline static-vector-pointer))
54 (defun static-vector-pointer (vector &key (offset 0))
55   "Return a foreign pointer to the beginning of VECTOR + OFFSET octets.
56 VECTOR must be a vector created by MAKE-STATIC-VECTOR."
57   (check-type offset unsigned-byte)
58   (inc-pointer (ff:fslot-address-typed :unsigned-char :lisp vector) offset))
59
60 (declaim (inline free-static-vector))
61 (defun free-static-vector (vector)
62   "Free VECTOR, which must be a vector created by MAKE-STATIC-VECTOR."
63   (excl:aclfree (excl:lispval-other-to-address vector))
64   (values))
65
66 (defmacro with-static-vector ((var length &rest args
67                                &key (element-type ''(unsigned-byte 8))
68                                (initial-element nil))
69                               &body body)
70   "Bind PTR-VAR to a static vector of length LENGTH and execute BODY
71 within its dynamic extent. The vector is freed upon exit."
72   (declare (ignore element-type initial-element))
73   `(let ((,var nil))
74      (unwind-protect
75           (progn
76             (setf ,var (make-static-vector ,length ,@args))
77             (locally ,@body))
78        (when ,var (free-static-vector ,var)))))