w32api-types.lisp

   1
   2 (defpackage cl-w32api.types
   3   (:use :cl :lucifer.luciffi))
   4 (in-package cl-w32api.types)
   5
   6
   7 ;;string types
   8
   9 (defvar *win32-astring-encoding* :cp1251)
  10 (defvar *win32-wstring-encoding* :ucs-2le)
  11
  12 (define-foreign-type w32api-astring-type  (cffi::foreign-string-type)
  13   ()
  14   (:simple-parser ASTRING))
  15 (export 'astring)
  16
  17 (defmethod translate-to-foreign :around (s (type w32api-astring-type))
  18   (let ((luciffi::*default-foreign-encoding* *win32-astring-encoding*))
  19     (if (null s)
  20         (null-pointer)
  21         (call-next-method))))
  22
  23 (defmethod translate-from-foreign :around (ptr (type w32api-astring-type))
  24   (let ((luciffi::*default-foreign-encoding* *win32-astring-encoding*))
  25     (if (null-pointer-p ptr)
  26         nil
  27         (call-next-method))))
  28
  29 (define-foreign-type w32api-wstring-type (cffi::foreign-string-type)
  30   ()
  31   (:simple-parser WSTRING))
  32 (export 'wstring)
  33
  34 (defmethod translate-to-foreign :around (s (type w32api-wstring-type))
  35   (let ((luciffi::*default-foreign-encoding* *win32-wstring-encoding*))
  36     (if (null s)
  37         (null-pointer)
  38         (call-next-method))))
  39
  40 (defmethod translate-from-foreign :around (ptr (type w32api-wstring-type))
  41   (let ((luciffi::*default-foreign-encoding* *win32-wstring-encoding*))
  42     (if (null-pointer-p ptr)
  43         nil
  44         (call-next-method))))
  45
  46 ;;handle types
  47
  48 (define-foreign-type w32api-handle-type ()
  49   ()
  50   (:actual-type :pointer)
  51   (:simple-parser handle))
  52 (export 'handle)
  53
  54 (defmethod translate-to-foreign (s (type w32api-handle-type))
  55   (cond
  56     ((null s) (luciffi:null-pointer))
  57     ((integerp s) (luciffi:make-pointer s))
  58     ((luciffi:pointerp s) s)
  59     (t (error "Not a pointer: ~a" s))))
  60
  61 (defmethod translate-from-foreign :around (ptr (type w32api-handle-type))
  62   (let ((luciffi::*default-foreign-encoding* *win32-wstring-encoding*))
  63     (if (null-pointer-p ptr)
  64         nil
  65         (call-next-method))))
  66
  67 ;;flag types
  68 #|
  69 (define-foreign-type w32api-flag-type ()
  70   ((available-flags :initarg :flag :reader available-flags))
  71   (:actual-type :unsigned-int))
  72
  73 (defmethod translate-to-foreign (s (type w32api-flag-type))
  74   (let ((available-flags (available-flags type)))
  75     (cond
  76       ((integerp s) s)
  77       ((listp s)
  78        (apply #'logior (mapcar (lambda (x)
  79                                  (cond
  80                                    ((symbolp x)
  81                                     (or (cadr (assoc x available-flags :test #'eql))
  82                                         (error "Unrecognizable-flag: ~a ." x)))
  83                                    (t x))) s))))))
  84 (defmethod translate-from-foreign (v (type w32api-flag-type))
  85   (let ((available-flags (available-flags type)))
  86     (loop for (flag-symbol flag-value) in available-flags
  87          if (equal (logior v flag-value) flag-value)
  88          collecting flag-symbol into total-symbol-list
  89          and collecting flag-value into total-value-list
  90          end
  91          finally (let ((rest-values (logxor v (apply #'logior total-value-list))))
  92                    (when (not (zerop rest-values))
  93                      (setf total-symbol-list (nconc total-symbol-list
  94                                                     (list rest-values))))
  95                    (return total-symbol-list)))))
  96
  97 (lutilities:defmacro-exported define-flags-type
  98     (name available-flags &optional documentation)
  99   (declare (ignore documentation))
 100   (cffi::warn-if-kw-or-belongs-to-cl name)
 101   `(eval-when (:compile-toplevel :load-toplevel :execute)
 102      (cffi::notice-foreign-type
 103       ',name (make-instance 'w32api-flag-type :flag ',available-flags))))
 104
 105 |#
 106 ;;(lutilities:defexport define