summaryrefslogtreecommitdiff
path: root/Lisp/internal-utilities.lisp
blob: 657897122faf366230dfbf53ec2113d61ed6bb7f (plain)
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
;;;; Objective-CL, an Objective-C bridge for Common Lisp.
;;;; Copyright (C) 2007  Matthias Andreas Benkard.
;;;;
;;;; This program is free software: you can redistribute it and/or
;;;; modify it under the terms of the GNU General Public License as
;;;; published by the Free Software Foundation, either version 3 of the
;;;; License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful, but
;;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program.  If not, see
;;;; <http://www.gnu.org/licenses/>.

(in-package #:mulk.objective-cl)


(defmacro atomically (&body body)
  ;; Use a reentrant global lock here.
  `(progn ,@body))


(defun featurep (symbol)
  (member symbol *features*))


(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))))))))