/usr/share/common-lisp/source/metatilities-base/dev/l0-macros.lisp is in cl-metatilities-base 20170403-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 | (in-package #:metatilities)
(defmacro nyi (&rest args)
"Signals an error saying that this function is not yet implemented. The args
are ignored, but by supplying args from the calling function, you can get them
ignored by the compiler."
`(error "This function is not yet implemented for ~A ~A on ~A."
(lisp-implementation-type)
(lisp-implementation-version)
(machine-type)
. ,args))
(defmacro deprecated (&body body)
"Wrap a function definition with `deprecated' to indicate that it should
no longer be used. If the first element of body is a string, it will be used
as additional documentation in the deprecation message. Foo example,
\(deprecated
\"Use bar instead.\"
\(defun foo-1 \(x\)
\(format t \"~%FOO: ~A\" x\)\)\)
Will generate the message:
; warning FOO-1 has been deprecated. Use bar instead.
at compile time whereever foo-1 is used."
(let ((documentation nil)
(name nil))
(when (stringp (first body))
(setf documentation (first body)
body (rest body)))
(setf name (cadar body))
`(progn
(define-compiler-macro ,name (&whole form &rest args)
(declare (ignore args))
(fresh-line *error-output*)
(write-string ,(format nil "~%; warning ~a has been deprecated.~@[ ~A~]"
name documentation) *error-output*)
(terpri *error-output*)
(values form))
,@body)))
(defmacro once-only (variable-list &body body)
"Generate code that evaluates certain expressions only once.
This is used in macros, for computing expansions.
VARIABLE-LIST is a list of symbols, whose values are subexpressions
to be substituted into a larger expression. BODY is what uses those
symbols' values and constructs the larger expression.
ONCE-ONLY modifies BODY so that it constructs a different expression,
which when run will evaluate the subsexpressions only once, save the
values in temporary variables, and use those from then on.
Example:
\(DEFMACRO DOUBLE (ARG) `(+ ,ARG ,ARG)) expands into code that computes ARG twice.
\(DEFMACRO DOUBLE (ARG) (ONCE-ONLY (ARG) `(+ ,ARG ,ARG))) will not."
(dolist (variable variable-list)
(if (not (symbolp variable))
(error "~S is not a variable" variable)))
(let ((bind-vars (gensym))
(bind-vals (gensym))
(tem (gensym)))
`(let ((,bind-vars nil)
(,bind-vals nil))
(let ((result ((lambda ,variable-list . ,body)
. ,(loop for variable in variable-list
collect `(if (let ((variable ,variable))
(loop
(when (atom variable) (return t))
(when (or (eq (car variable) 'quote)
(eq (car variable) 'function))
(return t))
(if (eq (car variable) 'the)
(setf variable (cadr (cdr variable)))
(return nil))))
,variable
(let ((,tem (gensym)))
(push ,tem ,bind-vars)
(push ,variable ,bind-vals)
,tem))))))
(if (null ,bind-vars)
result
`((lambda
,(nreverse ,bind-vars) ,result) . ,(nreverse ,bind-vals)))))))
(defmacro with-variables (symbols &body body)
"Using gensyms is necessary to prevent variables produced by macro expansions
from interfering with user variables, and naming them mnemonically helps make
macro expansions and compiled code easier to read, but it's a pain to create
them properly. This macro creates them for you, which makes writing nice macros
easier. For example, if you are writing a macro to iterate over an array, you
used to have to write:
(defmacro do-2d-array ((elt array) &body body)
(let ((row (gensym \"ROW\"))
(col (gensym \"COL\")))
`(dotimes (,row (array-dimension 0))
(dotimes (,col ,(array-dimension 1))
(let ((,elt (aref ,array ,row ,col)))
. ,body)))))
Now you can just write the following, which eliminates the need to laboriously
create the mnemonic gensyms.
(defmacro do-2d-array ((elt array) &body body)
(with-variables (row col)
`(dotimes (,row ,(array-dimension 0))
(dotimes (,col ,(array-dimension 1))
(let ((,elt (aref ,array ,row ,col)))
. ,body))))
"
`(let ,(mapcar #'(lambda (sym)
`(,sym (newsym ,(symbol-name sym))))
symbols)
. ,body))
;; a simple shorthand
(defmacro eval-always (&body body)
"Expands into an eval-when with all the fixings. It's nothing but a shorthand."
`(eval-when (:compile-toplevel :load-toplevel :execute)
,@body))
(defmacro defclass-property (property &optional (default nil default-supplied?))
"Create getter and setter methods for 'property' on symbol's property lists."
(once-only (property)
(let ((real-name (form-keyword property)))
`(progn
(defgeneric ,property (class-name)
(:documentation
,(format nil "Returns the value of `~(~A~)` for class-name"
property)))
(defgeneric (setf ,property) (value symbol)
(:documentation
,(format nil "Sets the value of `~(~A~)` for class-name"
property)))
(defmethod ,property ((class-name symbol))
(get class-name ,real-name
,@(when default-supplied? (list default))))
(defmethod (setf ,property) (value (class-name symbol))
(setf (get class-name ,real-name) value))))))
#+(or allegro clisp)
;; everyone else already defines this...
(defmacro without-interrupts (&body forms)
"Executes `forms' as a critical section; no other threads can get in."
;; Because this macro will appear in user code (eg, the priority queue
;; code), whether there is multi-threading or not, we have to expand to
;; something, so we expand to progn. The :eksl-generic-load-utils feature
;; is used as an otherwise case, since it will be defined as long as this
;; code is being loaded via our loading procedure.
(or
#+allegro
`(excl:without-interrupts . ,forms)
;; just in case...
;; default
`(progn . ,forms)))
;;; This is a more portable name, IMO. It can't hurt.
(defmacro with-atomic-execution (&body forms)
`(without-interrupts
,@forms))
(defmacro handler-bind* (binds &rest body)
"Special handler-bind which allow two special control contructs
inside of the condition handlers. resume will resume execution
past the handler-bind*. retry will execute the code from body,
i.e. so you usually fix the problem and then call retry."
(let ((catch-tag (gensym)))
`(catch ',catch-tag
(flet ((:resume () (throw ',catch-tag 0))
(:retry () ,@body))
(handler-bind ,binds
(:retry))))))
(defmacro with-gensyms (syms &body body)
`(let ,(mapcar #'(lambda (s)
`(,s (gensym)))
syms)
,@body))
(defvar *file-if-exists* :supersede
"Default behavior to use when opening files if they already exist.")
(defvar *file-print-right-margin* nil
"Default print right margin to use in with-new-file")
(defmacro with-new-file ((stream pathname &rest args &key
(reset-io t)
(print-right-margin *file-print-right-margin*)
&allow-other-keys)
&body body)
(remf args :reset-io)
(remf args :print-right-margin)
`(progn
(ensure-directories-exist ,pathname)
(with-open-file (,stream ,pathname
:if-exists *file-if-exists*
:if-does-not-exist :create
:direction :output
,@args)
(let ((*print-right-margin*
(or ,print-right-margin *print-right-margin*)))
,@(if reset-io
(with-gensyms (the-package)
`((let ((,the-package *package*))
(with-standard-io-syntax
(let ((*package* ,the-package))
,@body)))))
body)))))
(defmacro with-stream-from-specifier ((stream stream-specifier direction
&rest args)
&body body)
(with-gensyms (s close? output)
`(let (,s (,close? t) ,output)
(unwind-protect
(setf ,output
(prog1
(let (,stream)
(setf (values ,s ,close?)
(make-stream-from-specifier
,stream-specifier ,direction ,@args)
,stream ,s)
,@body)))
(when (and ,close? ,s)
(let ((it (close-stream-specifier ,s)))
(when it
(setf ,output it)))))
,output)))
(defmacro with-input ((var source &rest args) &body body)
"Create an input stream from source and bind it to var within the body of the with-input form. The stream will be closed if necessary on exit."
`(with-stream-from-specifier (,var ,source :input ,@args)
,@body))
(defmacro with-output ((var destination &rest args) &body body)
"Create an output stream from source and bind it to var within the body of the with-output form. The stream will be closed if necessary on exit."
`(with-stream-from-specifier (,var ,destination :output ,@args)
,@body))
(defmacro muffle-redefinition-warnings (&body body)
"Evaluate the body so that redefinition warnings will not be
signaled. (suppored in Allegro, Clozure CL, CLisp, and Lispworks)"
#+allegro
`(excl:without-redefinition-warnings
,@body)
#+(or ccl mcl)
`(let ((ccl::*warn-if-redefine* nil)
;;?? FIXME not sure if this should be here or not...
(ccl::*record-source-file* nil))
,@body)
#+clisp
`(let ((custom:*suppress-check-redefinition* t))
,@body)
#+lispworks
`(let ((lw:*handle-warn-on-redefinition* :quiet))
,@body)
#+sbcl
;; from http://www.sbcl.info/manual/Controlling-Verbosity.html
`(locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
,@body)
#-(or allegro ccl clisp mcl)
`(progn ,@body))
|