;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-;; $Id: gdk.lisp,v 1.22 2006-02-26 15:09:44 espen Exp $
+;; $Id: gdk.lisp,v 1.26 2006-04-25 13:37:28 espen Exp $
(in-package "GDK")
;;; Color
+(defbinding %color-copy () pointer
+ (location pointer))
+
+(defmethod allocate-foreign ((color color) &rest initargs)
+ (declare (ignore color initargs))
+ ;; Color structs are allocated as memory chunks by gdk, and since
+ ;; there is no gdk_color_new we have to use this hack to get a new
+ ;; color chunk
+ (with-allocated-memory (location #.(foreign-size (find-class 'color)))
+ (%color-copy location)))
+
(defun %scale-value (value)
(etypecase value
(integer value)
(float (truncate (* value 65535)))))
(defmethod initialize-instance ((color color) &rest initargs
- &key red green blue)
+ &key (red 0.0) (green 0.0) (blue 0.0))
(declare (ignore initargs))
(call-next-method)
(with-slots ((%red red) (%green green) (%blue blue)) color
%green (%scale-value green)
%blue (%scale-value blue))))
+(defbinding %color-parse () boolean
+ (spec string)
+ (color color :return))
+
+(defun color-parse (spec &optional (color (make-instance 'color)))
+ (multiple-value-bind (succeeded-p color) (%color-parse spec color)
+ (if succeeded-p
+ color
+ (error "Parsing color specification ~S failed." spec))))
+
(defun ensure-color (color)
(etypecase color
(null nil)
(color color)
+ (string (color-parse color))
(vector
- (make-instance
- 'color :red (svref color 0) :green (svref color 1)
- :blue (svref color 2)))))
-
+ (make-instance 'color
+ :red (svref color 0) :green (svref color 1) :blue (svref color 2)))))
+
;;; Drawable
;; (cr cairo:context)
;; (region region))
)
+
+
+;;; Multi-threading support
+
+#+sbcl
+(progn
+ (defvar *global-lock* (sb-thread:make-mutex :name "global GDK lock"))
+ (let ((recursive-level 0))
+ (defun threads-enter ()
+ (if (eq (sb-thread:mutex-value *global-lock*) sb-thread:*current-thread*)
+ (incf recursive-level)
+ (sb-thread:get-mutex *global-lock*)))
+
+ (defun threads-leave (&optional flush-p)
+ (cond
+ ((zerop recursive-level)
+ (when flush-p
+ (display-flush))
+ (sb-thread:release-mutex *global-lock*))
+ (t (decf recursive-level)))))
+
+ (define-callback %enter-fn nil ()
+ (threads-enter))
+
+ (define-callback %leave-fn nil ()
+ (threads-leave))
+
+ (defbinding threads-set-lock-functions (&optional) nil
+ (%enter-fn callback)
+ (%leave-fn callback))
+
+ (defmacro with-global-lock (&body body)
+ `(progn
+ (threads-enter)
+ (unwind-protect
+ (progn ,@body)
+ (threads-leave t)))))