external/clem/src/macros.lisp

   1
   2 (in-package :clem)
   3
   4 (defmacro def-unary-op (name op type-1 accumulator-type &key suffix)
   5   (let ((element-type-1 (element-type (find-class `,type-1)))
   6         (accumulator-element-type (element-type (find-class `,accumulator-type))))
   7     `(progn
   8        (defmethod ,(ch-util:make-intern (concatenate 'string name "-range" suffix))
   9            ((m ,type-1)  startr endr startc endc &key in-place)
  10          (destructuring-bind (mr mc) (dim m)
  11            (if in-place
  12                (with-typed-mref (m ,element-type-1)
  13                  (do ((i startr (1+ i)))
  14                      ((> i endr))
  15                    (declare (dynamic-extent i) (type fixnum i))
  16                    (do ((j startc (1+ j)))
  17                        ((> j endc))
  18                      (declare (dynamic-extent j) (type fixnum j))
  19                      (setf (mref m i j)
  20                            (,op (mref m i j)))))
  21                  m)
  22                (let ((p (make-instance ',accumulator-type :rows mr :cols mc)))
  23                  (with-typed-mref (m ,element-type-1)
  24                    (with-typed-mref (p ,accumulator-element-type)
  25                      (do ((i startr (1+ i)))
  26                          ((> i endr))
  27                        (declare (dynamic-extent i) (type fixnum i))
  28                        (do ((j startc (1+ j)))
  29                            ((> j endc))
  30                          (declare (dynamic-extent j) (type fixnum j))
  31                          (setf (mref p i j)
  32                                (,op (mref m i j)))))))
  33                  p))))
  34
  35        (defmethod ,(ch-util:make-intern (concatenate 'string name suffix))
  36            ((m ,type-1) &key in-place)
  37          (if in-place
  38              (with-typed-mref (m ,element-type-1)
  39                (loop for i from 0 below (matrix-total-size m)
  40                   do (setf (row-major-mref m i)
  41                            (,op (row-major-mref m i))))
  42                m)
  43              (let ((p (make-instance ',accumulator-type :dimensions (matrix-dimensions m))))
  44                (with-typed-mref (m ,element-type-1)
  45                  (with-typed-mref (p ,accumulator-element-type)
  46                    (loop for i from 0 below (matrix-total-size m)
  47                       do (setf (row-major-mref p i)
  48                                (,op (row-major-mref m i))))))
  49                p))))))
  50
  51 (defmacro def-binary-op (name op type-1 type-2 accumulator-type &key suffix (allow-in-place t))
  52   (let ((element-type-1 (element-type (find-class `,type-1)))
  53         (element-type-2 (element-type (find-class `,type-2)))
  54         (accumulator-element-type (element-type (find-class `,accumulator-type))))
  55     `(progn
  56        (defmethod ,(ch-util:make-intern (concatenate 'string name "-range" suffix))
  57            ((m ,type-1) (n ,type-2) startr endr startc endc &key in-place)
  58          (destructuring-bind (mr mc) (dim m)
  59            (if in-place
  60                ,(if allow-in-place
  61                     `(with-typed-mref (m ,element-type-1)
  62                        (with-typed-mref (n ,element-type-2)
  63                          (do ((i startr (1+ i)))
  64                              ((> i endr))
  65                            (declare (dynamic-extent i) (type fixnum i))
  66                            (do ((j startc (1+ j)))
  67                                ((> j endc))
  68                              (declare (dynamic-extent j) (type fixnum j))
  69                              (setf (mref m i j)
  70                                    (,op (mref m i j) (mref n i j))))))
  71                        m)
  72                     `(error 'matrix-argument-error
  73                             :format-control
  74                             "in-place operation not allowed (~S of ~S and ~S"
  75                             :format-arguments (list '+ ',type-1 ',type-2)))
  76                (let ((p (make-instance ',accumulator-type :rows mr :cols mc)))
  77                  (with-typed-mref (m ,element-type-1)
  78                    (with-typed-mref (p ,accumulator-element-type)
  79                      (with-typed-mref (n ,element-type-2)
  80                        (do ((i startr (1+ i)))
  81                            ((> i endr))
  82                          (declare (dynamic-extent i) (type fixnum i))
  83                          (do ((j startc (1+ j)))
  84                              ((> j endc))
  85                            (declare (dynamic-extent j) (type fixnum j))
  86                            (setf (mref p i j)
  87                                  (,op (mref m i j) (mref n i j))))))))
  88                  p))))
  89
  90        (defmethod ,(ch-util:make-intern (concatenate 'string name suffix))
  91            ((m ,type-1) (n ,type-2) &key in-place)
  92          (if in-place
  93              ,(if allow-in-place
  94                   `(with-typed-mref (m ,element-type-1)
  95                      (with-typed-mref (n ,element-type-2)
  96                        (loop for i from 0 below (matrix-total-size m)
  97                           do (setf (row-major-mref m i)
  98                                    (,op (row-major-mref m i) (row-major-mref n i)))))
  99                      m)
 100                   `(error 'matrix-argument-error
 101                             :format-control
 102                             "in-place operation not allowed (~S of ~S and ~S"
 103                             :format-arguments (list '+ ',type-1 ',type-2)))
 104              (let ((p (make-instance ',accumulator-type :dimensions (matrix-dimensions m))))
 105                (with-typed-mref (m ,element-type-1)
 106                  (with-typed-mref (n ,element-type-2)
 107                    (with-typed-mref (p ,accumulator-element-type)
 108                      (loop for i from 0 below (matrix-total-size m)
 109                         do (setf (row-major-mref p i)
 110                                  (,op (row-major-mref m i) (row-major-mref n i)))))))
 111                p))))))
 112
 113
 114