gboxed.variant-struct.lisp

   1 (in-package :gobject)
   2
   3 (defstruct var-structure
   4   name
   5   parent
   6   slots
   7   discriminator-slot
   8   variants)
   9
  10 (defstruct var-structure-variant
  11   discriminating-values
  12   structure)
  13
  14 (defstruct var-structure-slot
  15   name
  16   type
  17   initform
  18   count)
  19
  20 (defmethod make-load-form ((object var-structure) &optional env)
  21   (make-load-form-saving-slots object :environment env))
  22
  23 (defmethod make-load-form ((object var-structure-slot) &optional env)
  24   (make-load-form-saving-slots object :environment env))
  25
  26 (defmethod make-load-form ((object var-structure-variant) &optional env)
  27   (make-load-form-saving-slots object :environment env))
  28
  29 (defun var-struct-all-slots (struct)
  30   (when struct
  31     (append (var-struct-all-slots (var-structure-parent struct))
  32             (var-structure-slots struct))))
  33
  34 (defun all-structures (structure)
  35   (append (iter (for variant in (var-structure-variants structure))
  36                 (appending (all-structures (var-structure-variant-structure variant))))
  37           (list structure)))
  38
  39 (defun parse-variant-structure-definition (name slots &optional parent)
  40   (iter (with result = (make-var-structure :name name
  41                                            :parent parent
  42                                            :slots nil
  43                                            :discriminator-slot nil
  44                                            :variants nil))
  45         (for slot in slots)
  46         (if (eq :variant (first slot))
  47             (progn
  48               (when (var-structure-discriminator-slot result)
  49                 (error "Structure has more than one discriminator slot"))
  50               (setf (var-structure-discriminator-slot result) (second slot)
  51                     (var-structure-variants result) (parse-variants result (nthcdr 2 slot))))
  52             (push (parse-slot slot) (var-structure-slots result)))
  53         (finally (setf (var-structure-slots result)
  54                        (reverse (var-structure-slots result)))
  55                  (return result))))
  56
  57 (defun parse-slot (slot)
  58   (destructuring-bind (name type &key count initform) slot
  59     (make-var-structure-slot :name name :type type :count count :initform initform)))
  60
  61 (defun parse-variants (parent variants)
  62   (iter (for var-descr in variants)
  63         (for (options variant-name . slots) in variants)
  64         (for variant =
  65              (make-var-structure-variant
  66               :discriminating-values (ensure-list options)
  67               :structure (parse-variant-structure-definition variant-name slots parent)))
  68         (collect variant)))
  69
  70