vol-macro-macros.lisp

   1 ;; utilities that are used in vol to write macros
   2 ;; mostly its used to write functions for different ranks or types
   3
   4 (in-package :vol)
   5
   6
   7 (let ((type-names '(((complex double-float) . cdf)
   8                     ((complex single-float) . csf)
   9                     (double-float . df)
  10                     (single-float . sf)
  11                     ((signed-byte 16) . sb16)
  12                     ((unsigned-byte 16) . ub16)
  13                     ((unsigned-byte 8) . ub8))))
  14   (defun get-short-type (long-type)
  15     (cdr (assoc long-type type-names)))
  16   (defun get-long-type (short-type)
  17     (car (rassoc short-type type-names))))
  18
  19 #+nil
  20 (get-long-type 'df)
  21
  22 (defmacro format-symbol (fmt &rest rest)
  23   `(intern (string-upcase (format nil ,fmt ,@rest))))
  24
  25 (defparameter *macro-generated-functions* nil)
  26 (defun store-new-function (name)
  27   (push name *macro-generated-functions*))
  28
  29 ;; macro that defines another macro that in turn will define functions
  30 ;; handling different ranks and types. should be called like this:
  31 ;; (def-generator (fftshift rank type) ... ). the name of the new
  32 ;; macro will be def-fftshift-rank-type and when it is invoked the
  33 ;; generated function name will be pushed into
  34 ;; *macro-generated-functions*. this can be used to build the list of
  35 ;; exported symbols. if spec contains the symbol type, than a
  36 ;; long-type will be generated. the variable name should be used to
  37 ;; define the name of the function. here is an example:
  38
  39 ;; (def-generator (fftshift (rank type))
  40 ;;   `(defun ,name (in)
  41 ;;      (declare ((simple-array ,long-type ,rank) in))))
  42
  43 ;; now we can interpolate into a function with the following call
  44
  45 ;; (def-fftshift-rank-type 2 sf)
  46
  47 ;; the new function looks like this:
  48
  49 ;; (DEFUN DEF-FFTSHIFT-2-SF (IN)
  50 ;;   (DECLARE ((SIMPLE-ARRAY SINGLE-FLOAT 2) IN)))
  51
  52 ;; when a new macro is needed to generate a lot of functions (and
  53 ;; maybe one dispatch function) it should be called def-...-functions.
  54
  55 (defmacro def-generator ((name spec) &body body)
  56   (let ((macro-name (format-symbol "def-~a~{-~a~}" name spec))
  57         (function-fmt (let ((result (format nil "~a" name)))
  58                         (dotimes (i (length spec))
  59                           (setf result (concatenate 'string result (format nil "-~~a"))))
  60                         result)))
  61     `(defmacro ,macro-name ,spec
  62        (let ((name (format-symbol ,function-fmt ,@spec))
  63              ,(when (member 'type spec)
  64                     `(long-type (get-long-type type))))
  65          (store-new-function name)
  66          ,@body))))
  67
  68 #+nil
  69 (def-generator (fftshift (rank type))
  70   `(defun ,name (in)
  71      (declare ((simple-array ,long-type ,rank) in))))
  72 #+nil
  73 (def-fftshift-rank-type 2 sf)
  74 #+nil
  75 (fftshift-2-sf )
  76
  77 ;; given two lists the following macros get the outer product, a 2d
  78 ;; matrix spanning all the combinations. everything is pushed into a
  79 ;; 1d stack whose value can be altered by the optional parameter
  80 ;; return-sexpr. for use in macros progn is a useful return-sexpr.
  81
  82 (defmacro def-outer-cross (la lb func &optional return-sexpr)
  83   (let ((result nil))
  84     (loop for a in la do
  85          (loop for b in lb do
  86               (when (,predicate ,a ,b)
  87                (push `(,func ,a ,b)
  88                      result))))
  89     (if return-sexpr
  90         `(,return-sexpr ,@result)
  91         `(,@result))))
  92 #+nil
  93 (def-outer-cross (1 2 3) (sf df csf cdf) def-fftshift-rank-type progn)
  94 #+nil
  95 (def-outer-cross (1 2 3) (1 2 3) def)