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