meta.lisp

   1 (in-package :cl-zmq)
   2
   3 (defclass zmq (standard-class) ())
   4
   5 (defmethod validate-superclass ((obj zmq) (obj1 standard-class)) t)
   6
   7 (defvar *zmq-slot-readers* (make-hash-table :test 'equal))
   8 (defvar *zmq-slot-writers* (make-hash-table :test 'equal))
   9
  10 (defmethod slot-value-using-class ((class zmq) inst slot)
  11   (if (string= (string-upcase (slot-definition-name slot)) "RAW")
  12       (call-next-method class inst)
  13       (funcall (gethash (cons (class-name class) (slot-definition-name slot))
  14                         *zmq-slot-readers*)
  15                inst)))
  16
  17 (defmethod (setf slot-value-using-class) (new (class zmq) inst slot)
  18   (if (string= (string-upcase (slot-definition-name slot)) "RAW")
  19       (call-next-method new class inst)
  20       (funcall (gethash (cons (class-name class) (slot-definition-name slot))
  21                         *zmq-slot-writers*)
  22                new inst)))
  23
  24 (defmacro define-wrapper (class-and-type supers &optional slots)
  25   (destructuring-bind (class-name &optional (struct-type class-name))
  26       (cffi::ensure-list class-and-type)
  27     (let ((slots (or slots (cffi::foreign-slot-names struct-type)))
  28           (raw-accessor (cffi::format-symbol t "~A-RAW" class-name)))
  29       `(progn
  30          (defclass ,class-name ,supers
  31            (,@(loop for slot in slots collect
  32                    `(,slot))
  33             (raw :accessor ,raw-accessor))
  34            (:metaclass zmq))
  35
  36          ,@(loop for slot in slots
  37               for slot-name = (cffi::format-symbol t "~A-~A" class-name slot)
  38               for slot-type = (cffi::slot-type (cffi::get-slot-info class-name slot))
  39               collect
  40                 `(defun ,slot-name (inst)
  41                    ,(if (or (eq slot-type :char) (eq slot-type :uchar))
  42                         `(convert-from-foreign
  43                           (foreign-slot-value (,raw-accessor inst) ',class-name ',slot) :string)
  44                         (if (cffi::aggregatep (cffi::parse-type slot-type))
  45                             `(make-instance ',slot-type
  46                                             :pointer (foreign-slot-value (,raw-accessor inst) ',class-name ',slot))
  47                             `(foreign-slot-value (,raw-accessor inst) ',class-name ',slot))))
  48               collect
  49                 `(setf (gethash (cons ',class-name ',slot) *zmq-slot-readers*)
  50                        (fdefinition ',slot-name))
  51
  52               collect
  53                 `(defun (setf ,slot-name) (new inst)
  54                    (setf (foreign-slot-value (,raw-accessor inst) ',class-name ',slot)
  55                          (convert-to-foreign new ',slot-type)))
  56               collect
  57                 `(setf (gethash (cons ',class-name ',slot) *zmq-slot-writers*)
  58                        (fdefinition '(setf ,slot-name))))
  59
  60          (defmethod initialize-instance :after ((inst ,class-name) &key pointer finalizer)
  61            (let ((obj (or pointer (foreign-alloc ',class-name))))
  62              (setf (,raw-accessor inst) obj)
  63              (when finalizer
  64                (tg:finalize inst (lambda () (funcall finalizer obj))))
  65              (unless pointer
  66                (tg:finalize inst (lambda () (foreign-free obj))))))
  67          ',class-name))))
  68
  69 (defmacro def-c-struct (name &rest args)
  70   "Define cffi struct and generate wrapper"
  71   `(progn
  72      (defcstruct ,name
  73        ,@args)
  74      (define-wrapper ,name ())))
  75
  76 (define-condition error-again (error)
  77   ((argument :reader error-again :initarg :argument))
  78   (:report (lambda (condition stream)
  79              (write-string (convert-from-foreign
  80                             (%strerror (error-again condition))
  81                             :string)
  82                            stream))))
  83
  84 (defmacro defcfun* (name-and-options return-type &body args)
  85   (let* ((c-name (car name-and-options))
  86          (l-name (cadr name-and-options))
  87          (n-name (cffi::format-symbol t "%~A" l-name))
  88          (name (list c-name n-name))
  89
  90          (docstring (when (stringp (car args)) (pop args)))
  91          (ret (gensym)))
  92     (loop with opt
  93        for i in args
  94        unless (consp i) do (setq opt t)
  95        else
  96        collect i into args*
  97        and if (not opt) collect (car i) into names
  98        else collect (car i) into opts
  99        and collect (list (car i) 0) into opts-init
 100        end
 101        finally (return
 102          `(progn
 103             (defcfun ,name ,return-type
 104               ,@args*)
 105
 106             (defun ,l-name (,@names &optional ,@opts-init)
 107               ,docstring
 108               (let ((,ret (,n-name ,@names ,@opts)))
 109                 (if ,(if (eq return-type :pointer)
 110                            `(zerop (pointer-address ,ret))
 111                            `(not (zerop ,ret)))
 112                     (cond
 113                       ((eq *errno* isys:eagain) (error 'error-again :argument *errno*))
 114                       (t (error (convert-from-foreign (%strerror *errno*) :string))))
 115                 ,ret))))))))