src/description.lisp

   1 (in-package :lisp-on-lines)
   2
   3 (define-layered-function description-of (thing)
   4   (:method (thing)
   5     (find-description 't)))
   6
   7 (defun description-print-name (description)
   8   (description-class-name (class-of description)))
   9
  10 (defun description-attributes (description)
  11   (description-class-attributes (class-of description)))
  12
  13 (defun find-attribute (description attribute-name)
  14   (find attribute-name (description-attributes description)
  15         :key #'attribute-name))
  16
  17 (define-layered-function description-active-descriptions (description)
  18   (:method ((description standard-description-object))
  19     (attribute-value (find-attribute description 'active-descriptions)))
  20   (:method ((description attribute))
  21     (attribute-active-descriptions description)))
  22
  23 (define-layered-function description-inactive-descriptions (description)
  24   (:method ((description standard-description-object))
  25     (attribute-value (find-attribute description 'inactive-descriptions)))
  26   (:method ((description attribute))
  27     (attribute-inactive-descriptions description)))
  28
  29 (define-layered-function attributes (description)
  30   (:method (description)
  31     (let* ((active-attributes
  32             (find-attribute description 'active-attributes))
  33            (attributes (when active-attributes
  34              (attribute-value active-attributes))))
  35       (if attributes
  36           (mapcar (lambda (spec)
  37                     (find-attribute
  38                      description
  39                      (if (listp spec)
  40                          (car spec)
  41                          spec)))
  42                   attributes)
  43           (remove-if-not
  44            (lambda (attribute)
  45              (and (attribute-active-p attribute)
  46                   (some #'layer-active-p
  47                         (mapcar #'find-layer
  48                                 (slot-definition-layers
  49                                  (attribute-effective-attribute-definition attribute))))))
  50            (description-attributes description))))))
  51
  52
  53
  54
  55
  56
  57 ;;; A handy macro.
  58 (defmacro define-description (name &optional superdescriptions &body options)
  59   (let ((description-name (defining-description name)))
  60     (destructuring-bind (&optional slots &rest options) options
  61       (let ((description-layers (cdr (assoc :in-description options))))
  62         (if description-layers
  63             `(progn ;eval-when (:compile-toplevel :load-toplevel :execute)
  64                ,@(loop
  65                     :for layer
  66                     :in description-layers
  67                     :collect `(define-description
  68                                   ,name ,superdescriptions ,slots
  69                                   ,@(acons
  70                                     :in-layer (defining-description layer)
  71                                     (remove :in-description options :key #'car)))))
  72             `(progn ;eval-when (:compile-toplevel :load-toplevel :execute)
  73                                         ;  `(progn
  74                (defclass ,description-name
  75                    ,(append (mapcar #'defining-description
  76                                     superdescriptions)
  77                             (unless (or (eq t name)
  78                                         (assoc :mixinp options))
  79                               (list (defining-description t))))
  80                  ,(if slots slots '())
  81                  ,@options
  82                  ,@(unless (assoc :metaclass options)
  83                            '((:metaclass standard-description-class))))
  84                (initialize-descriptions)
  85                (find-description ',name)))))))
  86
  87
  88
  89
  90
  91
  92
  93
  94
  95
  96
  97
  98
  99
 100
 101
 102
 103
 104
 105