external/clem/src/metaclasses.lisp

   1
   2 (in-package :clem)
   3
   4 ;;; Taken from KMR's clsql package
   5 (defun remove-keyword-arg (arglist akey)
   6   (let ((mylist arglist)
   7         (newlist ()))
   8     (labels ((pop-arg (alist)
   9                (let ((arg (pop alist))
  10                      (val (pop alist)))
  11                  (unless (equal arg akey)
  12                    (setf newlist (append (list arg val) newlist)))
  13                  (when alist (pop-arg alist)))))
  14       (pop-arg mylist))
  15     newlist))
  16
  17 ;;; Also taken from KMR's clsql package
  18 (declaim (inline delistify-dsd))
  19 (defun delistify-dsd (list)
  20   "Some MOPs, like openmcl 0.14.2, cons attribute values in a list."
  21   (if (and (listp list) (null (cdr list)))
  22       (car list)
  23       list))
  24
  25 ;;; Taken from util so I don't need to include it here
  26 (defun insert-before (new old list)
  27   (labels ((build-list (old c &optional newlist)
  28              (if c
  29                  (if (eq old (car c))
  30                      (append (reverse (cdr c)) (cons (car c) (cons new newlist)))
  31                      (build-list old (cdr c) (cons (car c) newlist)))
  32                  (cons new newlist))))
  33     (reverse (build-list old list))))
  34
  35
  36 (defun fill-slot-from-ancestor (slot class)
  37   (let ((ancestor (find-if #'(lambda (anc)
  38                                (when (slot-exists-p anc slot)
  39                                  (slot-boundp anc slot)))
  40                            (cdr (compute-class-precedence-list class)))))
  41     (when ancestor
  42       (setf (slot-value class slot) (slot-value ancestor slot)))))
  43
  44 (defun fill-standard-matrix-class-slots-from-ancestors (class &rest all-keys)
  45   (mapcar #'(lambda (x)
  46               (let ((name (slot-definition-name x))
  47                     (initargs (slot-definition-initargs x)))
  48                 (unless (getf (car all-keys) (car initargs))
  49                   (fill-slot-from-ancestor name class))))
  50           (standard-matrix-class-slots class)))
  51
  52
  53 ;;; NOTE: don't use accessors here as they will return a list!
  54 ;;;       at least on SBCL
  55 (defclass standard-matrix-class (standard-class)
  56   ((element-type :initarg :element-type)
  57    (accumulator-type :initarg :accumulator-type)
  58    (specialized-array :initarg :specialized-array :initform nil)
  59    (val-format :initarg :val-format :initform nil)
  60    (minval :initarg :minval)
  61    (maxval :initarg :maxval)))
  62
  63 (let ((smc (find-class 'standard-matrix-class)))
  64   (defun standard-matrix-class-p (class)
  65     (subtypep (class-of class) smc)))
  66
  67 (defun standard-matrix-class-precedence-list (class)
  68   (remove-if-not
  69    #'(lambda (x) (standard-matrix-class-p x))
  70    (class-precedence-list class)))
  71
  72 (defun standard-matrix-class-slots (class)
  73   (let ((slots) (slot-names))
  74     (mapcar #'(lambda (x)
  75                 (mapcar #'(lambda (y)
  76                             (unless (member (slot-definition-name y)
  77                                             slot-names)
  78                               (push y slots)
  79                               (push (slot-definition-name y)
  80                                     slot-names)))
  81                         (class-direct-slots (class-of x))))
  82             (standard-matrix-class-precedence-list class))
  83     slots))
  84
  85 (defgeneric element-type (smc)
  86   (:documentation "the type of the elements of instances
  87 of this matrix class"))
  88 (defmethod element-type ((smc standard-matrix-class))
  89   (car (slot-value smc 'element-type)))
  90
  91 (defgeneric accumulator-type (smc)
  92   (:documentation "the type of the result of various mathematical
  93 opreations on instances of this matrix class. needs work."))
  94 (defmethod accumulator-type ((smc standard-matrix-class))
  95   (car (slot-value smc 'accumulator-type)))
  96
  97 ;;; FIXME! This is a hack to get around the fact that
  98 ;;; if we have a say, integer-matrix class, we can't
  99 ;;; make certain declarations. this needs to be fixed
 100 ;;; and hopefully removed
 101 (defgeneric specialized-array-p (smc))
 102 (defmethod specialized-array-p ((smc standard-matrix-class))
 103   (car (slot-value smc 'specialized-array)))
 104
 105 (defgeneric val-format (smc)
 106   (:documentation "the format string used to print out
 107 element values of instances of this matrix class"))
 108 (defmethod val-format ((smc standard-matrix-class))
 109   (car (slot-value smc 'val-format)))
 110
 111 ;;; FIXME this name is _way_ too close to min-val. Should
 112 ;;; be something like min-allowed-value or some such.
 113 ;;; also should be enforced more places if we're going to
 114 ;;; really use this!
 115 (defgeneric minval (smc)
 116   (:documentation "the minimum value allowed by instances
 117 of this matrix class."))
 118 (defmethod minval ((smc standard-matrix-class))
 119   (car (slot-value smc 'minval)))
 120
 121 ;;; FIXME this name is _way_ too close to max-val. Should
 122 ;;; be something like max-allowed-value or some such.
 123 ;;; also should be enforced more places if we're going to
 124 ;;; really use this!
 125 (defgeneric maxval (smc)
 126   (:documentation "the maximum value allowed by instances
 127 of this matrix class."))
 128 (defmethod maxval ((smc standard-matrix-class))
 129   (car (slot-value smc 'maxval)))
 130
 131
 132 ;;;
 133 ;;; Need validate-superclass for some reason. Read AMOP and fix this note
 134 ;;;
 135 (defmethod validate-superclass ((c1 standard-matrix-class) (c2 standard-class))
 136   t)
 137
 138 (defmethod validate-superclass ((c1 standard-class) (c2 standard-matrix-class))
 139   t)
 140
 141 (defun add-root-class (root-class direct-superclasses)
 142   (if (member root-class direct-superclasses)
 143       direct-superclasses
 144       (insert-before root-class
 145                      (car (class-direct-superclasses root-class))
 146                      direct-superclasses)))
 147
 148 (defclass typed-mixin ()
 149   ((specialzied-array :allocation :class :accessor specialized-array-p :initform nil)))
 150
 151 ;;; FIXME this needs work
 152 (defgeneric set-val-fit (m i j v &key truncate))
 153 (defmethod set-val-fit ((m typed-mixin) i j v &key (truncate nil))
 154   (set-val m i j (if truncate (truncate v) v)))
 155
 156 (defgeneric map-matrix-fit (f a))
 157 (defmethod map-matrix-fit (f (a typed-mixin))
 158   (destructuring-bind (m n) (dim a)
 159     (dotimes (i m)
 160       (dotimes (j n)
 161         (set-val-fit a i j (funcall f a i j)))))
 162   a)
 163
 164 (defmethod initialize-instance :around
 165     ((class standard-matrix-class) &rest all-keys &key direct-superclasses &allow-other-keys)
 166   (let ((root-class (find-class 'typed-mixin))
 167         (mc (find-class 'standard-matrix-class)))
 168     (if (and root-class (not (equal class root-class)))
 169         (if (member-if #'(lambda (super)
 170                            (eq (class-of super) mc)) direct-superclasses)
 171             (call-next-method)
 172             (apply #'call-next-method class
 173                    :direct-superclasses
 174                    (add-root-class root-class direct-superclasses)
 175                    (remove-keyword-arg all-keys :direct-superclasses)))
 176         (call-next-method)))
 177   (finalize-inheritance class)
 178   (fill-standard-matrix-class-slots-from-ancestors class all-keys))
 179
 180 (defmethod reinitialize-instance :around
 181     ((class standard-matrix-class) &rest all-keys &key direct-superclasses &allow-other-keys)
 182   (let ((root-class (find-class 'typed-mixin))
 183         (mc (find-class 'standard-matrix-class)))
 184     (if (and root-class (not (equal class root-class)))
 185         (if (member-if #'(lambda (super)
 186                            (eq (class-of super) mc)) direct-superclasses)
 187             (call-next-method)
 188             (apply #'call-next-method class
 189                    :direct-superclasses
 190                    (add-root-class root-class direct-superclasses)
 191                    (remove-keyword-arg all-keys :direct-superclasses)))
 192         (call-next-method)))
 193   (finalize-inheritance class)
 194   (fill-standard-matrix-class-slots-from-ancestors class all-keys))
 195