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

Contents of /src/pcl/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12 - (hide annotations)
Thu Apr 15 22:38:15 1999 UTC (15 years ago) by pw
Branch: MAIN
Changes since 1.11: +4 -3 lines
fix find-class (when called with nil second arg) to be silent
even if the supplied class name is invalid.
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 dtc 1.10 #+cmu
28     (ext:file-comment
29 pw 1.12 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/macros.lisp,v 1.12 1999/04/15 22:38:15 pw 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     (proclaim '(declaration
41     #-Genera values ;I use this so that Zwei can remind
42     ;me what values a function returns.
43    
44     #-Genera arglist ;Tells me what the pretty arglist
45     ;of something (which probably takes
46     ;&rest args) is.
47    
48     #-Genera indentation ;Tells ZWEI how to indent things
49     ;like defclass.
50     class
51     variable-rebinding
52     pcl-fast-call
53 ram 1.5 method-name
54     method-lambda-list
55 wlott 1.1 ))
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 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     #+Lucid
168     (eval-when (compile load eval)
169     (eval `(defstruct ,(intern "FASLESCAPE" (find-package 'lucid)))))
170    
171     (defvar *keyword-package* (find-package 'keyword))
172    
173 wlott 1.1 (defun make-keyword (symbol)
174     (intern (symbol-name symbol) *keyword-package*))
175    
176     (eval-when (compile load eval)
177    
178     (defun string-append (&rest strings)
179     (setq strings (copy-list strings)) ;The explorer can't even
180     ;rplaca an &rest arg?
181     (do ((string-loc strings (cdr string-loc)))
182     ((null string-loc)
183     (apply #'concatenate 'string strings))
184     (rplaca string-loc (string (car string-loc)))))
185     )
186    
187     (defun symbol-append (sym1 sym2 &optional (package *package*))
188     (intern (string-append sym1 sym2) package))
189    
190     (defmacro check-member (place list &key (test #'eql) (pretty-name place))
191     (once-only (place list)
192     `(or (member ,place ,list :test ,test)
193     (error "The value of ~A, ~S is not one of ~S."
194     ',pretty-name ,place ,list))))
195    
196     (defmacro alist-entry (alist key make-entry-fn)
197     (once-only (alist key)
198     `(or (assq ,key ,alist)
199     (progn (setf ,alist (cons (,make-entry-fn ,key) ,alist))
200     (car ,alist)))))
201    
202     ;;; A simple version of destructuring-bind.
203    
204     ;;; This does no more error checking than CAR and CDR themselves do. Some
205     ;;; attempt is made to be smart about preserving intermediate values. It
206     ;;; could be better, although the only remaining case should be easy for
207     ;;; the compiler to spot since it compiles to PUSH POP.
208     ;;;
209     ;;; Common Lisp BUG:
210     ;;; Common Lisp should have destructuring-bind.
211     ;;;
212     (defmacro destructuring-bind (pattern form &body body)
213     (multiple-value-bind (ignore declares body)
214     (extract-declarations body)
215     (declare (ignore ignore))
216     (multiple-value-bind (setqs binds)
217     (destructure pattern form)
218     `(let ,binds
219     ,@declares
220     ,@setqs
221     (progn .destructure-form.)
222     . ,body))))
223    
224     (eval-when (compile load eval)
225     (defun destructure (pattern form)
226 ram 1.5 ;;(declare (values setqs binds))
227 wlott 1.1 (let ((*destructure-vars* ())
228     (setqs ()))
229     (declare (special *destructure-vars*))
230     (setq *destructure-vars* '(.destructure-form.)
231     setqs (list `(setq .destructure-form. ,form))
232     form '.destructure-form.)
233     (values (nconc setqs (nreverse (destructure-internal pattern form)))
234     (delete nil *destructure-vars*))))
235    
236     (defun destructure-internal (pattern form)
237     ;; When we are called, pattern must be a list. Form should be a symbol
238     ;; which we are free to setq containing the value to be destructured.
239     ;; Optimizations are performed for the last element of pattern cases.
240     ;; we assume that the compiler is smart about gensyms which are bound
241     ;; but only for a short period of time.
242     (declare (special *destructure-vars*))
243     (let ((gensym (gensym))
244     (pending-pops 0)
245     (var nil)
246     (setqs ()))
247     (labels
248     ((make-pop (var form pop-into)
249     (prog1
250     (cond ((zerop pending-pops)
251     `(progn ,(and var `(setq ,var (car ,form)))
252     ,(and pop-into `(setq ,pop-into (cdr ,form)))))
253     ((null pop-into)
254     (and var `(setq ,var ,(make-caxr pending-pops form))))
255     (t
256     `(progn (setq ,pop-into ,(make-cdxr pending-pops form))
257     ,(and var `(setq ,var (pop ,pop-into))))))
258     (setq pending-pops 0))))
259     (do ((pat pattern (cdr pat)))
260     ((null pat) ())
261     (if (symbolp (setq var (car pat)))
262     (progn
263     #-:coral (unless (memq var '(nil ignore))
264     (push var *destructure-vars*))
265     #+:coral (push var *destructure-vars*)
266     (cond ((null (cdr pat))
267     (push (make-pop var form ()) setqs))
268     ((symbolp (cdr pat))
269     (push (make-pop var form (cdr pat)) setqs)
270     (push (cdr pat) *destructure-vars*)
271     (return ()))
272     #-:coral
273     ((memq var '(nil ignore)) (incf pending-pops))
274     #-:coral
275     ((memq (cadr pat) '(nil ignore))
276     (push (make-pop var form ()) setqs)
277     (incf pending-pops 1))
278     (t
279     (push (make-pop var form form) setqs))))
280     (progn
281     (push `(let ((,gensym ()))
282     ,(make-pop gensym
283     form
284     (if (symbolp (cdr pat)) (cdr pat) form))
285     ,@(nreverse
286 pw 1.9 (destructure-internal (car pat) gensym)))
287 wlott 1.1 setqs)
288     (when (symbolp (cdr pat))
289     (push (cdr pat) *destructure-vars*)
290     (return)))))
291     setqs)))
292     )
293    
294    
295     (defmacro collecting-once (&key initial-value)
296     `(let* ((head ,initial-value)
297     (tail ,(and initial-value `(last head))))
298     (values #'(lambda (value)
299     (if (null head)
300     (setq head (setq tail (list value)))
301     (unless (memq value head)
302     (setq tail
303     (cdr (rplacd tail (list value)))))))
304     #'(lambda nil head))))
305    
306     (defmacro doplist ((key val) plist &body body &environment env)
307     (multiple-value-bind (doc decls bod)
308     (extract-declarations body env)
309     (declare (ignore doc))
310     `(let ((.plist-tail. ,plist) ,key ,val)
311     ,@decls
312     (loop (when (null .plist-tail.) (return nil))
313     (setq ,key (pop .plist-tail.))
314     (when (null .plist-tail.)
315     (error "Malformed plist in doplist, odd number of elements."))
316     (setq ,val (pop .plist-tail.))
317     (progn ,@bod)))))
318    
319     (defmacro if* (condition true &rest false)
320     `(if ,condition ,true (progn ,@false)))
321    
322 ram 1.3 (defmacro dolist-carefully ((var list improper-list-handler) &body body)
323     `(let ((,var nil)
324     (.dolist-carefully. ,list))
325     (loop (when (null .dolist-carefully.) (return nil))
326     (if (consp .dolist-carefully.)
327     (progn
328     (setq ,var (pop .dolist-carefully.))
329     ,@body)
330     (,improper-list-handler)))))
331 wlott 1.1
332     ;;
333     ;;;;;; printing-random-thing
334     ;;
335     ;;; Similar to printing-random-object in the lisp machine but much simpler
336     ;;; and machine independent.
337     (defmacro printing-random-thing ((thing stream) &body body)
338 pw 1.7 #+cmu17
339     `(print-unreadable-object (,thing ,stream :identity t) ,@body)
340     #-cmu17
341     (once-only (thing stream)
342     `(progn
343     (when *print-readably*
344     (error "~S cannot be printed readably." thing))
345     (format ,stream "#<")
346     ,@body
347     (format ,stream " ")
348     (printing-random-thing-internal ,thing ,stream)
349     (format ,stream ">"))))
350 wlott 1.1
351     (defun printing-random-thing-internal (thing stream)
352     (declare (ignore thing stream))
353     nil)
354    
355     ;;
356     ;;;;;;
357     ;;
358    
359     (defun capitalize-words (string &optional (dashes-p t))
360     (let ((string (copy-seq (string string))))
361     (declare (string string))
362     (do* ((flag t flag)
363     (length (length string) length)
364     (char nil char)
365     (i 0 (+ i 1)))
366     ((= i length) string)
367     (setq char (elt string i))
368     (cond ((both-case-p char)
369     (if flag
370     (and (setq flag (lower-case-p char))
371     (setf (elt string i) (char-upcase char)))
372     (and (not flag) (setf (elt string i) (char-downcase char))))
373     (setq flag nil))
374     ((char-equal char #\-)
375     (setq flag t)
376     (unless dashes-p (setf (elt string i) #\space)))
377     (t (setq flag nil))))))
378    
379 ram 1.5 #-(or lucid kcl)
380     (eval-when (compile load eval)
381     ;(warn "****** Things will go faster if you fix define-compiler-macro")
382 ram 1.3 )
383 wlott 1.1
384 pw 1.7 #-cmu
385 ram 1.3 (defmacro define-compiler-macro (name arglist &body body)
386 ram 1.5 #+(or lucid kcl)
387     `(#+lucid lcl:def-compiler-macro #+kcl si::define-compiler-macro
388 phg 1.6 ,name ,arglist
389     ,@body)
390 ram 1.5 #-(or kcl lucid)
391 phg 1.6 (declare (ignore name arglist body))
392     #-(or kcl lucid)
393 ram 1.5 nil)
394 ram 1.3
395    
396 ram 1.5 ;;;
397     ;;; FIND-CLASS
398     ;;;
399     ;;; This is documented in the CLOS specification.
400     ;;;
401     (defvar *find-class* (make-hash-table :test #'eq))
402 wlott 1.1
403 ram 1.3 (defun function-returning-nil (x)
404     (declare (ignore x))
405     nil)
406    
407 ram 1.5 (defmacro find-class-cell-class (cell)
408     `(car ,cell))
409 ram 1.3
410 ram 1.5 (defmacro find-class-cell-predicate (cell)
411 phg 1.6 `(cadr ,cell))
412 ram 1.3
413 phg 1.6 (defmacro find-class-cell-make-instance-function-keys (cell)
414     `(cddr ,cell))
415    
416 ram 1.5 (defmacro make-find-class-cell (class-name)
417     (declare (ignore class-name))
418 phg 1.6 '(list* nil #'function-returning-nil nil))
419 ram 1.5
420     (defun find-class-cell (symbol &optional dont-create-p)
421     (or (gethash symbol *find-class*)
422     (unless dont-create-p
423     (unless (legal-class-name-p symbol)
424     (error "~S is not a legal class name." symbol))
425     (setf (gethash symbol *find-class*) (make-find-class-cell symbol)))))
426    
427     (defvar *create-classes-from-internal-structure-definitions-p* t)
428    
429     (defun find-class-from-cell (symbol cell &optional (errorp t))
430     (or (find-class-cell-class cell)
431     (and *create-classes-from-internal-structure-definitions-p*
432     (structure-type-p symbol)
433     (find-structure-class symbol))
434     (cond ((null errorp) nil)
435     ((legal-class-name-p symbol)
436     (error "No class named: ~S." symbol))
437     (t
438     (error "~S is not a legal class name." symbol)))))
439    
440     (defun find-class-predicate-from-cell (symbol cell &optional (errorp t))
441     (unless (find-class-cell-class cell)
442     (find-class-from-cell symbol cell errorp))
443     (find-class-cell-predicate cell))
444    
445     (defun legal-class-name-p (x)
446     (and (symbolp x)
447     (not (keywordp x))))
448    
449     (defun find-class (symbol &optional (errorp t) environment)
450     (declare (ignore environment))
451 pw 1.12 (let ((cell (find-class-cell symbol (not errorp))))
452     (when cell
453     (find-class-from-cell symbol cell errorp))))
454 ram 1.5
455     (defun find-class-predicate (symbol &optional (errorp t) environment)
456     (declare (ignore environment))
457 phg 1.6 (find-class-predicate-from-cell
458     symbol (find-class-cell symbol errorp) errorp))
459 ram 1.5
460 pw 1.7 (defvar *boot-state* nil) ; duplicate defvar to defs.lisp
461    
462     ; Use this definition in any CL implementation supporting
463     ; both define-compiler-macro and load-time-value.
464     #+cmu ; Note that in CMU, lisp:find-class /= pcl:find-class
465     (define-compiler-macro find-class (&whole form
466     symbol &optional (errorp t) environment)
467     (declare (ignore environment))
468     (if (and (constantp symbol)
469     (legal-class-name-p (eval symbol))
470     (constantp errorp)
471     (member *boot-state* '(braid complete)))
472     (let ((symbol (eval symbol))
473     (errorp (not (null (eval errorp))))
474     (class-cell (make-symbol "CLASS-CELL")))
475     `(let ((,class-cell (load-time-value (find-class-cell ',symbol))))
476     (or (find-class-cell-class ,class-cell)
477     #-cmu17
478     (find-class-from-cell ',symbol ,class-cell ,errorp)
479     #+cmu17
480     ,(if errorp
481     `(find-class-from-cell ',symbol ,class-cell t)
482     `(and (kernel:class-cell-class
483     ',(kernel:find-class-cell symbol))
484     (find-class-from-cell ',symbol ,class-cell nil))))))
485     form))
486    
487 dtc 1.11 (defun (setf find-class) (new-value symbol)
488 ram 1.5 (if (legal-class-name-p symbol)
489 phg 1.6 (let ((cell (find-class-cell symbol)))
490     (setf (find-class-cell-class cell) new-value)
491     (when (or (eq *boot-state* 'complete)
492     (eq *boot-state* 'braid))
493 pw 1.8 (when (and new-value (class-wrapper new-value))
494     (setf (find-class-cell-predicate cell)
495     (symbol-function (class-predicate-name new-value))))
496 phg 1.6 (when (and new-value (not (forward-referenced-class-p new-value)))
497 pw 1.7
498 phg 1.6 (dolist (keys+aok (find-class-cell-make-instance-function-keys cell))
499     (update-initialize-info-internal
500     (initialize-info new-value (car keys+aok) nil (cdr keys+aok))
501 pw 1.8 'make-instance-function))))
502     new-value)
503 ram 1.5 (error "~S is not a legal class name." symbol)))
504    
505 dtc 1.11 (defun (setf find-class-predicate) (new-value symbol)
506 ram 1.5 (if (legal-class-name-p symbol)
507     (setf (find-class-cell-predicate (find-class-cell symbol)) new-value)
508     (error "~S is not a legal class name." symbol)))
509    
510 wlott 1.1 (defmacro gathering1 (gatherer &body body)
511     `(gathering ((.gathering1. ,gatherer))
512     (macrolet ((gather1 (x) `(gather ,x .gathering1.)))
513     ,@body)))
514    
515    
516     ;;;
517     ;;; These are augmented definitions of list-elements and list-tails from
518     ;;; iterate.lisp. These versions provide the extra :by keyword which can
519     ;;; be used to specify the step function through the list.
520     ;;;
521     (defmacro *list-elements (list &key (by #'cdr))
522     `(let ((tail ,list))
523     #'(lambda (finish)
524     (if (endp tail)
525     (funcall finish)
526     (prog1 (car tail)
527     (setq tail (funcall ,by tail)))))))
528    
529     (defmacro *list-tails (list &key (by #'cdr))
530     `(let ((tail ,list))
531     #'(lambda (finish)
532     (prog1 (if (endp tail)
533     (funcall finish)
534     tail)
535     (setq tail (funcall ,by tail))))))
536 ram 1.2
537 ram 1.3 (defmacro function-funcall (form &rest args)
538 ram 1.5 #-cmu `(funcall ,form ,@args)
539     #+cmu `(funcall (the function ,form) ,@args))
540 ram 1.3
541     (defmacro function-apply (form &rest args)
542 ram 1.5 #-cmu `(apply ,form ,@args)
543     #+cmu `(apply (the function ,form) ,@args))
544 ram 1.3
545    
546     (defsetf slot-value set-slot-value)
547    
548     (defvar *redefined-functions* nil)
549    
550     (defmacro original-definition (name)
551     `(get ,name ':definition-before-pcl))
552    
553     (defun redefine-function (name new)
554     (pushnew name *redefined-functions*)
555     (unless (original-definition name)
556     (setf (original-definition name)
557     (symbol-function name)))
558     (setf (symbol-function name)
559     (symbol-function new)))
560 ram 1.4

  ViewVC Help
Powered by ViewVC 1.1.5