1 ;; utilities that are used in vol to write macros
2 ;; mostly its used to write functions for different ranks or types
7 (let ((type-names '(((complex double-float
) . cdf
)
8 ((complex single-float
) . csf
)
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
)))
17 (defun get-long-type (short-type)
18 (car (rassoc short-type type-names
))))
23 (defmacro format-symbol
(fmt &rest rest
)
24 `(intern (string-upcase (format nil
,fmt
,@rest
))))
26 (defparameter *macro-generated-functions
* nil
)
27 (defun store-new-function (name)
28 (push name
*macro-generated-functions
*))
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:
40 ;; (def-generator (fftshift (rank type))
42 ;; (declare ((simple-array ,long-type ,rank) in))))
44 ;; now we can interpolate into a function with the following call
46 ;; (def-fftshift-rank-type 2 sf)
48 ;; the new function looks like this:
50 ;; (DEFUN DEF-FFTSHIFT-2-SF (IN)
51 ;; (DECLARE ((SIMPLE-ARRAY SINGLE-FLOAT 2) IN)))
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.
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"))))
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
))
70 (def-generator (fftshift (rank type
))
72 (declare ((simple-array ,long-type
,rank
) in
))))
74 (def-fftshift-rank-type 2 sf
)
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.
83 (defmacro def-outer-cross
(la lb func
&optional return-sexpr
)
90 `(,return-sexpr
,@result
)
93 (def-outer-cross (1 2 3) (sf df csf cdf
) def-fftshift-rank-type progn
)
95 (def-outer-cross (1 2 3) (1 2 3) def
)