3 (defstruct var-structure
10 (defstruct var-structure-variant
14 (defstruct var-structure-slot
20 (defmethod make-load-form ((object var-structure) &optional env)
21 (make-load-form-saving-slots object :environment env))
23 (defmethod make-load-form ((object var-structure-slot) &optional env)
24 (make-load-form-saving-slots object :environment env))
26 (defmethod make-load-form ((object var-structure-variant) &optional env)
27 (make-load-form-saving-slots object :environment env))
29 (defun var-struct-all-slots (struct)
31 (append (var-struct-all-slots (var-structure-parent struct))
32 (var-structure-slots struct))))
34 (defun all-structures (structure)
35 (append (iter (for variant in (var-structure-variants structure))
36 (appending (all-structures (var-structure-variant-structure variant))))
39 (defun parse-variant-structure-definition (name slots &optional parent)
40 (iter (with result = (make-var-structure :name name
43 :discriminator-slot nil
46 (if (eq :variant (first slot))
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)))
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)))
61 (defun parse-variants (parent variants)
62 (iter (for var-descr in variants)
63 (for (options variant-name . slots) in variants)
65 (make-var-structure-variant
66 :discriminating-values (ensure-list options)
67 :structure (parse-variant-structure-definition variant-name slots parent)))