gboxed.vs.lisp

   1 (in-package :gobject)
   2
   3 (defun generated-cstruct-name (symbol)
   4   (or (get symbol 'generated-cstruct-name)
   5       (setf (get symbol 'generated-cstruct-name) (gensym (format nil "GEN-~A-CSTRUCT-" (symbol-name symbol))))))
   6
   7 (defun generated-cunion-name (symbol)
   8   (or (get symbol 'generated-cunion-name)
   9       (setf (get symbol 'generated-cunion-name) (gensym (format nil "GEN-~A-CSTRUCT-" (symbol-name symbol))))))
  10
  11 (defun generate-cstruct-1 (struct)
  12   `(defcstruct ,(generated-cstruct-name (var-structure-name struct))
  13      ,@(iter (for slot in (var-struct-all-slots struct))
  14              (collect `(,(var-structure-slot-name slot) ,(var-structure-slot-type slot)
  15                          ,@(when (var-structure-slot-count slot)
  16                                  (list `(:count ,(var-structure-slot-count slot)))))))))
  17
  18 (defun generate-c-structures (structure)
  19   (iter (for str in (all-structures structure))
  20         (collect (generate-cstruct-1 str))))
  21
  22 (defun generate-union-1 (struct)
  23   `(defcunion ,(generated-cunion-name (var-structure-name struct))
  24      ,@(iter (for variant in (all-structures struct))
  25              (unless (eq struct variant)
  26                (collect `(,(var-structure-name variant)
  27                            ,(generated-cunion-name (var-structure-name variant))))))))
  28
  29 (defun generate-unions (struct)
  30   (iter (for str in (all-structures struct))
  31         (collect (generate-union-1 str))))
  32
  33 (defun generate-structure-1 (str)
  34   `(defstruct ,(if (var-structure-parent str)
  35                    `(,(var-structure-name str) (:include ,(var-structure-name (var-structure-parent str))
  36                                                          (,(var-structure-discriminator-slot (var-structure-parent str))
  37                                                            ,(first (var-structure-variant-discriminating-values
  38                                                                     (find str
  39                                                                           (var-structure-variants
  40                                                                            (var-structure-parent str))
  41                                                                           :key #'var-structure-variant-structure))))))
  42                    `,(var-structure-name str))
  43      ,@(iter (for slot in (var-structure-slots str))
  44              (collect `(,(var-structure-slot-name slot)
  45                          ,(var-structure-slot-initform slot))))))
  46
  47 (defun generate-structures (str)
  48   (iter (for variant in (reverse (all-structures str)))
  49         (collect (generate-structure-1 variant))))
  50
  51 (defun generate-native-type-decision-procedure-1 (str proxy-var)
  52   (if (null (var-structure-discriminator-slot str))
  53       `(values ',(generated-cstruct-name (var-structure-name str))
  54                ',(mapcar #'var-structure-slot-name (var-struct-all-slots str)))
  55       `(typecase ,proxy-var
  56          ,@(iter (for variant in (var-structure-variants str))
  57                  (for v-str = (var-structure-variant-structure variant))
  58                  (collect `(,(var-structure-name v-str)
  59                              ,(generate-native-type-decision-procedure-1 v-str proxy-var))))
  60          (,(var-structure-name str)
  61           (values ',(generated-cstruct-name (var-structure-name str))
  62                   ',(mapcar #'var-structure-slot-name (var-struct-all-slots str)))))))
  63
  64 (defun generate-proxy-type-decision-procedure-1 (str native-var)
  65   (if (null (var-structure-discriminator-slot str))
  66       `(values ',(var-structure-name str)
  67                ',(mapcar #'var-structure-slot-name (var-struct-all-slots str))
  68                ',(generated-cstruct-name (var-structure-name str)))
  69       `(case (foreign-slot-value ,native-var
  70                                  ',(generated-cstruct-name (var-structure-name str))
  71                                  ',(var-structure-discriminator-slot str))
  72          ,@(iter (for variant in (var-structure-variants str))
  73                  (for v-str = (var-structure-variant-structure variant))
  74                  (collect `(,(var-structure-variant-discriminating-values variant)
  75                              ,(generate-proxy-type-decision-procedure-1
  76                                v-str
  77                                native-var))))
  78          (t (values ',(var-structure-name str)
  79                     ',(mapcar #'var-structure-slot-name (var-struct-all-slots str))
  80                     ',(generated-cstruct-name (var-structure-name str)))))))
  81
  82 (defun generate-proxy-type-decision-procedure (str)
  83   (let ((native (gensym "NATIVE-")))
  84     `(lambda (,native)
  85        ,(generate-proxy-type-decision-procedure-1 str native))))
  86
  87 (defun generate-native-type-decision-procedure (str)
  88   (let ((proxy (gensym "PROXY-")))
  89     `(lambda (,proxy)
  90        ,(generate-native-type-decision-procedure-1 str proxy))))
  91
  92 (defun compile-proxy-type-decision-procedure (str)
  93   (compile nil (generate-proxy-type-decision-procedure str)))
  94
  95 (defun compile-native-type-decision-procedure (str)
  96   (compile nil (generate-native-type-decision-procedure str)))
  97
  98 (defstruct (g-boxed-variant-cstruct-info (:include g-boxed-info))
  99   root
 100   native-type-decision-procedure
 101   proxy-type-decision-procedure)
 102
 103 (defmethod make-load-form ((object g-boxed-variant-cstruct-info) &optional env)
 104   (make-load-form-saving-slots object :environment env))
 105
 106 (defmacro define-boxed-variant-cstruct (name g-type-name &body slots)
 107   (let* ((structure (parse-variant-structure-definition name slots)))
 108     `(progn ,@(generate-c-structures structure)
 109             ,@(generate-unions structure)
 110             ,@(generate-structures structure)
 111             (eval-when (:compile-toplevel :load-toplevel :execute)
 112               (setf (get ',name 'g-boxed-foreign-info)
 113                     (make-g-boxed-variant-cstruct-info :name ',name
 114                                                        :g-type ,g-type-name
 115                                                        :root ,structure
 116                                                        :native-type-decision-procedure
 117                                                        ,(generate-native-type-decision-procedure structure)
 118                                                        :proxy-type-decision-procedure
 119                                                        ,(generate-proxy-type-decision-procedure structure)))))))
 120
 121 (defun decide-native-type (info proxy)
 122   (funcall (g-boxed-variant-cstruct-info-native-type-decision-procedure info) proxy))
 123
 124 (defmethod create-temporary-native ((type g-boxed-variant-cstruct-info) proxy)
 125   (multiple-value-bind (actual-cstruct slots) (decide-native-type type proxy)
 126     (let ((native-structure (foreign-alloc
 127                              (generated-cstruct-name
 128                               (var-structure-name
 129                                (g-boxed-variant-cstruct-info-root type))))))
 130       (iter (for slot in slots)
 131             (setf (foreign-slot-value native-structure actual-cstruct slot)
 132                   (slot-value proxy slot)))
 133       native-structure)))
 134
 135 (defun decide-proxy-type (info native-structure)
 136   (funcall (g-boxed-variant-cstruct-info-proxy-type-decision-procedure info) native-structure))
 137
 138 (defmethod free-temporary-native ((type g-boxed-variant-cstruct-info) proxy native-ptr)
 139   (multiple-value-bind (actual-struct slots actual-cstruct) (decide-proxy-type type native-ptr)
 140     (unless (eq (type-of proxy) actual-struct)
 141       (restart-case
 142           (error "Expected type of boxed variant structure ~A and actual type ~A do not match"
 143                  (type-of proxy) actual-struct)
 144         (skip-parsing-values () (return-from free-temporary-native))))
 145     (iter (for slot in slots)
 146           (setf (slot-value proxy slot)
 147                 (foreign-slot-value native-ptr actual-cstruct slot)))))
 148
 149 (defmethod create-proxy-for-native ((type g-boxed-variant-cstruct-info) native-ptr)
 150   (multiple-value-bind (actual-struct slots actual-cstruct) (decide-proxy-type type native-ptr)
 151     (let ((proxy (make-instance actual-struct)))
 152       (iter (for slot in slots)
 153             (setf (slot-value proxy slot)
 154                   (foreign-slot-value native-ptr actual-cstruct slot)))
 155       proxy)))
 156
 157 (defmethod create-reference-proxy ((type g-boxed-variant-cstruct-info) native-ptr)
 158   (create-proxy-for-native type native-ptr))
 159
 160 (defmethod free-reference-proxy ((type g-boxed-variant-cstruct-info) proxy native-ptr)
 161   (multiple-value-bind (actual-cstruct slots) (decide-native-type type proxy)
 162     (iter (for slot in slots)
 163           (setf (foreign-slot-value native-ptr actual-cstruct slot)
 164                 (slot-value proxy slot)))))