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

Contents of /src/pcl/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.14 - (show annotations)
Sun May 30 23:14:03 1999 UTC (14 years, 10 months ago) by pw
Branch: MAIN
Changes since 1.13: +15 -55 lines
Remove all #+ and #- conditionals from the source code. What is left
is essentially Common Lisp except for explicit references to things
in CMUCL specific packages.
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.14 1999/05/30 23:14:03 pw 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 (proclaim '(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 ;;; ONCE-ONLY does the same thing as it does in zetalisp. I should have just
102 ;;; lifted it from there but I am honest. Not only that but this one is
103 ;;; written in Common Lisp. I feel a lot like bootstrapping, or maybe more
104 ;;; like rebuilding Rome.
105 (defmacro once-only (vars &body body)
106 (let ((gensym-var (gensym))
107 (run-time-vars (gensym))
108 (run-time-vals (gensym))
109 (expand-time-val-forms ()))
110 (dolist (var vars)
111 (push `(if (or (symbolp ,var)
112 (numberp ,var)
113 (and (listp ,var)
114 (member (car ,var) '(quote function))))
115 ,var
116 (let ((,gensym-var (gensym)))
117 (push ,gensym-var ,run-time-vars)
118 (push ,var ,run-time-vals)
119 ,gensym-var))
120 expand-time-val-forms))
121 `(let* (,run-time-vars
122 ,run-time-vals
123 (wrapped-body
124 (let ,(mapcar #'list vars (reverse expand-time-val-forms))
125 ,@body)))
126 `(let ,(mapcar #'list (reverse ,run-time-vars)
127 (reverse ,run-time-vals))
128 ,wrapped-body))))
129
130 (eval-when (compile load eval)
131 (defun extract-declarations (body &optional environment)
132 ;;(declare (values documentation declarations body))
133 (let (documentation declarations form)
134 (when (and (stringp (car body))
135 (cdr body))
136 (setq documentation (pop body)))
137 (block outer
138 (loop
139 (when (null body) (return-from outer nil))
140 (setq form (car body))
141 (when (block inner
142 (loop (cond ((not (listp form))
143 (return-from outer nil))
144 ((eq (car form) 'declare)
145 (return-from inner 't))
146 (t
147 (multiple-value-bind (newform macrop)
148 (macroexpand-1 form environment)
149 (if (or (not (eq newform form)) macrop)
150 (setq form newform)
151 (return-from outer nil)))))))
152 (pop body)
153 (dolist (declaration (cdr form))
154 (push declaration declarations)))))
155 (values documentation
156 (and declarations `((declare ,.(nreverse declarations))))
157 body)))
158 )
159
160 (defun get-declaration (name declarations &optional default)
161 (dolist (d declarations default)
162 (dolist (form (cdr d))
163 (when (and (consp form) (eq (car form) name))
164 (return-from get-declaration (cdr form))))))
165
166
167 (defvar *keyword-package* (find-package 'keyword))
168
169 (defun make-keyword (symbol)
170 (intern (symbol-name symbol) *keyword-package*))
171
172 (eval-when (compile load eval)
173
174 (defun string-append (&rest strings)
175 (setq strings (copy-list strings)) ;The explorer can't even
176 ;rplaca an &rest arg?
177 (do ((string-loc strings (cdr string-loc)))
178 ((null string-loc)
179 (apply #'concatenate 'string strings))
180 (rplaca string-loc (string (car string-loc)))))
181 )
182
183 (defun symbol-append (sym1 sym2 &optional (package *package*))
184 (intern (string-append sym1 sym2) package))
185
186 (defmacro check-member (place list &key (test #'eql) (pretty-name place))
187 (once-only (place list)
188 `(or (member ,place ,list :test ,test)
189 (error "The value of ~A, ~S is not one of ~S."
190 ',pretty-name ,place ,list))))
191
192 (defmacro alist-entry (alist key make-entry-fn)
193 (once-only (alist key)
194 `(or (assq ,key ,alist)
195 (progn (setf ,alist (cons (,make-entry-fn ,key) ,alist))
196 (car ,alist)))))
197
198 ;;; A simple version of destructuring-bind.
199
200 ;;; This does no more error checking than CAR and CDR themselves do. Some
201 ;;; attempt is made to be smart about preserving intermediate values. It
202 ;;; could be better, although the only remaining case should be easy for
203 ;;; the compiler to spot since it compiles to PUSH POP.
204 ;;;
205 ;;; Common Lisp BUG:
206 ;;; Common Lisp should have destructuring-bind.
207 ;;;
208 (defmacro destructuring-bind (pattern form &body body)
209 (multiple-value-bind (ignore declares body)
210 (extract-declarations body)
211 (declare (ignore ignore))
212 (multiple-value-bind (setqs binds)
213 (destructure pattern form)
214 `(let ,binds
215 ,@declares
216 ,@setqs
217 (progn .destructure-form.)
218 . ,body))))
219
220 (eval-when (compile load eval)
221 (defun destructure (pattern form)
222 ;;(declare (values setqs binds))
223 (let ((*destructure-vars* ())
224 (setqs ()))
225 (declare (special *destructure-vars*))
226 (setq *destructure-vars* '(.destructure-form.)
227 setqs (list `(setq .destructure-form. ,form))
228 form '.destructure-form.)
229 (values (nconc setqs (nreverse (destructure-internal pattern form)))
230 (delete nil *destructure-vars*))))
231
232 (defun destructure-internal (pattern form)
233 ;; When we are called, pattern must be a list. Form should be a symbol
234 ;; which we are free to setq containing the value to be destructured.
235 ;; Optimizations are performed for the last element of pattern cases.
236 ;; we assume that the compiler is smart about gensyms which are bound
237 ;; but only for a short period of time.
238 (declare (special *destructure-vars*))
239 (let ((gensym (gensym))
240 (pending-pops 0)
241 (var nil)
242 (setqs ()))
243 (labels
244 ((make-pop (var form pop-into)
245 (prog1
246 (cond ((zerop pending-pops)
247 `(progn ,(and var `(setq ,var (car ,form)))
248 ,(and pop-into `(setq ,pop-into (cdr ,form)))))
249 ((null pop-into)
250 (and var `(setq ,var ,(make-caxr pending-pops form))))
251 (t
252 `(progn (setq ,pop-into ,(make-cdxr pending-pops form))
253 ,(and var `(setq ,var (pop ,pop-into))))))
254 (setq pending-pops 0))))
255 (do ((pat pattern (cdr pat)))
256 ((null pat) ())
257 (if (symbolp (setq var (car pat)))
258 (progn
259 (unless (memq var '(nil ignore))
260 (push var *destructure-vars*))
261 (cond ((null (cdr pat))
262 (push (make-pop var form ()) setqs))
263 ((symbolp (cdr pat))
264 (push (make-pop var form (cdr pat)) setqs)
265 (push (cdr pat) *destructure-vars*)
266 (return ()))
267 ((memq var '(nil ignore)) (incf pending-pops))
268 ((memq (cadr pat) '(nil ignore))
269 (push (make-pop var form ()) setqs)
270 (incf pending-pops 1))
271 (t
272 (push (make-pop var form form) setqs))))
273 (progn
274 (push `(let ((,gensym ()))
275 ,(make-pop gensym
276 form
277 (if (symbolp (cdr pat)) (cdr pat) form))
278 ,@(nreverse
279 (destructure-internal (car pat) gensym)))
280 setqs)
281 (when (symbolp (cdr pat))
282 (push (cdr pat) *destructure-vars*)
283 (return)))))
284 setqs)))
285 )
286
287
288 (defmacro collecting-once (&key initial-value)
289 `(let* ((head ,initial-value)
290 (tail ,(and initial-value `(last head))))
291 (values #'(lambda (value)
292 (if (null head)
293 (setq head (setq tail (list value)))
294 (unless (memq value head)
295 (setq tail
296 (cdr (rplacd tail (list value)))))))
297 #'(lambda nil head))))
298
299 (defmacro doplist ((key val) plist &body body &environment env)
300 (multiple-value-bind (doc decls bod)
301 (extract-declarations body env)
302 (declare (ignore doc))
303 `(let ((.plist-tail. ,plist) ,key ,val)
304 ,@decls
305 (loop (when (null .plist-tail.) (return nil))
306 (setq ,key (pop .plist-tail.))
307 (when (null .plist-tail.)
308 (error "Malformed plist in doplist, odd number of elements."))
309 (setq ,val (pop .plist-tail.))
310 (progn ,@bod)))))
311
312 (defmacro if* (condition true &rest false)
313 `(if ,condition ,true (progn ,@false)))
314
315 (defmacro dolist-carefully ((var list improper-list-handler) &body body)
316 `(let ((,var nil)
317 (.dolist-carefully. ,list))
318 (loop (when (null .dolist-carefully.) (return nil))
319 (if (consp .dolist-carefully.)
320 (progn
321 (setq ,var (pop .dolist-carefully.))
322 ,@body)
323 (,improper-list-handler)))))
324
325 ;;
326 ;;;;;; printing-random-thing
327 ;;
328 ;;; Similar to printing-random-object in the lisp machine but much simpler
329 ;;; and machine independent.
330 (defmacro printing-random-thing ((thing stream) &body body)
331 `(print-unreadable-object (,thing ,stream :identity t) ,@body))
332
333 (defun printing-random-thing-internal (thing stream)
334 (declare (ignore thing stream))
335 nil)
336
337 ;;
338 ;;;;;;
339 ;;
340
341 (defun capitalize-words (string &optional (dashes-p t))
342 (let ((string (copy-seq (string string))))
343 (declare (string string))
344 (do* ((flag t flag)
345 (length (length string) length)
346 (char nil char)
347 (i 0 (+ i 1)))
348 ((= i length) string)
349 (setq char (elt string i))
350 (cond ((both-case-p char)
351 (if flag
352 (and (setq flag (lower-case-p char))
353 (setf (elt string i) (char-upcase char)))
354 (and (not flag) (setf (elt string i) (char-downcase char))))
355 (setq flag nil))
356 ((char-equal char #\-)
357 (setq flag t)
358 (unless dashes-p (setf (elt string i) #\space)))
359 (t (setq flag nil))))))
360
361 ;;;
362 ;;; FIND-CLASS
363 ;;;
364 ;;; This is documented in the CLOS specification.
365 ;;;
366 (defvar *find-class* (make-hash-table :test #'eq))
367
368 (defun function-returning-nil (x)
369 (declare (ignore x))
370 nil)
371
372 (defmacro find-class-cell-class (cell)
373 `(car ,cell))
374
375 (defmacro find-class-cell-predicate (cell)
376 `(cadr ,cell))
377
378 (defmacro find-class-cell-make-instance-function-keys (cell)
379 `(cddr ,cell))
380
381 (defmacro make-find-class-cell (class-name)
382 (declare (ignore class-name))
383 '(list* nil #'function-returning-nil nil))
384
385 (defun find-class-cell (symbol &optional dont-create-p)
386 (or (gethash symbol *find-class*)
387 (unless dont-create-p
388 (unless (legal-class-name-p symbol)
389 (error "~S is not a legal class name." symbol))
390 (setf (gethash symbol *find-class*) (make-find-class-cell symbol)))))
391
392 (defvar *create-classes-from-internal-structure-definitions-p* t)
393
394 (defun find-class-from-cell (symbol cell &optional (errorp t))
395 (or (find-class-cell-class cell)
396 (and *create-classes-from-internal-structure-definitions-p*
397 (structure-type-p symbol)
398 (find-structure-class symbol))
399 (cond ((null errorp) nil)
400 ((legal-class-name-p symbol)
401 (error "No class named: ~S." symbol))
402 (t
403 (error "~S is not a legal class name." symbol)))))
404
405 (defun find-class-predicate-from-cell (symbol cell &optional (errorp t))
406 (unless (find-class-cell-class cell)
407 (find-class-from-cell symbol cell errorp))
408 (find-class-cell-predicate cell))
409
410 (defun legal-class-name-p (x)
411 (and (symbolp x)
412 (not (keywordp x))))
413
414 (defun find-class (symbol &optional (errorp t) environment)
415 "Returns the PCL class metaobject named by SYMBOL. An error of type
416 SIMPLE-ERROR is signaled if the class does not exist unless ERRORP
417 is NIL in which case NIL is returned. SYMBOL cannot be a keyword."
418 (declare (ignore environment))
419 (find-class-from-cell
420 symbol (find-class-cell symbol t) errorp))
421
422 (defun find-class-predicate (symbol &optional (errorp t) environment)
423 (declare (ignore environment))
424 (find-class-predicate-from-cell
425 symbol (find-class-cell symbol errorp) errorp))
426
427 (defvar *boot-state* nil) ; duplicate defvar to defs.lisp
428
429 ; Use this definition in any CL implementation supporting
430 ; both define-compiler-macro and load-time-value.
431 ; Note that in CMU, lisp:find-class /= pcl:find-class
432 (define-compiler-macro find-class (&whole form
433 symbol &optional (errorp t) environment)
434 (declare (ignore environment))
435 (if (and (constantp symbol)
436 (legal-class-name-p (eval symbol))
437 (constantp errorp)
438 (member *boot-state* '(braid complete)))
439 (let ((symbol (eval symbol))
440 (errorp (not (null (eval errorp))))
441 (class-cell (make-symbol "CLASS-CELL")))
442 `(let ((,class-cell (load-time-value (find-class-cell ',symbol))))
443 (or (find-class-cell-class ,class-cell)
444 ,(if errorp
445 `(find-class-from-cell ',symbol ,class-cell t)
446 `(and (kernel:class-cell-class
447 ',(kernel:find-class-cell symbol))
448 (find-class-from-cell ',symbol ,class-cell nil))))))
449 form))
450
451 (defun (setf find-class) (new-value symbol)
452 (if (legal-class-name-p symbol)
453 (let ((cell (find-class-cell symbol)))
454 (setf (find-class-cell-class cell) new-value)
455 (when (or (eq *boot-state* 'complete)
456 (eq *boot-state* 'braid))
457 (when (and new-value (class-wrapper new-value))
458 (setf (find-class-cell-predicate cell)
459 (symbol-function (class-predicate-name new-value))))
460 (when (and new-value (not (forward-referenced-class-p new-value)))
461
462 (dolist (keys+aok (find-class-cell-make-instance-function-keys cell))
463 (update-initialize-info-internal
464 (initialize-info new-value (car keys+aok) nil (cdr keys+aok))
465 'make-instance-function))))
466 new-value)
467 (error "~S is not a legal class name." symbol)))
468
469 (defun (setf find-class-predicate) (new-value symbol)
470 (if (legal-class-name-p symbol)
471 (setf (find-class-cell-predicate (find-class-cell symbol)) new-value)
472 (error "~S is not a legal class name." symbol)))
473
474 (defmacro gathering1 (gatherer &body body)
475 `(gathering ((.gathering1. ,gatherer))
476 (macrolet ((gather1 (x) `(gather ,x .gathering1.)))
477 ,@body)))
478
479
480 ;;;
481 ;;; These are augmented definitions of list-elements and list-tails from
482 ;;; iterate.lisp. These versions provide the extra :by keyword which can
483 ;;; be used to specify the step function through the list.
484 ;;;
485 (defmacro *list-elements (list &key (by #'cdr))
486 `(let ((tail ,list))
487 #'(lambda (finish)
488 (if (endp tail)
489 (funcall finish)
490 (prog1 (car tail)
491 (setq tail (funcall ,by tail)))))))
492
493 (defmacro *list-tails (list &key (by #'cdr))
494 `(let ((tail ,list))
495 #'(lambda (finish)
496 (prog1 (if (endp tail)
497 (funcall finish)
498 tail)
499 (setq tail (funcall ,by tail))))))
500
501 (defmacro function-funcall (form &rest args)
502 `(funcall (the function ,form) ,@args))
503
504 (defmacro function-apply (form &rest args)
505 `(apply (the function ,form) ,@args))
506
507
508 (defsetf slot-value set-slot-value)
509
510 (defvar *redefined-functions* nil)
511
512 (defmacro original-definition (name)
513 `(get ,name ':definition-before-pcl))
514
515 (defun redefine-function (name new)
516 (pushnew name *redefined-functions*)
517 (unless (original-definition name)
518 (setf (original-definition name)
519 (symbol-function name)))
520 (setf (symbol-function name)
521 (symbol-function new)))
522

  ViewVC Help
Powered by ViewVC 1.1.5