Coverage report: /home/ellis/comp/core/std/prim.lisp

KindCoveredAll%
expression2285 0.7
branch026 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; prim.lisp --- Primitive Macros
2
 
3
 ;; 
4
 
5
 ;;; Code:
6
 (in-package :std/prim)
7
 
8
 ;;; EARLY MACROS
9
 (eval-when (:compile-toplevel :load-toplevel :execute)
10
   (defun g!-symbol-p (s)
11
     "Return T if S is a G!-symbol (gensym'd)."
12
     (and (symbolp s)
13
          (> (length (symbol-name s)) 2)
14
          (string= (symbol-name s)
15
                   "G!"
16
                   :start1 0
17
                   :end1 2)))
18
 
19
   (defun o!-symbol-p (s)
20
     "Return T if S is a O!-symbol (oneshot)."
21
     (and (symbolp s)
22
          (> (length (symbol-name s)) 2)
23
          (string= (symbol-name s)
24
                   "O!"
25
                   :start1 0
26
                   :end1 2)))
27
 
28
   (defun o!-symbol-to-g!-symbol (s)
29
     "Convert O!-symbol S to a G!-symbol."
30
     (symb "G!" (subseq (symbol-name s) 2))))
31
 
32
 (defmacro defmacro/g! (name args &body body)
33
   "Define a macro with G!-symbols in ARGS automatically converted to gensyms."
34
   (let ((syms (remove-duplicates
35
                (remove-if-not #'g!-symbol-p
36
                               (flatten* body)))))
37
     (multiple-value-bind (body declarations docstring)
38
         (parse-body body :documentation t)
39
       `(defmacro ,name ,args
40
          ,@(when docstring
41
              (list docstring))
42
          ,@declarations
43
          (let ,(mapcar
44
                 (lambda (s)
45
                   `(,s (gensym ,(subseq
46
                                  (symbol-name s)
47
                                  2))))
48
                 syms)
49
            ,@body)))))
50
 
51
 (defmacro defmacro! (name args &body body)
52
   "Define a macro with G!-symbols in ARGS converted to gensyms and O!-symbols
53
 evaluated once and bound to a G!-symbol for use in BODY."
54
   (let* ((os (remove-if-not #'o!-symbol-p (flatten* args)))
55
          (gs (mapcar #'o!-symbol-to-g!-symbol os)))
56
     (multiple-value-bind (body declarations docstring)
57
         (parse-body body :documentation t)
58
       `(defmacro/g! ,name ,args
59
          ,@(when docstring
60
              (list docstring))
61
          ,@declarations
62
          `(let ,(mapcar #'list (list ,@gs) (list ,@os))
63
             ,(progn ,@body))))))
64
 
65
 (defmacro defun! (name args &body body)
66
   "Define a function with G!-symbols in ARGS automatically converted."
67
   (let ((syms (remove-duplicates
68
                (remove-if-not #'g!-symbol-p
69
                               (flatten* body)))))
70
     (multiple-value-bind (body declarations docstring)
71
         (parse-body body :documentation t)
72
       `(defun ,name ,args
73
          ,@(when docstring
74
              (list docstring))
75
          ,@declarations
76
          (let ,(mapcar (lambda (s)
77
                          `(,s (gensym ,(subseq (symbol-name s)
78
                                                2))))
79
                 syms)
80
            ,@body)))))
81
 
82
 ;;; Util
83
 (defun unquote-args (lst args)
84
   "Makes a list suitable for use inside macros (sort-of), by building a
85
 new list quoting every symbol in @arg{lst} other than those in @arg{args}.
86
 CAUTION: DO NOT use backquotes!
87
 
88
 @lisp
89
 Example:
90
 > (unquote-args '(+ x y z) '(x y))
91
 => (LIST '+ X Y 'Z)
92
 
93
 > (unquote-args '(let ((x 1)) (+ x 1)) '(x))
94
 => (LIST 'LET (LIST (LIST X '1)) (LIST '+ X '1))
95
 @end lisp"
