cepl/base-macros.lisp at master · m-g-r/cepl · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
;; This software is Copyright (c) 2012 Chris Bagley
;; (techsnuffle<at>gmail<dot>com)
;; Chris Bagley grants you the rights to
;; distribute and use this software as governed
;; by the terms of the Lisp Lesser GNU Public License
;; (http://opensource.franz.com/preamble.html),
;; known as the LLGPL.

;; a load of handy macros to use around the place
;; the base-* packages are meant to be 'used' so that
;; there is no need to write the package name.

(in-package :base-macros)

;;;--------------------------------------------------------------

(defmacro once-only ((&rest names) &body body)
  (let ((gensyms (loop for n in names collect (gensym))))
    `(let (,@(loop for g in gensyms collect `(,g (gensym))))
      `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
        ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
           ,@body)))))

;;;--------------------------------------------------------------

(defmacro continuable (&body body)
  "Helper macro that we can use to allow us to continue from an
   error. Remember to hit C in slime or pick the restart so
   errors don't kill the app."
  `(restart-case
       (progn ,@body)
     (continue () :report "CEPL Continue")))

;----------------------------------------------------------------
;;
(defmacro apply-across-elements (call array-forms
			     num-of-elms &body body)
  "This is a helper macro to limit the amount of ugly code
   in some of the maths libraries. See the following for 2
   examples of how it is used:
   ;; (apply-across-elements make-vector3 ((vc-a vector-a)) 3
   ;;   (* vc-a b)))

   ;; (MAKE-VECTOR3 (* (AREF VECTOR-A 0) B)
   ;;               (* (AREF VECTOR-A 1) B)
   ;; 	         (* (AREF VECTOR-A 2) B))


   ;; (apply-to-elements make-matrix3 ((vc-a mat-a)
   ;;                                  (vc-b mat-b)) 9
   ;;   (+ vc-a vc-b))

   ;; (MAKE-MATRIX3 (+ (AREF MAT-A 0) (AREF MAT-B 0))
   ;; 	         (+ (AREF MAT-A 1) (AREF MAT-B 1))
   ;; 	         (+ (AREF MAT-A 2) (AREF MAT-B 2))
   ;; 	         (+ (AREF MAT-A 3) (AREF MAT-B 3))
   ;; 	         (+ (AREF MAT-A 4) (AREF MAT-B 4))
   ;; 	         (+ (AREF MAT-A 5) (AREF MAT-B 5))
   ;; 	         (+ (AREF MAT-A 6) (AREF MAT-B 6))
   ;; 	         (+ (AREF MAT-A 7) (AREF MAT-B 7))
   ;; 	         (+ (AREF MAT-A 8) (AREF MAT-B 8)))"
  (labels ((subst-many (el-num tree swap-list)
	     (if (null swap-list)
		 tree
		 (subst-many el-num
			     (let* ((form (car swap-list))
				    (old (car form))
				    (new `(aref ,(cadr form)
						,el-num)))
			       (subst new old tree))
			     (cdr swap-list))))
	   (gen-line (&optional (el-num 0))
	     (if (< el-num num-of-elms)
		 (cons (subst-many el-num (car body) array-forms)
		       (gen-line (+ el-num 1)))
		 nil)))
    `(,call ,@(gen-line))))

;----------------------------------------------------------------