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