/[cmucl]/src/pcl/macros.lisp
ViewVC logotype

Contents of /src/pcl/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (show annotations)
Sat Aug 24 13:46:52 2002 UTC (11 years, 8 months ago) by pmai
Branch: MAIN
Changes since 1.16: +3 -32 lines
Patch by Gerd Moellmann to remove PCL's variant of once-only,
replacing it by the version already present in CMUCL.
1 ;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
2 ;;;
3 ;;; *************************************************************************
4 ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
5 ;;; All rights reserved.
6 ;;;
7 ;;; Use and copying of this software and preparation of derivative works
8 ;;; based upon this software are permitted. Any distribution of this
9 ;;; software or derivative works must comply with all applicable United
10 ;;; States export control laws.
11 ;;;
12 ;;; This software is made available AS IS, and Xerox Corporation makes no
13 ;;; warranty about the software, its performance or its conformity to any
14 ;;; specification.
15 ;;;
16 ;;; Any person obtaining a copy of this software is requested to send their
17 ;;; name and post office or electronic mail address to:
18 ;;; CommonLoops Coordinator
19 ;;; Xerox PARC
20 ;;; 3333 Coyote Hill Rd.
21 ;;; Palo Alto, CA 94304
22 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
23 ;;;
24 ;;; Suggestions, comments and requests for improvements are also welcome.
25 ;;; *************************************************************************
26 ;;;
27
28 (ext:file-comment
29 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/macros.lisp,v 1.17 2002/08/24 13:46:52 pmai Exp $")
30 ;;;
31 ;;; Macros global variable definitions, and other random support stuff used
32 ;;; by the rest of the system.
33 ;;;
34 ;;; For simplicity (not having to use eval-when a lot), this file must be
35 ;;; loaded before it can be compiled.
36 ;;;
37
38 (in-package :pcl)
39
40 (declaim (declaration
41 values ;;I use this so that Zwei can remind
42 ;;me what values a function returns.
43
44 arglist ;;Tells me what the pretty arglist
45 ;;of something (which probably takes
46 ;;&rest args) is.
47
48 indentation ;;Tells ZWEI how to indent things
49 ;;like defclass.
50 class
51 variable-rebinding
52 pcl-fast-call
53 method-name
54 method-lambda-list
55 ))
56
57 ;;; Age old functions which CommonLisp cleaned-up away. They probably exist
58 ;;; in other packages in all CommonLisp implementations, but I will leave it
59 ;;; to the compiler to optimize into calls to them.
60 ;;;
61 ;;; Common Lisp BUG:
62 ;;; Some Common Lisps define these in the Lisp package which causes
63 ;;; all sorts of lossage. Common Lisp should explictly specify which
64 ;;; symbols appear in the Lisp package.
65 ;;;
66 (eval-when (compile load eval)
67
68 (defmacro memq (item list) `(member ,item ,list :test #'eq))
69 (defmacro assq (item list) `(assoc ,item ,list :test #'eq))
70 (defmacro rassq (item list) `(rassoc ,item ,list :test #'eq))
71 (defmacro delq (item list) `(delete ,item ,list :test #'eq))
72 (defmacro posq (item list) `(position ,item ,list :test #'eq))
73 (defmacro neq (x y) `(not (eq ,x ,y)))
74
75
76 (defun make-caxr (n form)
77 (if (< n 4)
78 `(,(nth n '(car cadr caddr cadddr)) ,form)
79 (make-caxr (- n 4) `(cddddr ,form))))
80
81 (defun make-cdxr (n form)
82 (cond ((zerop n) form)
83 ((< n 5) `(,(nth n '(identity cdr cddr cdddr cddddr)) ,form))
84 (t (make-cdxr (- n 4) `(cddddr ,form)))))
85 )
86
87 (defun true (&rest ignore) (declare (ignore ignore)) t)
88 (defun false (&rest ignore) (declare (ignore ignore)) nil)
89 (defun zero (&rest ignore) (declare (ignore ignore)) 0)
90
91 (defun make-plist (keys vals)
92 (if (null vals)
93 ()
94 (list* (car keys)
95 (car vals)
96 (make-plist (cdr keys) (cdr vals)))))
97
98 (defun remtail (list tail)
99 (if (eq list tail) () (cons (car list) (remtail (cdr list) tail))))
100
101 (eval-when (compile load eval)
102 (defun extract-declarations (body &optional environment)
103 ;;(declare (values documentation declarations body))
104 (let (documentation declarations form)
105 (when (and (stringp (car body))
106 (cdr body))
107 (setq documentation (pop body)))
108 (block outer
109 (loop
110 (when (null body) (return-from outer nil))
111 (setq form (car body))
112 (when (block inner
113 (loop (cond ((not (listp form))
114 (return-from outer nil))
115 ((eq (car form) 'declare)
116 (return-from inner 't))
117 (t
118 (multiple-value-bind (newform macrop)
119 (macroexpand-1 form environment)
120 (if (or (not (eq newform form)) macrop)
121 (setq form newform)
122 (return-from outer nil)))))))
123 (pop body)
124 (dolist (declaration (cdr form))
125 (push declaration declarations)))))
126 (values documentation
127 (and declarations `((declare ,.(nreverse declarations))))
128 body)))
129 )
130
131 (defun get-declaration (name declarations &optional default)
132 (dolist (d declarations default)
133 (dolist (form (cdr d))
134 (when (and (consp form) (eq (car form) name))
135 (return-from get-declaration (cdr form))))))
136
137
138 (defvar *keyword-package* (find-package 'keyword))
139
140 (defun make-keyword (symbol)
141 (intern (symbol-name symbol) *keyword-package*))
142
143 (eval-when (compile load eval)
144
145 (defun string-append (&rest strings)
146 (setq strings (copy-list strings)) ;The explorer can't even
147 ;rplaca an &rest arg?
148 (do ((string-loc strings (cdr string-loc)))
149 ((null string-loc)
150 (apply #'concatenate 'string strings))
151 (rplaca string-loc (string (car string-loc)))))
152 )
153
154 (defun symbol-append (sym1 sym2 &optional (package *package*))
155 (intern (string-append sym1 sym2) package))
156
157 (defmacro check-member (place list &key (test #'eql) (pretty-name place))
158 (ext:once-only ((place place) (list list))
159 `(or (member ,place ,list :test ,test)
160 (error "The value of ~A, ~S is not one of ~S."
161 ',pretty-name ,place ,list))))
162
163 (defmacro alist-entry (alist key make-entry-fn)
164 (ext:once-only ((alist alist) (key key))
165 `(or (assq ,key ,alist)
166 (progn (setf ,alist (cons (,make-entry-fn ,key) ,alist))
167 (car ,alist)))))
168
169 (defmacro collecting-once (&key initial-value)
170 `(let* ((head ,initial-value)
171 (tail ,(and initial-value `(last head))))
172 (values #'(lambda (value)
173 (if (null head)
174 (setq head (setq tail (list value)))
175 (unless (memq value head)
176 (setq tail
177 (cdr (rplacd tail (list value)))))))
178 #'(lambda nil head))))
179
180 (defmacro doplist ((key val) plist &body body &environment env)
181 (multiple-value-bind (doc decls bod)
182 (extract-declarations body env)
183 (declare (ignore doc))
184 `(let ((.plist-tail. ,plist) ,key ,val)
185 ,@decls
186 (loop (when (null .plist-tail.) (return nil))
187 (setq ,key (pop .plist-tail.))
188 (when (null .plist-tail.)
189 (error "Malformed plist in doplist, odd number of elements."))
190 (setq ,val (pop .plist-tail.))
191 (progn ,@bod)))))
192
193 (defmacro if* (condition true &rest false)
194 `(if ,condition ,true (progn ,@false)))
195
196 (defmacro dolist-carefully ((var list improper-list-handler) &body body)
197 `(let ((,var nil)
198 (.dolist-carefully. ,list))
199 (loop (when (null .dolist-carefully.) (return nil))
200 (if (consp .dolist-carefully.)
201 (progn
202 (setq ,var (pop .dolist-carefully.))
203 ,@body)
204 (,improper-list-handler)))))
205
206 ;;
207 ;;;;;; printing-random-thing
208 ;;
209 ;;; Similar to printing-random-object in the lisp machine but much simpler
210 ;;; and machine independent.
211 (defmacro printing-random-thing ((thing stream) &body body)
212 `(print-unreadable-object (,thing ,stream :identity t) ,@body))
213
214 (defun printing-random-thing-internal (thing stream)
215 (declare (ignore thing stream))
216 nil)
217
218 ;;
219 ;;;;;;
220 ;;
221
222 (defun capitalize-words (string &optional (dashes-p t))
223 (let ((string (copy-seq (string string))))
224 (declare (string string))
225 (do* ((flag t flag)
226 (length (length string) length)
227 (char nil char)
228 (i 0 (+ i 1)))
229 ((= i length) string)
230 (setq char (elt string i))
231 (cond ((both-case-p char)
232 (if flag
233 (and (setq flag (lower-case-p char))
234 (setf (elt string i) (char-upcase char)))
235 (and (not flag) (setf (elt string i) (char-downcase char))))
236 (setq flag nil))
237 ((char-equal char #\-)
238 (setq flag t)
239 (unless dashes-p (setf (elt string i) #\space)))
240 (t (setq flag nil))))))
241
242 ;;;
243 ;;; FIND-CLASS
244 ;;;
245 ;;; This is documented in the CLOS specification.
246 ;;;
247 (defvar *find-class* (make-hash-table :test #'eq))
248
249 (defun function-returning-nil (x)
250 (declare (ignore x))
251 nil)
252
253 (defmacro find-class-cell-class (cell)
254 `(car ,cell))
255
256 (defmacro find-class-cell-predicate (cell)
257 `(cadr ,cell))
258
259 (defmacro find-class-cell-make-instance-function-keys (cell)
260 `(cddr ,cell))
261
262 (defmacro make-find-class-cell (class-name)
263 (declare (ignore class-name))
264 '(list* nil #'function-returning-nil nil))
265
266 (defun find-class-cell (symbol &optional dont-create-p)
267 (or (gethash symbol *find-class*)
268 (unless dont-create-p
269 (unless (legal-class-name-p symbol)
270 (error "~S is not a legal class name." symbol))
271 (setf (gethash symbol *find-class*) (make-find-class-cell symbol)))))
272
273 (defvar *create-classes-from-internal-structure-definitions-p* t)
274
275 (defun find-class-from-cell (symbol cell &optional (errorp t))
276 (or (find-class-cell-class cell)
277 (and *create-classes-from-internal-structure-definitions-p*
278 (structure-type-p symbol)
279 (find-structure-class symbol))
280 (cond ((null errorp) nil)
281 ((legal-class-name-p symbol)
282 (error "No class named: ~S." symbol))
283 (t
284 (error "~S is not a legal class name." symbol)))))
285
286 (defun find-class-predicate-from-cell (symbol cell &optional (errorp t))
287 (unless (find-class-cell-class cell)
288 (find-class-from-cell symbol cell errorp))
289 (find-class-cell-predicate cell))
290
291 (defun legal-class-name-p (x)
292 (and (symbolp x)
293 (not (keywordp x))))
294
295 (defun find-class (symbol &optional (errorp t) environment)
296 "Returns the PCL class metaobject named by SYMBOL. An error of type
297 SIMPLE-ERROR is signaled if the class does not exist unless ERRORP
298 is NIL in which case NIL is returned. SYMBOL cannot be a keyword."
299 (declare (ignore environment))
300 (find-class-from-cell
301 symbol (find-class-cell symbol t) errorp))
302
303 (defun find-class-predicate (symbol &optional (errorp t) environment)
304 (declare (ignore environment))
305 (find-class-predicate-from-cell
306 symbol (find-class-cell symbol errorp) errorp))
307
308 (defvar *boot-state* nil) ; duplicate defvar to defs.lisp
309
310 ; Use this definition in any CL implementation supporting
311 ; both define-compiler-macro and load-time-value.
312 ; Note that in CMU, lisp:find-class /= pcl:find-class
313 (define-compiler-macro find-class (&whole form
314 symbol &optional (errorp t) environment)
315 (declare (ignore environment))
316 (if (and (constantp symbol)
317 (legal-class-name-p (eval symbol))
318 (constantp errorp)
319 (member *boot-state* '(braid complete)))
320 (let ((symbol (eval symbol))
321 (errorp (not (null (eval errorp))))
322 (class-cell (make-symbol "CLASS-CELL")))
323 `(let ((,class-cell (load-time-value (find-class-cell ',symbol))))
324 (or (find-class-cell-class ,class-cell)
325 ,(if errorp
326 `(find-class-from-cell ',symbol ,class-cell t)
327 `(and (kernel:class-cell-class
328 ',(kernel:find-class-cell symbol))
329 (find-class-from-cell ',symbol ,class-cell nil))))))
330 form))
331
332 (defun (setf find-class) (new-value symbol)
333 (if (legal-class-name-p symbol)
334 (let ((cell (find-class-cell symbol)))
335 (setf (find-class-cell-class cell) new-value)
336 (when (or (eq *boot-state* 'complete)
337 (eq *boot-state* 'braid))
338 (when (and new-value (class-wrapper new-value))
339 (setf (find-class-cell-predicate cell)
340 (symbol-function (class-predicate-name new-value))))
341 (when (and new-value (not (forward-referenced-class-p new-value)))
342
343 (dolist (keys+aok (find-class-cell-make-instance-function-keys cell))
344 (update-initialize-info-internal
345 (initialize-info new-value (car keys+aok) nil (cdr keys+aok))
346 'make-instance-function))))
347 new-value)
348 (error "~S is not a legal class name." symbol)))
349
350 (defun (setf find-class-predicate) (new-value symbol)
351 (if (legal-class-name-p symbol)
352 (setf (find-class-cell-predicate (find-class-cell symbol)) new-value)
353 (error "~S is not a legal class name." symbol)))
354
355 (defmacro gathering1 (gatherer &body body)
356 `(gathering ((.gathering1. ,gatherer))
357 (macrolet ((gather1 (x) `(gather ,x .gathering1.)))
358 ,@body)))
359
360
361 ;;;
362 ;;; These are augmented definitions of list-elements and list-tails from
363 ;;; iterate.lisp. These versions provide the extra :by keyword which can
364 ;;; be used to specify the step function through the list.
365 ;;;
366 (defmacro *list-elements (list &key (by #'cdr))
367 `(let ((tail ,list))
368 #'(lambda (finish)
369 (if (endp tail)
370 (funcall finish)
371 (prog1 (car tail)
372 (setq tail (funcall ,by tail)))))))
373
374 (defmacro *list-tails (list &key (by #'cdr))
375 `(let ((tail ,list))
376 #'(lambda (finish)
377 (prog1 (if (endp tail)
378 (funcall finish)
379 tail)
380 (setq tail (funcall ,by tail))))))
381
382 (defmacro function-funcall (form &rest args)
383 `(funcall (the function ,form) ,@args))
384
385 (defmacro function-apply (form &rest args)
386 `(apply (the function ,form) ,@args))
387
388
389 (defsetf slot-value set-slot-value)
390
391 (defvar *redefined-functions* nil)
392
393 (defmacro original-definition (name)
394 `(get ,name ':definition-before-pcl))
395
396 (defun redefine-function (name new)
397 (pushnew name *redefined-functions*)
398 (unless (original-definition name)
399 (setf (original-definition name)
400 (symbol-function name)))
401 (setf (symbol-function name)
402 (symbol-function new)))
403

  ViewVC Help
Powered by ViewVC 1.1.5