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
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
|
(in-package #:mulk.objective-cl)
(defmacro atomically (&body body)
;; Use a reentrant global lock here.
`(progn ,@body))
(declaim (ftype (function (symbol * &rest *))))
(defun apply-macro (macro-name arg &rest args)
"Because FOREIGN-FUNCALL is a macro. Why, oh why is this?"
(funcall
(compile nil
`(lambda ()
(,macro-name ,@(butlast (cons arg args))
,@(car (last (cons arg args))))))))
(defmacro with-foreign-conversion (bindings &body body)
`(with-obj-data-values
,(mapcar #'(lambda (name-value-pair)
(destructuring-bind (name value)
name-value-pair
`(,name (lisp->obj-data ,value))))
bindings)
,@body))
(defmacro with-obj-data-values (bindings &body body)
`(let ,(mapcar #'(lambda (name-value-pair)
(destructuring-bind (name value)
name-value-pair
`(,name ,value)))
bindings)
(unwind-protect
(progn ,@body)
,@(mapcar #'(lambda (name-value-pair)
`(dealloc-obj-data ,(first name-value-pair)))
bindings))))
(defmacro with-foreign-string-pool ((register-fn-name) &body body)
(let ((pool-var (gensym)))
`(let ((,pool-var (list)))
(flet ((,register-fn-name (x)
(push x ,pool-var)
x))
(unwind-protect
(progn ,@body)
(dolist (x ,pool-var)
(cffi:foreign-string-free x)))))))
(defmacro with-foreign-object-pool ((register-fn-name) &body body)
(let ((pool-var (gensym)))
`(let ((,pool-var (list)))
(flet ((,register-fn-name (x)
(push x ,pool-var)
x))
(unwind-protect
(progn ,@body)
(dolist (x ,pool-var)
(cffi:foreign-free x)))))))
(defmacro defcoercion (to-class (object) &body body)
(let ((type-sym (gensym)))
`(defmethod coerce-object (,object (,type-sym (eql ',to-class)))
,@body)))
;; Compatibility with older versions of CFFI.
(unless (fboundp 'foreign-funcall-pointer)
(defmacro foreign-funcall-pointer (pointer options &rest args)
(if (find-symbol "FOREIGN-FUNCALL-POINTER" '#:cffi)
`(cffi:foreign-funcall-pointer ,pointer ,options ,@args)
`(cffi:foreign-funcall (,pointer ,@options) ,@args))))
;; Caching of function values.
(defmacro define-cached-function (name lambda-list hashing-form &body body)
"Define a function and cache its result in a hash table. The hash key
is computed according to HASHING-FORM.
Note that HASHING-FORM is expected to return a freshly consed object
that can be garbage collected. It is not recommended to use an atom as
a HASHING-FORM if the value of the atom might itself be an interned atom
or any other value that might never be deleted by the garbage
collector."
(let ((hash-table (gensym))
(value (gensym))
(default-value (gensym))
(hash-key (gensym))
(no-weak-hashing-p (handler-case
(prog1 nil
(tg:make-weak-hash-table :weakness :key
:test 'equal))
(serious-condition () t))))
(if no-weak-hashing-p
`(defun ,name ,lambda-list ,@body)
`(let ((,hash-table (tg:make-weak-hash-table :weakness :key
:test 'equal)))
(defun ,name ,lambda-list
(let* ((,hash-key ,hashing-form)
(,value (gethash ,hash-key ,hash-table ',default-value)))
(if (eq ',default-value ,value)
(values-list
(setf (gethash ,hash-key ,hash-table)
(multiple-value-list (progn ,@body))))
(values-list ,value))))))))
|
