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 | ||
26 | (defpackage #:mdw.base | |
27 | (:use #:common-lisp) | |
28 | (:export #:compile-time-defun | |
29 | #:show | |
30 | #:stringify #:listify #:fix-pair #:pairify | |
31 | #:whitespace-char-p | |
32 | #:slot-uninitialized | |
33 | #:with-gensyms #:let*/gensyms #:with-places | |
e979e568 MW |
34 | #:locp #:locf #:ref #:with-locatives |
35 | #:update-place #:update-place-after | |
36 | #:incf-after #:decf-after)) | |
861345b4 | 37 | (in-package #:mdw.base) |
38 | ||
39 | (defmacro compile-time-defun (name args &body body) | |
40 | "Define a function which can be used by macros during the compilation | |
41 | process." | |
42 | `(eval-when (:compile-toplevel :load-toplevel) | |
43 | (defun ,name ,args ,@body))) | |
44 | ||
45 | (defmacro show (x) | |
46 | "Debugging tool: print the expression X and its value." | |
47 | (let ((tmp (gensym))) | |
48 | `(let ((,tmp ,x)) | |
49 | (format t "~&~S: ~S~%" ',x ,tmp) | |
50 | ,tmp))) | |
51 | ||
52 | (defun stringify (str) | |
53 | "Return a string representation of STR. Strings are returned unchanged; | |
54 | symbols are converted to their names (unqualified!). Other objects are | |
55 | converted to their print representations." | |
56 | (typecase str | |
57 | (string str) | |
58 | (symbol (symbol-name str)) | |
59 | (t (with-output-to-string (s) | |
60 | (princ str s))))) | |
61 | (compile-time-defun listify (x) | |
62 | "If X is a (possibly empty) list, return X; otherwise return (list X)." | |
63 | (if (listp x) x (list x))) | |
64 | (compile-time-defun do-fix-pair (x y defaultp) | |
65 | "Helper function for fix-pair and pairify." | |
66 | (flet ((singleton (x) (values x (if defaultp y x)))) | |
67 | (cond ((atom x) (singleton x)) | |
68 | ((null (cdr x)) (singleton (car x))) | |
69 | ((atom (cdr x)) (values (car x) (cdr x))) | |
70 | ((cddr x) (error "Too many elements for a pair.")) | |
71 | (t (values (car x) (cadr x)))))) | |
72 | (compile-time-defun fix-pair (x &optional (y nil defaultp)) | |
73 | "Return two values extracted from X. It works as follows: | |
74 | (A) -> A, Y | |
75 | (A B) -> A, B | |
76 | (A B . C) -> error | |
77 | (A . B) -> A, B | |
78 | A -> A, Y | |
79 | where Y defaults to A if not specified." | |
80 | (do-fix-pair x y defaultp)) | |
81 | (compile-time-defun pairify (x &optional (y nil defaultp)) | |
82 | "As for fix-pair, but returns a list instead of two values." | |
83 | (multiple-value-call #'list (do-fix-pair x y defaultp))) | |
84 | ||
85 | (defun whitespace-char-p (ch) | |
86 | "Return whether CH is a whitespace character or not." | |
87 | (case ch | |
88 | ((#\space #\tab #\newline #\return #\vt #\formfeed) t) | |
89 | (t nil))) | |
90 | ||
ec18c92a | 91 | (defmacro nlet (name binds &body body) |
92 | "Scheme's named let." | |
93 | (multiple-value-bind (vars vals) | |
94 | (loop for bind in binds | |
95 | for (var val) = (pairify bind nil) | |
96 | collect var into vars | |
97 | collect val into vals | |
98 | finally (return (values vars vals))) | |
99 | `(labels ((,name ,vars | |
100 | ,@body)) | |
101 | (,name ,@vals)))) | |
102 | ||
103 | (defmacro while (cond &body body) | |
104 | "If COND is false, evaluate to nil; otherwise evaluate BODY and try again." | |
105 | `(loop | |
106 | (unless `cond (return)) | |
107 | ,@body)) | |
108 | ||
861345b4 | 109 | (declaim (ftype (function nil ()) slot-unitialized)) |
110 | (defun slot-uninitialized () | |
111 | "A function which signals an error. Can be used as an initializer form in | |
112 | structure definitions without doom ensuing." | |
113 | (error "No initializer for slot.")) | |
114 | ||
115 | (defmacro with-gensyms (syms &body body) | |
116 | "Everyone's favourite macro helper." | |
117 | `(let (,@(mapcar (lambda (sym) `(,sym (gensym ,(symbol-name sym)))) | |
118 | (listify syms))) | |
119 | ,@body)) | |
120 | ||
121 | (defmacro let*/gensyms (binds &body body) | |
122 | "A macro helper. BINDS is a list of binding pairs (VAR VALUE), where VALUE | |
123 | defaults to VAR. The result is that BODY is evaluated in a context where | |
124 | each VAR is bound to a gensym, and in the final expansion, each of those | |
125 | gensyms will be bound to the corresponding VALUE." | |
126 | (labels ((more (binds) | |
127 | (let ((tmp (gensym "TMP")) (bind (car binds))) | |
128 | `((let ((,tmp ,(cadr bind)) | |
129 | (,(car bind) (gensym ,(symbol-name (car bind))))) | |
130 | `(let ((,,(car bind) ,,tmp)) | |
131 | ,,@(if (cdr binds) | |
132 | (more (cdr binds)) | |
133 | body))))))) | |
134 | (if (null binds) | |
135 | `(progn ,@body) | |
136 | (car (more (mapcar #'pairify (listify binds))))))) | |
137 | ||
138 | (defmacro %place-ref (getform setform newtmp) | |
139 | "Grim helper macro for with-places." | |
140 | (declare (ignore setform newtmp)) | |
141 | getform) | |
142 | (define-setf-expander %place-ref (getform setform newtmp) | |
143 | "Grim helper macro for with-places." | |
144 | (values nil nil newtmp setform getform)) | |
145 | (defmacro with-places ((&key environment) places &body body) | |
146 | "A hairy helper, for writing setf-like macros. PLACES is a list of binding | |
147 | pairs (VAR PLACE), where PLACE defaults to VAR. The result is that BODY is | |
148 | evaluated in a context where each VAR is bound to a gensym, and in the final | |
149 | expansion, each of those gensyms will be bound to a symbol-macro capable of | |
150 | reading or setting the value of the corresponding PLACE." | |
151 | (if (null places) | |
152 | `(progn ,@body) | |
153 | (let*/gensyms (environment) | |
154 | (labels | |
155 | ((more (places) | |
156 | (let ((place (car places))) | |
157 | (with-gensyms (tmp valtmps valforms | |
158 | newtmps setform getform) | |
159 | `((let ((,tmp ,(cadr place)) | |
160 | (,(car place) | |
161 | (gensym ,(symbol-name (car place))))) | |
162 | (multiple-value-bind | |
163 | (,valtmps ,valforms | |
164 | ,newtmps ,setform ,getform) | |
165 | (get-setf-expansion ,tmp | |
166 | ,environment) | |
167 | (list 'let* | |
168 | (mapcar #'list ,valtmps ,valforms) | |
169 | `(symbol-macrolet ((,,(car place) | |
170 | (%place-ref ,,getform | |
171 | ,,setform | |
172 | ,,newtmps))) | |
173 | ,,@(if (cdr places) | |
174 | (more (cdr places)) | |
175 | body)))))))))) | |
176 | (car (more (mapcar #'pairify (listify places)))))))) | |
177 | ||
e979e568 MW |
178 | (defmacro update-place (op place arg &environment env) |
179 | "Update PLACE with the value of OP PLACE ARG, returning the new value." | |
180 | (with-places (:environment env) (place) | |
181 | `(setf ,place (,op ,place ,arg)))) | |
182 | (defmacro update-place-after (op place arg &environment env) | |
183 | "Update PLACE with the value of OP PLACE ARG, returning the old value." | |
184 | (with-places (:environment env) (place) | |
185 | (with-gensyms (x) | |
186 | `(let ((,x ,place)) | |
187 | (setf ,place (,op ,x ,arg)) | |
188 | ,x)))) | |
189 | (defmacro incf-after (place &optional (by 1)) | |
190 | "Increment PLACE by BY, returning the old value." | |
191 | `(update-place-after + ,place ,by)) | |
192 | (defmacro decf-after (place &optional (by 1)) | |
193 | "Decrement PLACE by BY, returning the old value." | |
194 | `(update-place-after - ,place ,by)) | |
195 | ||
196 | ||
861345b4 | 197 | (defstruct (loc (:predicate locp) (:constructor make-loc (reader writer))) |
198 | "Locative data type. See `locf' and `ref'." | |
199 | (reader (slot-uninitialized) :type function) | |
200 | (writer (slot-uninitialized) :type function)) | |
201 | (defmacro locf (place &environment env) | |
202 | "Slightly cheesy locatives. (locf PLACE) returns an object which, using | |
203 | the `ref' function, can be used to read or set the value of PLACE. It's | |
204 | cheesy because it uses closures rather than actually taking the address of | |
205 | something. Also, unlike Zetalisp, we don't overload `car' to do our dirty | |
206 | work." | |
207 | (multiple-value-bind | |
208 | (valtmps valforms newtmps setform getform) | |
209 | (get-setf-expansion place env) | |
210 | `(let* (,@(mapcar #'list valtmps valforms)) | |
211 | (make-loc (lambda () ,getform) | |
212 | (lambda (,@newtmps) ,setform))))) | |
213 | (declaim (inline loc (setf loc))) | |
214 | (defun ref (loc) | |
215 | "Fetch the value referred to by a locative." | |
216 | (funcall (loc-reader loc))) | |
217 | (defun (setf ref) (new loc) | |
218 | "Store a new value in the place referred to by a locative." | |
219 | (funcall (loc-writer loc) new)) | |
220 | (defmacro with-locatives (locs &body body) | |
221 | "LOCS is a list of items of the form (SYM [LOC-EXPR]), where SYM is a | |
222 | symbol and LOC-EXPR evaluates to a locative. If LOC-EXPR is omitted, it | |
223 | defaults to SYM. As an abbreviation for a common case, LOCS may be a symbol | |
224 | instead of a list. The BODY is evaluated in an environment where each SYM is | |
225 | a symbol macro which expands to (ref LOC-EXPR) -- or, in fact, something | |
226 | similar which doesn't break if LOC-EXPR has side-effects. Thus, references, | |
227 | including `setf' forms, fetch or modify the thing referred to by the | |
228 | LOC-EXPR. Useful for covering over where something uses a locative." | |
229 | (setf locs (mapcar #'pairify (listify locs))) | |
230 | (let ((tt (mapcar (lambda (l) (declare (ignore l)) (gensym)) locs)) | |
231 | (ll (mapcar #'cadr locs)) | |
232 | (ss (mapcar #'car locs))) | |
233 | `(let (,@(mapcar (lambda (tmp loc) `(,tmp ,loc)) tt ll)) | |
234 | (symbol-macrolet (,@(mapcar (lambda (sym tmp) | |
235 | `(,sym (ref ,tmp))) ss tt)) | |
236 | ,@body)))) | |
237 | ||
238 | ;;;----- That's all, folks -------------------------------------------------- |