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

Contents of /src/pcl/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.16 - (hide annotations)
Mon Aug 19 16:52:09 2002 UTC (11 years, 8 months ago) by pmai
Branch: MAIN
Changes since 1.15: +1 -91 lines
Slightly mangled patch by Gerd Moellmann to remove PCL's own version
of destructuring-bind in favour of the ANSI CL version already in
CMUCL.
1 wlott 1.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 pw 1.14
28 dtc 1.10 (ext:file-comment
29 pmai 1.16 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/macros.lisp,v 1.16 2002/08/19 16:52:09 pmai Exp $")
30 dtc 1.10 ;;;
31 wlott 1.1 ;;; 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 phg 1.6 (in-package :pcl)
39 wlott 1.1
40 pw 1.15 (declaim (declaration
41     values ;;I use this so that Zwei can remind
42     ;;me what values a function returns.
43 wlott 1.1
44 pw 1.15 arglist ;;Tells me what the pretty arglist
45     ;;of something (which probably takes
46     ;;&rest args) is.
47 wlott 1.1
48 pw 1.15 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 wlott 1.1
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 ram 1.5 (make-caxr (- n 4) `(cddddr ,form))))
80 wlott 1.1
81     (defun make-cdxr (n form)
82     (cond ((zerop n) form)
83     ((< n 5) `(,(nth n '(identity cdr cddr cdddr cddddr)) ,form))
84 ram 1.5 (t (make-cdxr (- n 4) `(cddddr ,form)))))
85 wlott 1.1 )
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 ram 1.5 (run-time-vars (gensym))
108     (run-time-vals (gensym))
109 wlott 1.1 (expand-time-val-forms ()))
110     (dolist (var vars)
111 ram 1.5 (push `(if (or (symbolp ,var)
112     (numberp ,var)
113     (and (listp ,var)
114     (member (car ,var) '(quote function))))
115 wlott 1.1 ,var
116 ram 1.5 (let ((,gensym-var (gensym)))
117 wlott 1.1 (push ,gensym-var ,run-time-vars)
118     (push ,var ,run-time-vals)
119     ,gensym-var))
120 ram 1.5 expand-time-val-forms))
121 wlott 1.1 `(let* (,run-time-vars
122     ,run-time-vals
123     (wrapped-body
124     (let ,(mapcar #'list vars (reverse expand-time-val-forms))
125     ,@body)))
126 ram 1.5 `(let ,(mapcar #'list (reverse ,run-time-vars)
127     (reverse ,run-time-vals))
128     ,wrapped-body))))
129 wlott 1.1
130     (eval-when (compile load eval)
131     (defun extract-declarations (body &optional environment)
132 ram 1.5 ;;(declare (values documentation declarations body))
133 wlott 1.1 (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 ram 1.5 (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 wlott 1.1
166 ram 1.5
167     (defvar *keyword-package* (find-package 'keyword))
168    
169 wlott 1.1 (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     (defmacro collecting-once (&key initial-value)
199     `(let* ((head ,initial-value)
200     (tail ,(and initial-value `(last head))))
201     (values #'(lambda (value)
202     (if (null head)
203     (setq head (setq tail (list value)))
204     (unless (memq value head)
205     (setq tail
206     (cdr (rplacd tail (list value)))))))
207     #'(lambda nil head))))
208    
209     (defmacro doplist ((key val) plist &body body &environment env)
210     (multiple-value-bind (doc decls bod)
211     (extract-declarations body env)
212     (declare (ignore doc))
213     `(let ((.plist-tail. ,plist) ,key ,val)
214     ,@decls
215     (loop (when (null .plist-tail.) (return nil))
216     (setq ,key (pop .plist-tail.))
217     (when (null .plist-tail.)
218     (error "Malformed plist in doplist, odd number of elements."))
219     (setq ,val (pop .plist-tail.))
220     (progn ,@bod)))))
221    
222     (defmacro if* (condition true &rest false)
223     `(if ,condition ,true (progn ,@false)))
224    
225 ram 1.3 (defmacro dolist-carefully ((var list improper-list-handler) &body body)
226     `(let ((,var nil)
227     (.dolist-carefully. ,list))
228     (loop (when (null .dolist-carefully.) (return nil))
229     (if (consp .dolist-carefully.)
230     (progn
231     (setq ,var (pop .dolist-carefully.))
232     ,@body)
233     (,improper-list-handler)))))
234 wlott 1.1
235     ;;
236     ;;;;;; printing-random-thing
237     ;;
238     ;;; Similar to printing-random-object in the lisp machine but much simpler
239     ;;; and machine independent.
240     (defmacro printing-random-thing ((thing stream) &body body)
241 pw 1.14 `(print-unreadable-object (,thing ,stream :identity t) ,@body))
242 wlott 1.1
243     (defun printing-random-thing-internal (thing stream)
244     (declare (ignore thing stream))
245     nil)
246    
247     ;;
248     ;;;;;;
249     ;;
250    
251     (defun capitalize-words (string &optional (dashes-p t))
252     (let ((string (copy-seq (string string))))
253     (declare (string string))
254     (do* ((flag t flag)
255     (length (length string) length)
256     (char nil char)
257     (i 0 (+ i 1)))
258     ((= i length) string)
259     (setq char (elt string i))
260     (cond ((both-case-p char)
261     (if flag
262     (and (setq flag (lower-case-p char))
263     (setf (elt string i) (char-upcase char)))
264     (and (not flag) (setf (elt string i) (char-downcase char))))
265     (setq flag nil))
266     ((char-equal char #\-)
267     (setq flag t)
268     (unless dashes-p (setf (elt string i) #\space)))
269     (t (setq flag nil))))))
270    
271 ram 1.5 ;;;
272     ;;; FIND-CLASS
273     ;;;
274     ;;; This is documented in the CLOS specification.
275     ;;;
276     (defvar *find-class* (make-hash-table :test #'eq))
277 wlott 1.1
278 ram 1.3 (defun function-returning-nil (x)
279     (declare (ignore x))
280     nil)
281    
282 ram 1.5 (defmacro find-class-cell-class (cell)
283     `(car ,cell))
284 ram 1.3
285 ram 1.5 (defmacro find-class-cell-predicate (cell)
286 phg 1.6 `(cadr ,cell))
287 ram 1.3
288 phg 1.6 (defmacro find-class-cell-make-instance-function-keys (cell)
289     `(cddr ,cell))
290    
291 ram 1.5 (defmacro make-find-class-cell (class-name)
292     (declare (ignore class-name))
293 phg 1.6 '(list* nil #'function-returning-nil nil))
294 ram 1.5
295     (defun find-class-cell (symbol &optional dont-create-p)
296     (or (gethash symbol *find-class*)
297     (unless dont-create-p
298     (unless (legal-class-name-p symbol)
299     (error "~S is not a legal class name." symbol))
300     (setf (gethash symbol *find-class*) (make-find-class-cell symbol)))))
301    
302     (defvar *create-classes-from-internal-structure-definitions-p* t)
303    
304     (defun find-class-from-cell (symbol cell &optional (errorp t))
305     (or (find-class-cell-class cell)
306     (and *create-classes-from-internal-structure-definitions-p*
307     (structure-type-p symbol)
308     (find-structure-class symbol))
309     (cond ((null errorp) nil)
310     ((legal-class-name-p symbol)
311     (error "No class named: ~S." symbol))
312     (t
313     (error "~S is not a legal class name." symbol)))))
314    
315     (defun find-class-predicate-from-cell (symbol cell &optional (errorp t))
316     (unless (find-class-cell-class cell)
317     (find-class-from-cell symbol cell errorp))
318     (find-class-cell-predicate cell))
319    
320     (defun legal-class-name-p (x)
321     (and (symbolp x)
322     (not (keywordp x))))
323    
324     (defun find-class (symbol &optional (errorp t) environment)
325 pw 1.13 "Returns the PCL class metaobject named by SYMBOL. An error of type
326     SIMPLE-ERROR is signaled if the class does not exist unless ERRORP
327     is NIL in which case NIL is returned. SYMBOL cannot be a keyword."
328 ram 1.5 (declare (ignore environment))
329 pw 1.13 (find-class-from-cell
330     symbol (find-class-cell symbol t) errorp))
331 ram 1.5
332     (defun find-class-predicate (symbol &optional (errorp t) environment)
333     (declare (ignore environment))
334 phg 1.6 (find-class-predicate-from-cell
335     symbol (find-class-cell symbol errorp) errorp))
336 ram 1.5
337 pw 1.7 (defvar *boot-state* nil) ; duplicate defvar to defs.lisp
338    
339     ; Use this definition in any CL implementation supporting
340     ; both define-compiler-macro and load-time-value.
341 pw 1.14 ; Note that in CMU, lisp:find-class /= pcl:find-class
342 pw 1.7 (define-compiler-macro find-class (&whole form
343     symbol &optional (errorp t) environment)
344     (declare (ignore environment))
345     (if (and (constantp symbol)
346     (legal-class-name-p (eval symbol))
347     (constantp errorp)
348     (member *boot-state* '(braid complete)))
349     (let ((symbol (eval symbol))
350     (errorp (not (null (eval errorp))))
351     (class-cell (make-symbol "CLASS-CELL")))
352     `(let ((,class-cell (load-time-value (find-class-cell ',symbol))))
353     (or (find-class-cell-class ,class-cell)
354     ,(if errorp
355     `(find-class-from-cell ',symbol ,class-cell t)
356     `(and (kernel:class-cell-class
357     ',(kernel:find-class-cell symbol))
358     (find-class-from-cell ',symbol ,class-cell nil))))))
359     form))
360    
361 dtc 1.11 (defun (setf find-class) (new-value symbol)
362 ram 1.5 (if (legal-class-name-p symbol)
363 phg 1.6 (let ((cell (find-class-cell symbol)))
364     (setf (find-class-cell-class cell) new-value)
365     (when (or (eq *boot-state* 'complete)
366     (eq *boot-state* 'braid))
367 pw 1.8 (when (and new-value (class-wrapper new-value))
368     (setf (find-class-cell-predicate cell)
369     (symbol-function (class-predicate-name new-value))))
370 phg 1.6 (when (and new-value (not (forward-referenced-class-p new-value)))
371 pw 1.7
372 phg 1.6 (dolist (keys+aok (find-class-cell-make-instance-function-keys cell))
373     (update-initialize-info-internal
374     (initialize-info new-value (car keys+aok) nil (cdr keys+aok))
375 pw 1.8 'make-instance-function))))
376     new-value)
377 ram 1.5 (error "~S is not a legal class name." symbol)))
378    
379 dtc 1.11 (defun (setf find-class-predicate) (new-value symbol)
380 ram 1.5 (if (legal-class-name-p symbol)
381     (setf (find-class-cell-predicate (find-class-cell symbol)) new-value)
382     (error "~S is not a legal class name." symbol)))
383    
384 wlott 1.1 (defmacro gathering1 (gatherer &body body)
385     `(gathering ((.gathering1. ,gatherer))
386     (macrolet ((gather1 (x) `(gather ,x .gathering1.)))
387     ,@body)))
388    
389    
390     ;;;
391     ;;; These are augmented definitions of list-elements and list-tails from
392     ;;; iterate.lisp. These versions provide the extra :by keyword which can
393     ;;; be used to specify the step function through the list.
394     ;;;
395     (defmacro *list-elements (list &key (by #'cdr))
396     `(let ((tail ,list))
397     #'(lambda (finish)
398     (if (endp tail)
399     (funcall finish)
400     (prog1 (car tail)
401     (setq tail (funcall ,by tail)))))))
402    
403     (defmacro *list-tails (list &key (by #'cdr))
404     `(let ((tail ,list))
405     #'(lambda (finish)
406     (prog1 (if (endp tail)
407     (funcall finish)
408     tail)
409     (setq tail (funcall ,by tail))))))
410 ram 1.2
411 ram 1.3 (defmacro function-funcall (form &rest args)
412 pw 1.14 `(funcall (the function ,form) ,@args))
413 ram 1.3
414     (defmacro function-apply (form &rest args)
415 pw 1.14 `(apply (the function ,form) ,@args))
416 ram 1.3
417    
418     (defsetf slot-value set-slot-value)
419    
420     (defvar *redefined-functions* nil)
421    
422     (defmacro original-definition (name)
423     `(get ,name ':definition-before-pcl))
424    
425     (defun redefine-function (name new)
426     (pushnew name *redefined-functions*)
427     (unless (original-definition name)
428     (setf (original-definition name)
429     (symbol-function name)))
430     (setf (symbol-function name)
431     (symbol-function new)))
432 ram 1.4

  ViewVC Help
Powered by ViewVC 1.1.5