Coverage report: /home/ellis/comp/core/std/macs/sugar.lisp

KindCoveredAll%
expression6275 2.2
branch024 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; sugar.lisp --- Syntactic Sugar Macros
2
 
3
 ;; Utility macros to make our code a bit more sweet.
4
 
5
 ;;; Code:
6
 (in-package :std/macs)
7
 
8
 (defmacro def! (name &body body)
9
   "`defun' without args."
10
   `(defun ,name () ,@body))
11
 
12
 (defmacro eval-always (&body body)
13
   "Eval BODY in all contexts (:compile-toplevel :load-toplevel :execute)."
14
   `(eval-when (:compile-toplevel :load-toplevel :execute) ,@body))
15
 
16
 (defun compile-and-eval (form)
17
   "Compile and eval a FORM."
18
   (funcall (compile nil `(lambda () ,form))))
19
 
20
 (defun compile-and-eval* (form)
21
   "Splice, compile, and eval a FORM."
22
   (funcall (compile nil `(lambda () ,@form))))
23
 
24
 (defun compile-and-load (file &key (output-file ""))
25
   "Utility function which compiles a lisp FILE and loads the resulting fasl file."
26
   (load (compile-file (pathname file) :output-file output-file)))
27
 
28
 ;; from jackdaniel's Dynamic Slots, see also META/DYNAMIC
