Commit | Line | Data |
---|---|---|
861345b4 | 1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; $Id$ | |
4 | ;;; | |
5 | ;;; Basic definitions | |
6 | ;;; | |
7 | ;;; (c) 2005 Mark Wooding | |
8 | ;;; | |
9 | ||
10 | ;;;----- Licensing notice --------------------------------------------------- | |
11 | ;;; | |
12 | ;;; This program is free software; you can redistribute it and/or modify | |
13 | ;;; it under the terms of the GNU General Public License as published by | |
14 | ;;; the Free Software Foundation; either version 2 of the License, or | |
15 | ;;; (at your option) any later version. | |
16 | ;;; | |
17 | ;;; This program is distributed in the hope that it will be useful, | |
18 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 | ;;; GNU General Public License for more details. | |
21 | ;;; | |
22 | ;;; You should have received a copy of the GNU General Public License | |
23 | ;;; along with this program; if not, write to the Free Software Foundation, | |
24 | ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. | |
25 | ||
02866e07 MW |
26 | ;;;-------------------------------------------------------------------------- |
27 | ;;; Package things. | |
28 | ||
861345b4 | 29 | (defpackage #:mdw.base |
30 | (:use #:common-lisp) | |
23f32e98 MW |
31 | (:export #:unsigned-fixnum |
32 | #:compile-time-defun | |
861345b4 | 33 | #:show |
8f801ae8 MW |
34 | #:stringify #:mappend #:listify #:fix-pair #:pairify |
35 | #:parse-body #:with-parsed-body | |
861345b4 | 36 | #:whitespace-char-p |
37 | #:slot-uninitialized | |
2af61873 | 38 | #:nlet #:while #:until #:case2 #:ecase2 #:setf-default |
861345b4 | 39 | #:with-gensyms #:let*/gensyms #:with-places |
e979e568 MW |
40 | #:locp #:locf #:ref #:with-locatives |
41 | #:update-place #:update-place-after | |
7dcf04ad MW |
42 | #:incf-after #:decf-after |
43 | #:fixnump) | |
44 | #+cmu (:import-from #:extensions #:fixnump)) | |
45 | ||
861345b4 | 46 | (in-package #:mdw.base) |
47 | ||
02866e07 | 48 | ;;;-------------------------------------------------------------------------- |
23f32e98 MW |
49 | ;;; Useful types. |
50 | ||
51 | (deftype unsigned-fixnum () | |
52 | "Unsigned fixnums; useful as array indices and suchlike." | |
53 | `(mod ,most-positive-fixnum)) | |
54 | ||
55 | ;;;-------------------------------------------------------------------------- | |
02866e07 MW |
56 | ;;; Some simple macros to get things going. |
57 | ||
861345b4 | 58 | (defmacro compile-time-defun (name args &body body) |
59 | "Define a function which can be used by macros during the compilation | |
0ff9df03 | 60 | process." |
fe0f07ea | 61 | `(eval-when (:compile-toplevel :load-toplevel :execute) |
861345b4 | 62 | (defun ,name ,args ,@body))) |
63 | ||
64 | (defmacro show (x) | |
2f94737a | 65 | "Debugging tool: print the expression X and its values." |
861345b4 | 66 | (let ((tmp (gensym))) |
2f94737a MW |
67 | `(let ((,tmp (multiple-value-list ,x))) |
68 | (format t "~&") | |
69 | (pprint-logical-block (*standard-output* nil :per-line-prefix ";; ") | |
70 | (format t | |
71 | "~S = ~@_~:I~:[#<no values>~;~:*~{~S~^ ~_~}~]" | |
72 | ',x | |
73 | ,tmp)) | |
74 | (terpri) | |
75 | (values-list ,tmp)))) | |
861345b4 | 76 | |
77 | (defun stringify (str) | |
78 | "Return a string representation of STR. Strings are returned unchanged; | |
0ff9df03 MW |
79 | symbols are converted to their names (unqualified!). Other objects are |
80 | converted to their print representations." | |
861345b4 | 81 | (typecase str |
82 | (string str) | |
83 | (symbol (symbol-name str)) | |
53e95db0 | 84 | (t (princ-to-string str)))) |
02866e07 | 85 | |
4b6a6387 MW |
86 | (defun mappend (function list &rest more-lists) |
87 | "Apply FUNCTION to corresponding elements of LIST and MORE-LISTS, yielding | |
88 | a list. Return the concatenation of all the resulting lists. Like | |
89 | mapcan, but nondestructive." | |
90 | (apply #'append (apply #'mapcar function list more-lists))) | |
91 | ||
861345b4 | 92 | (compile-time-defun listify (x) |
93 | "If X is a (possibly empty) list, return X; otherwise return (list X)." | |
94 | (if (listp x) x (list x))) | |
02866e07 | 95 | |
861345b4 | 96 | (compile-time-defun do-fix-pair (x y defaultp) |
97 | "Helper function for fix-pair and pairify." | |
98 | (flet ((singleton (x) (values x (if defaultp y x)))) | |
99 | (cond ((atom x) (singleton x)) | |
100 | ((null (cdr x)) (singleton (car x))) | |
101 | ((atom (cdr x)) (values (car x) (cdr x))) | |
102 | ((cddr x) (error "Too many elements for a pair.")) | |
103 | (t (values (car x) (cadr x)))))) | |
02866e07 | 104 | |
861345b4 | 105 | (compile-time-defun fix-pair (x &optional (y nil defaultp)) |
106 | "Return two values extracted from X. It works as follows: | |
0ff9df03 MW |
107 | (A) -> A, Y |
108 | (A B) -> A, B | |
109 | (A B . C) -> error | |
110 | (A . B) -> A, B | |
111 | A -> A, Y | |
112 | where Y defaults to A if not specified." | |
861345b4 | 113 | (do-fix-pair x y defaultp)) |
02866e07 | 114 | |
861345b4 | 115 | (compile-time-defun pairify (x &optional (y nil defaultp)) |
116 | "As for fix-pair, but returns a list instead of two values." | |
117 | (multiple-value-call #'list (do-fix-pair x y defaultp))) | |
118 | ||
119 | (defun whitespace-char-p (ch) | |
120 | "Return whether CH is a whitespace character or not." | |
121 | (case ch | |
67cb6748 MW |
122 | (#.(loop for i below char-code-limit |
123 | for ch = (code-char i) | |
124 | unless (with-input-from-string (in (string ch)) | |
125 | (peek-char t in nil)) | |
126 | collect ch) | |
127 | t) | |
861345b4 | 128 | (t nil))) |
129 | ||
130 | (declaim (ftype (function nil ()) slot-unitialized)) | |
131 | (defun slot-uninitialized () | |
132 | "A function which signals an error. Can be used as an initializer form in | |
0ff9df03 | 133 | structure definitions without doom ensuing." |
861345b4 | 134 | (error "No initializer for slot.")) |
135 | ||
e2a3c923 | 136 | (compile-time-defun parse-body (body &key (allow-docstring-p t)) |
9d3ccec7 | 137 | "Given a BODY (a list of forms), parses it into three sections: a |
0ff9df03 MW |
138 | docstring, a list of declarations (forms beginning with the symbol |
139 | `declare') and the body forms. The result is returned as three lists | |
140 | (even the docstring), suitable for interpolation into a backquoted list | |
e2a3c923 MW |
141 | using `@,'. If ALLOW-DOCSTRING-P is nil, docstrings aren't allowed at |
142 | all." | |
143 | (let ((doc nil) (decls nil)) | |
144 | (do ((forms body (cdr forms))) (nil) | |
145 | (let ((form (and forms (car forms)))) | |
146 | (cond ((and allow-docstring-p (not doc) (stringp form) (cdr forms)) | |
147 | (setf doc form)) | |
148 | ((and (consp form) | |
149 | (eq (car form) 'declare)) | |
150 | (setf decls (append decls (cdr form)))) | |
151 | (t (return (values (and doc (list doc)) | |
152 | (and decls (list (cons 'declare decls))) | |
153 | forms)))))))) | |
9d3ccec7 | 154 | |
8f801ae8 MW |
155 | (defmacro with-parsed-body |
156 | ((bodyvar declvar &optional (docvar (gensym) docp)) form &body body) | |
157 | "Parse FORM into a body, declarations and (maybe) a docstring; bind BODYVAR | |
158 | to the body, DECLVAR to the declarations, and DOCVAR to (a list | |
159 | containing) the docstring, and evaluate BODY." | |
160 | `(multiple-value-bind | |
161 | (,docvar ,declvar ,bodyvar) | |
162 | (parse-body ,form :allow-docstring-p ,docp) | |
163 | ,@(if docp nil `((declare (ignore ,docvar)))) | |
164 | ,@body)) | |
165 | ||
7dcf04ad MW |
166 | #-cmu |
167 | (progn | |
168 | (declaim (inline fixnump)) | |
169 | (defun fixnump (object) | |
170 | "Answer non-nil if OBJECT is a fixnum, or nil if it isn't." | |
171 | (typep object 'fixnum))) | |
172 | ||
02866e07 MW |
173 | ;;;-------------------------------------------------------------------------- |
174 | ;;; Generating symbols. | |
175 | ||
861345b4 | 176 | (defmacro with-gensyms (syms &body body) |
177 | "Everyone's favourite macro helper." | |
178 | `(let (,@(mapcar (lambda (sym) `(,sym (gensym ,(symbol-name sym)))) | |
179 | (listify syms))) | |
180 | ,@body)) | |
181 | ||
182 | (defmacro let*/gensyms (binds &body body) | |
183 | "A macro helper. BINDS is a list of binding pairs (VAR VALUE), where VALUE | |
0ff9df03 MW |
184 | defaults to VAR. The result is that BODY is evaluated in a context where |
185 | each VAR is bound to a gensym, and in the final expansion, each of those | |
186 | gensyms will be bound to the corresponding VALUE." | |
861345b4 | 187 | (labels ((more (binds) |
188 | (let ((tmp (gensym "TMP")) (bind (car binds))) | |
189 | `((let ((,tmp ,(cadr bind)) | |
190 | (,(car bind) (gensym ,(symbol-name (car bind))))) | |
191 | `(let ((,,(car bind) ,,tmp)) | |
192 | ,,@(if (cdr binds) | |
193 | (more (cdr binds)) | |
194 | body))))))) | |
195 | (if (null binds) | |
196 | `(progn ,@body) | |
197 | (car (more (mapcar #'pairify (listify binds))))))) | |
198 | ||
02866e07 | 199 | ;;;-------------------------------------------------------------------------- |
f2d46aaa MW |
200 | ;;; Some simple yet useful control structures. |
201 | ||
202 | (defmacro nlet (name binds &body body) | |
203 | "Scheme's named let." | |
204 | (multiple-value-bind (vars vals) | |
205 | (loop for bind in binds | |
206 | for (var val) = (pairify bind nil) | |
207 | collect var into vars | |
208 | collect val into vals | |
209 | finally (return (values vars vals))) | |
210 | `(labels ((,name ,vars | |
211 | ,@body)) | |
212 | (,name ,@vals)))) | |
213 | ||
214 | (defmacro while (cond &body body) | |
215 | "If COND is false, evaluate to nil; otherwise evaluate BODY and try again." | |
38ccae7f MW |
216 | `(loop (unless ,cond (return)) (progn ,@body))) |
217 | ||
218 | (defmacro until (cond &body body) | |
219 | "If COND is true, evaluate to nil; otherwise evaluate BODY and try again." | |
220 | `(loop (when ,cond (return)) (progn ,@body))) | |
f2d46aaa | 221 | |
560e1186 MW |
222 | (compile-time-defun do-case2-like (kind vform clauses) |
223 | "Helper function for `case2' and `ecase2'." | |
224 | (with-gensyms (scrutinee argument) | |
225 | `(multiple-value-bind (,scrutinee ,argument) ,vform | |
226 | (declare (ignorable ,argument)) | |
227 | (,kind ,scrutinee | |
228 | ,@(mapcar (lambda (clause) | |
229 | (destructuring-bind | |
b3bc3745 | 230 | (cases (&optional varx vary) &rest forms) |
560e1186 MW |
231 | clause |
232 | `(,cases | |
b3bc3745 MW |
233 | ,@(if varx |
234 | (list `(let ((,(or vary varx) ,argument) | |
235 | ,@(and vary | |
236 | `((,varx ,scrutinee)))) | |
237 | ,@forms)) | |
560e1186 MW |
238 | forms)))) |
239 | clauses))))) | |
240 | ||
241 | (defmacro case2 (vform &body clauses) | |
242 | "VFORM is a form which evaluates to two values, SCRUTINEE and ARGUMENT. | |
b3bc3745 MW |
243 | The CLAUSES have the form (CASES ([[SCRUVAR] ARGVAR]) FORMS...), where a |
244 | standard `case' clause has the form (CASES FORMS...). The `case2' form | |
245 | evaluates the VFORM, and compares the SCRUTINEE to the various CASES, in | |
246 | order, just like `case'. If there is a match, then the corresponding | |
247 | FORMs are evaluated with ARGVAR bound to the ARGUMENT and SCRUVAR bound to | |
248 | the SCRUTINEE (where specified). Note the bizarre defaulting behaviour: | |
249 | ARGVAR is less optional than SCRUVAR." | |
560e1186 MW |
250 | (do-case2-like 'case vform clauses)) |
251 | ||
252 | (defmacro ecase2 (vform &body clauses) | |
253 | "Like `case2', but signals an error if no clause matches the SCRUTINEE." | |
254 | (do-case2-like 'ecase vform clauses)) | |
255 | ||
2af61873 MW |
256 | (defmacro setf-default (&rest specs &environment env) |
257 | "Like setf, but only sets places which are currently nil. | |
258 | ||
259 | The arguments are an alternating list of PLACEs and DEFAULTs. If a PLACE | |
260 | is nil, the DEFAULT is evaluated and stored in the PLACE; otherwise the | |
261 | default is /not/ stored. The result is the (new) value of the last | |
262 | PLACE." | |
263 | (labels ((doit (specs) | |
264 | (cond ((null specs) nil) | |
265 | ((null (cdr specs)) | |
266 | (error "Odd number of arguments for SETF-DEFAULT.")) | |
267 | (t | |
268 | (let ((place (car specs)) | |
269 | (default (cadr specs)) | |
270 | (rest (cddr specs))) | |
271 | (multiple-value-bind | |
272 | (vars vals store-vals writer reader) | |
273 | (get-setf-expansion place env) | |
274 | `(let* ,(mapcar #'list vars vals) | |
275 | (or ,reader | |
276 | (multiple-value-bind ,store-vals ,default | |
277 | ,writer)) | |
278 | ,@(and rest (list (doit rest)))))))))) | |
279 | (doit specs))) | |
280 | ||
f2d46aaa | 281 | ;;;-------------------------------------------------------------------------- |
02866e07 MW |
282 | ;;; with-places |
283 | ||
861345b4 | 284 | (defmacro %place-ref (getform setform newtmp) |
285 | "Grim helper macro for with-places." | |
286 | (declare (ignore setform newtmp)) | |
287 | getform) | |
02866e07 | 288 | |
861345b4 | 289 | (define-setf-expander %place-ref (getform setform newtmp) |
290 | "Grim helper macro for with-places." | |
291 | (values nil nil newtmp setform getform)) | |
02866e07 | 292 | |
861345b4 | 293 | (defmacro with-places ((&key environment) places &body body) |
294 | "A hairy helper, for writing setf-like macros. PLACES is a list of binding | |
0ff9df03 MW |
295 | pairs (VAR PLACE), where PLACE defaults to VAR. The result is that BODY |
296 | is evaluated in a context where each VAR is bound to a gensym, and in the | |
297 | final expansion, each of those gensyms will be bound to a symbol-macro | |
298 | capable of reading or setting the value of the corresponding PLACE." | |
861345b4 | 299 | (if (null places) |
300 | `(progn ,@body) | |
301 | (let*/gensyms (environment) | |
302 | (labels | |
303 | ((more (places) | |
304 | (let ((place (car places))) | |
305 | (with-gensyms (tmp valtmps valforms | |
306 | newtmps setform getform) | |
307 | `((let ((,tmp ,(cadr place)) | |
308 | (,(car place) | |
309 | (gensym ,(symbol-name (car place))))) | |
310 | (multiple-value-bind | |
311 | (,valtmps ,valforms | |
312 | ,newtmps ,setform ,getform) | |
313 | (get-setf-expansion ,tmp | |
314 | ,environment) | |
315 | (list 'let* | |
316 | (mapcar #'list ,valtmps ,valforms) | |
317 | `(symbol-macrolet ((,,(car place) | |
318 | (%place-ref ,,getform | |
319 | ,,setform | |
320 | ,,newtmps))) | |
321 | ,,@(if (cdr places) | |
322 | (more (cdr places)) | |
323 | body)))))))))) | |
324 | (car (more (mapcar #'pairify (listify places)))))))) | |
325 | ||
02866e07 MW |
326 | ;;;-------------------------------------------------------------------------- |
327 | ;;; Update-in-place macros built using with-places. | |
328 | ||
e979e568 MW |
329 | (defmacro update-place (op place arg &environment env) |
330 | "Update PLACE with the value of OP PLACE ARG, returning the new value." | |
331 | (with-places (:environment env) (place) | |
332 | `(setf ,place (,op ,place ,arg)))) | |
02866e07 | 333 | |
e979e568 MW |
334 | (defmacro update-place-after (op place arg &environment env) |
335 | "Update PLACE with the value of OP PLACE ARG, returning the old value." | |
336 | (with-places (:environment env) (place) | |
337 | (with-gensyms (x) | |
338 | `(let ((,x ,place)) | |
02866e07 MW |
339 | (setf ,place (,op ,x ,arg)) |
340 | ,x)))) | |
341 | ||
e979e568 MW |
342 | (defmacro incf-after (place &optional (by 1)) |
343 | "Increment PLACE by BY, returning the old value." | |
344 | `(update-place-after + ,place ,by)) | |
02866e07 | 345 | |
e979e568 MW |
346 | (defmacro decf-after (place &optional (by 1)) |
347 | "Decrement PLACE by BY, returning the old value." | |
348 | `(update-place-after - ,place ,by)) | |
349 | ||
02866e07 MW |
350 | ;;;-------------------------------------------------------------------------- |
351 | ;;; Locatives. | |
e979e568 | 352 | |
861345b4 | 353 | (defstruct (loc (:predicate locp) (:constructor make-loc (reader writer))) |
354 | "Locative data type. See `locf' and `ref'." | |
355 | (reader (slot-uninitialized) :type function) | |
356 | (writer (slot-uninitialized) :type function)) | |
02866e07 | 357 | |
861345b4 | 358 | (defmacro locf (place &environment env) |
359 | "Slightly cheesy locatives. (locf PLACE) returns an object which, using | |
0ff9df03 MW |
360 | the `ref' function, can be used to read or set the value of PLACE. It's |
361 | cheesy because it uses closures rather than actually taking the address of | |
362 | something. Also, unlike Zetalisp, we don't overload `car' to do our dirty | |
363 | work." | |
861345b4 | 364 | (multiple-value-bind |
365 | (valtmps valforms newtmps setform getform) | |
366 | (get-setf-expansion place env) | |
367 | `(let* (,@(mapcar #'list valtmps valforms)) | |
368 | (make-loc (lambda () ,getform) | |
369 | (lambda (,@newtmps) ,setform))))) | |
02866e07 | 370 | |
861345b4 | 371 | (declaim (inline loc (setf loc))) |
02866e07 | 372 | |
861345b4 | 373 | (defun ref (loc) |
374 | "Fetch the value referred to by a locative." | |
375 | (funcall (loc-reader loc))) | |
02866e07 | 376 | |
861345b4 | 377 | (defun (setf ref) (new loc) |
378 | "Store a new value in the place referred to by a locative." | |
379 | (funcall (loc-writer loc) new)) | |
02866e07 | 380 | |
861345b4 | 381 | (defmacro with-locatives (locs &body body) |
382 | "LOCS is a list of items of the form (SYM [LOC-EXPR]), where SYM is a | |
0ff9df03 MW |
383 | symbol and LOC-EXPR evaluates to a locative. If LOC-EXPR is omitted, it |
384 | defaults to SYM. As an abbreviation for a common case, LOCS may be a | |
385 | symbol instead of a list. The BODY is evaluated in an environment where | |
386 | each SYM is a symbol macro which expands to (ref LOC-EXPR) -- or, in fact, | |
387 | something similar which doesn't break if LOC-EXPR has side-effects. Thus, | |
388 | references, including `setf' forms, fetch or modify the thing referred to | |
389 | by the LOC-EXPR. Useful for covering over where something uses a | |
390 | locative." | |
861345b4 | 391 | (setf locs (mapcar #'pairify (listify locs))) |
392 | (let ((tt (mapcar (lambda (l) (declare (ignore l)) (gensym)) locs)) | |
393 | (ll (mapcar #'cadr locs)) | |
394 | (ss (mapcar #'car locs))) | |
395 | `(let (,@(mapcar (lambda (tmp loc) `(,tmp ,loc)) tt ll)) | |
396 | (symbol-macrolet (,@(mapcar (lambda (sym tmp) | |
397 | `(,sym (ref ,tmp))) ss tt)) | |
398 | ,@body)))) | |
399 | ||
400 | ;;;----- That's all, folks -------------------------------------------------- |