96
   (maptree-if #'(lambda (x) (or (symbolp x) (consp x)))
97
               #'(lambda (x) (etypecase x
98
                               (symbol (if (member x args) x `(quote ,x)))
99
                               (cons (values `(list ,@x) #'(lambda (f x) (cons (first x) (mapcar f (cdr x))))))))
100
               lst))
101
 
102
 (defmacro definline (name lambda-list &body body)
103
   "Define an inlined function."
104
   `(progn
105
      (declaim (inline ,name))
106
      (defun ,name ,lambda-list ,@body)))
107
 
108
 (defmacro defnotinline (name lambda-list &body body)
109
   `(progn
110
      (declaim (notinline ,name))
111
      (defun ,name ,lambda-list ,@body)))
112
 
113
 (defmacro with-optimization ((&rest args) &body body)
114
   "Create a local environment with optimization declarations ARGS and execute
115
 BODY.
116
 
117
 Example:
118
 (macroexpand-1
119
   `(with-optimization (:speed 2 :safety 3)
120
   (+ 1d0 2d0)))
121
 ;; (LOCALLY (DECLARE (OPTIMIZE (SPEED 2) (SAFETY 3))) (+ 1.0d0 2.0d0))"
122
   `(locally
123
        ,(recursive-append
124
          `(declare (optimize ,@(multiple-value-call #'mapcar #'(lambda (key val) (list (intern (symbol-name key)) val))
125
                                                     (loop :for ele :in args
126
                                                        :counting t :into cnt
127
                                                        :if (oddp cnt)
128
                                                          :collect ele into key
129
                                                        :else
130
                                                          :collect (progn (assert (member ele '(0 1 2 3))) ele) into val
131
                                                        :finally (return (values key val))))))
132
          (when (and (consp (car body)) (eq (caar body) 'declare))
133
            (cdar body)))
134
      ,@(if (and (consp (car body)) (eq (caar body) 'declare)) (cdr body) body)))
135
 
136
 (defmacro macrofy (lambda-func)
137
   "Macrofies a lambda function, for use later inside macros. Returns a
138
 macro-function like function which can be called later for use
139
 inside macros.
140
 
141
 DO NOT USE backquotes in the lambda function!
142
 
143
 Example:
144
 (macroexpand-1 `(macrofy (lambda (x y z) (+ (sin x) y (apply #'cos (list z))))))
145
 ;; (LAMBDA (X Y Z)
146
 ;;   (LIST '+ (LIST 'SIN X) Y (LIST 'APPLY (LIST 'FUNCTION 'COS) (LIST 'LIST Z))))
147
 ;; T
148
 
149
 (funcall (macrofy (lambda (x y z) (+ (sin x) y (apply #'cos (list z))))) 'a 'b 'c)
150
 ;; (+ (SIN A) B (APPLY #'COS (LIST C)))"
151
   (destructuring-bind (labd args &rest body) lambda-func
152
     (assert (eq labd 'lambda))
153
     `(lambda ,args ,@(cdr (unquote-args body args)))))
154
 
155
 (defmacro with-marking (&rest body)
156
   "
157
  This macro basically declares local-variables globally,
158
  while keeping semantics and scope local.
159
 
160
 Example:
161
 (macroexpand-1
162
   `(with-marking
163
        (loop :for i := 0 :then (1+ i)
164
           :do (mark* ((xi (* 10 2) :type index-type)
165
                   (sum 0 :type index-type))
166
                  (incf sum (mark (* 10 2)))
167
                  (if (= i 10)
168
                      (return sum))))))
169
 
170
 ;; (LET* ((#:G1083 (* 10 2)) (#:SUM1082 0) (#:XI1081 (* 10 2)))
171
 ;;   (DECLARE (TYPE INDEX-TYPE #:SUM1082)
172
 ;;       (TYPE INDEX-TYPE #:XI1081))
173
 ;;   (LOOP :FOR I := 0 :THEN (1+ I)
174
 ;;         :DO (SYMBOL-MACROLET ((XI #:XI1081) (SUM #:SUM1082))
175
 ;;          (INCF SUM #:G1083)
176
 ;;          (IF (= I 10)
177
 ;;              (RETURN SUM)))))
178
 ;; T"
179
   (let* ((decls nil)
180
          (types nil)
181
          (code (maptree '(:mark* :mark :memo)
182
                         #'(lambda (mrk)
183
                             (ecase (car mrk)
184
                               (:mark*
185
                                `(symbol-macrolet (,@(mapcar #'(lambda (decl) (destructuring-bind (ref code &key type) decl
186
                                                                                (let ((rsym (gensym (symbol-name ref))))
187
                                                                                  (push `(,rsym ,code) decls)
188
                                                                                  (when type
189
                                                                                    (push `(type ,type ,rsym) types))
190
                                                                                  `(,ref ,rsym))))
191
                                                             (cadr mrk)))
192
                                   ,@(cddr mrk)))
193
                               (:mark
194
                                (destructuring-bind (code &key type) (cdr mrk)
195
                                  (let ((rsym (gensym)))
196
                                    (push `(,rsym ,code) decls)
197
                                    (when type
198
                                      (push `(type ,type ,rsym) types))
199
                                    rsym)))
200
                               (:memo
201
                                (destructuring-bind (code &key type) (cdr mrk)
202
                                  (let ((memo (find code decls :key #'cadr :test #'tree-equal)))
203
                                    (if memo
204
                                        (car memo)
205
                                        (let ((rsym (gensym)))
206
                                          (push `(,rsym ,code) decls)
207
                                          (when type
208
                                            (push `(type ,type ,rsym) types))
209
                                          rsym)))))))
210
                         body)))
211
     `(let* (,@decls)
212
        ,@(when types `((declare ,@types)))
213
        ,@code)))
214
 
215
 (defun defunits-chaining (u units prev)
216
   (if (member u prev)
217
       (error "~{ ~a~^ depends on~}"
218
              (cons u prev)))
219
   (let ((spec (find u units :key #'car)))
220
     (if (null spec)
221
         (error "Unknown unit ~a" u)
222
         (let ((chain (cadr spec)))
223
           (if (listp chain)
224
               (* (car chain)
225
                  (defunits-chaining
226
                      (cadr chain)
227
                    units
228
                    (cons u prev)))
229
               chain)))))
230
 
231
 ;;; Gensyms
232
 (defmacro using-gensyms ((decl (&rest syms) &optional gensyms) &rest body)
233
   `(let ((,decl (zip-list ',(mapcar #'(lambda (x) (gensym (symbol-name x))) syms) (list ,@syms))))
234
      (destructuring-bind (,@syms) (mapcar #'car ,decl)
235
        ,(append
236
          (if gensyms
237
            `(with-gensyms (,@gensyms)) `(progn))
238
          body))))
239
 
240
 (defmacro binding-gensyms ((mname &optional (fname (gensym))) &rest body)
241
   (with-gensyms (htbl)
242
     `(let ((,htbl (make-hash-table)))
243
        (labels ((,fname (x) (or (gethash x ,htbl) (setf (gethash x ,htbl) (gensym (symbol-name x))))))
244
          (macrolet ((,mname (x) `(,', fname ',x)))
245
            ,@body)))))