29
 (defmacro dlet (bindings &body body)
30
   "LET form -> PROGV form."
31
   (loop for (var val) in bindings
32
         collect var into vars
33
         collect val into vals
34
         finally (return `(progv (list ,@vars) (list ,@vals)
35
                            ,@body))))
36
 
37
 (defun without-props (plist props)
38
   "Return a new PLIST with all keys in PROPS dropped."
39
   (loop for (options value) on plist by #'cddr
40
         append (unless (member options props)
41
                  (list options value))))
42
 
43
 ;; TODO 2024-10-24: 
44
 (defmacro defclass* (name direct-superclasses direct-slots &rest opts)
45
   "Convenience wrapper for DEFCLASS - always binds the following slot args to
46
 default values unless overwritten at runtime:
47
 
48
 :INITARG
49
 :ACCESSOR"
50
   `(defclass ,name ,direct-superclasses 
51
      ,(mapcar (lambda (x) 
52
                 (etypecase x
53
                   (atom `(,x :initarg ,(sb-int:keywordicate x) :accessor ,(sb-int:symbolicate name '- x)))
54
                   (cons 
55
                    (let ((%name (car x))
56
                          (%args (cdr x)))
57
                      `(,%name ,@(std:acond
58
                                  ((getf x :initarg)
59
                                   (remf x :initarg)
60
                                   (if-let ((acc (getf x :accessor)))
61
                                     (progn
62
                                       (remf x :accessor)
63
                                       `(:initarg ,it :accessor ,acc ,@%args))
64
                                     `(:initarg ,it :accessor ,(sb-int:symbolicate name '- x) ,@%args)))
65
                                  ((getf x :accessor)
66
                                   (remf x :accessor)
67
                                   (if-let ((acc (getf x :intargr)))
68
                                     (progn
69
                                       (remf x :initarg)
70
                                       `(:accessor ,it :initarg ,acc ,@%args))
71
                                     `(:accessor ,it :initarg ,%name ,@%args)))))))))
72
        direct-slots)
73
      ,@opts))
74
 
75
 ;; Based on INCONGRUENT-METHODS:DEFINE-CLASS
76
 (defmacro define-class (name direct-superclasses direct-slots &body body)
77
   "Like DEFCLASS but with the forms in BODY acting as simplified method
78
 definitions."
79
   (with-gensyms (self)
80
     (labels ((slot-definition (x)
81
                (if (listp x)
82
                    (cons (first x)
83
                          (without-props (rest x)
84
                            '(:reader :writer :accessor)))
85
                    x))
86
              (slot-accessor-definition (x)
87
                (destructuring-bind (slot-name &rest options) x
88
                  (loop :for (options value) :on options :by #'cddr
89
                        :append
90
                           (case options
91
                             (:accessor
92
                              `((defmethod ,value ((,self ,name))
93
                                  (slot-value ,self ',slot-name))
94
                                (defmethod (setf ,value)
95
                                    (new (,self ,name))
96
                                  (setf (slot-value ,self ',slot-name) new))))
97
                             (:reader
98
                              `((defmethod ,value ((,self ,name))
99
                                  (slot-value ,self ',slot-name))))
100
                             (:writer
101
                              `((defmethod (setf ,value)
102
                                    (new (,self ,name))
103
                                  (setf (slot-value ,self ',slot-name) new))))))))
104
              (method-definition (definition)
105
                (destructuring-bind (method-name lambda-list &rest body)
106
                    definition
107
                  (if (listp method-name)
108
                      `(define-class-method ,method-name (,(first lambda-list)
109
                                                          (,(intern "SELF") ,name)
110
                                                          ,@(rest lambda-list))
111
                         ,@body)
112
                      `(define-class-method ,method-name ((,(intern "SELF") ,name)
113
                                                          ,@lambda-list)
114
                         ,@body)))))
115
       `(progn
116
          (defclass ,name ,direct-superclasses
117
            ,(mapcar #'slot-definition direct-slots))
118
          ,@(mapcan #'slot-accessor-definition
119
                    (remove-if-not #'listp direct-slots))
120
          ,@(mapcar #'method-definition body)))))
121
 
122
 ;;; Nest
123
 ;; I don't use this much, but it is quite handy.
124
 ;; ref: https://fare.livejournal.com/189741.html
125
 
126
 ;; in this case we just pull the version from UIOP
127
 (defmacro nest (&rest things)
128
   "Macro to keep code nesting and indentation under control." ;; Thanks to mbaringer
129
   (reduce #'(lambda (outer inner) `(,@outer ,inner))
130
           things :from-end t))
131
 
132
 ;;; Let extensions
133
 (defmacro letv* (bindings &rest body)
134
   "Extended LET* which handles multiple values, destructuring bind, and type declarations. 
135
 
136
 The declarations list VARS is similar to that in let.
137
 
138
 Examples:
139
 (macroexpand-1 `(letv* ((x 2 :type fixnum)
140
                         ((a &optional (c 2)) b (values (list 1) 3) :type (fixnum &optional (t)) t))
141
                   t))
142
 ;; (LET ((X 2))
143
 ;;       (DECLARE (TYPE FIXNUM X))
144
 ;;   (MULTIPLE-VALUE-BIND (#:G1120 B) (VALUES (LIST 1) 3)
145
 ;;     (DECLARE (TYPE T B))
146
 ;;     (DESTRUCTURING-BIND (A &OPTIONAL (C 2)) #:G1120
147
 ;;       (DECLARE (TYPE FIXNUM A)
148
 ;;                (TYPE T C))
149
 ;;       (PROGN T))))"
150
   (labels ((typedecl (syms alist)
151
              (let ((decls (remove-if #'null (mapcar #'(lambda (s)
152
                                                         (let ((ts (assoc s alist)))
153
                                                           (if (cdr ts)
154
                                                               `(type ,(cdr ts) ,s)
155
                                                               `(ignore ,s))))
156
                                                     syms))))
157
                (when decls `((declare ,@decls))))))
158
     (apply #'recursive-append
159
            (append
160
             (mapcan #'(lambda (x)
161
                         (destructuring-bind (bind expr type) (let ((tpos (position :type x)) (len (length x)))
162
                                                                (list (subseq x 0 (1- (or tpos len))) (nth (1- (or tpos len)) x) (when tpos (nthcdr (1+ tpos) x))))
163
                           (let* ((typa (loop for (s ty) on (flatten (zip-tree bind type))
164
                                              with skip? = nil
165
                                              if (or skip? (null s)) do (setf skip? nil)
166
                                              else 
167
                                              do (progn (setf skip? t)
168
                                                        (unless (member s cl:lambda-list-keywords)
169
                                                          (collect (cons s ty))))))
170
                                  (vsyms (mapcar #'(lambda (x) (if (consp x)
171
                                                                   (let ((g (gensym)))
172
                                                                     (list g
173
                                                                           `(destructuring-bind (,@x) ,g
174
                                                                              ,@(typedecl (flatten x) typa))))
175
                                                                   (list x)))
176
                                                 bind)))
177
                             (list*
178
                              (recursive-append
179
                               (if (> (length bind) 1)
180
                                   `(multiple-value-bind (,@(mapcar #'car vsyms)) ,expr)
181
                                   `(let ((,@(mapcar #'car vsyms) ,expr))))
182
                               (car (typedecl (mapcar #'car vsyms) typa)))
183
                              (remove-if #'null (mapcar #'cadr vsyms))))))
184
                     bindings)
185
             `((progn ,@body))))))
186
 
187
 (defmacro lety (bindings &rest body)
188
   "Like let, but also allows type-declarations with the key :type.
189
 
190
   Example:
191
   (macroexpand-1
192
     `(let-typed ((x 1 :type fixnum))
193
     (+ 1 x)))
194
   ;; (LET ((X 1))
195
   ;;   (DECLARE (TYPE FIXNUM X))
196
   ;;   (+ 1 X))"
197
   `(let (,@(mapcar #'(lambda (x) (subseq x 0 2)) bindings))
198
      ,@(let ((types (remove-if #'null (mapcar #'(lambda (x) (destructuring-bind (s e &key (type t)) x
199
                                                               (declare (ignore e))
200
                                                               (unless (eql type t)
201
                                                                 (if (null type)
202
                                                                     `(ignore ,s)
203
                                                                     `(type ,type ,s)))))
204
                                               bindings))))
205
          (when types `((declare ,@types))))
206
      ,@body))
207
 
208
 (defmacro lety* (bindings &rest body)
209
   "Like let*, but also allows type-declarations with the key :type.
210
 
211
 Example:
212
 (macroexpand-1
213
   `(let*-typed ((x 1 :type fixnum))
214
       (+ 1 x)))
215
 ;; (LET* ((X 1))
216
 ;;   (DECLARE (TYPE FIXNUM X))
217
 ;;   (+ 1 X))"
218
   `(let* (,@(mapcar #'(lambda (x) (subseq x 0 2)) bindings))
219
      ,@(let ((types (remove-if #'null
220
                                (mapcar #'(lambda (x) (destructuring-bind (s e &key (type t)) x
221
                                                        (declare (ignore e))
222
                                                        (unless (eql type t)
223
                                                          (if (null type)
224
                                                              `(ignore ,s)
225
                                                              `(type ,type ,s)))))
226
                                        bindings))))
227
          (when types `((declare ,@types))))
228
      ,@body))