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

Contents of /src/pcl/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4.1.1 - (show annotations) (vendor branch)
Fri Aug 14 01:31:16 1992 UTC (21 years, 8 months ago) by ram
Changes since 1.4: +1 -2 lines
Don't clobber DEFINE-COMPILER-MACRO, because we have it now.
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 ;;; Macros global variable definitions, and other random support stuff used
28 ;;; by the rest of the system.
29 ;;;
30 ;;; For simplicity (not having to use eval-when a lot), this file must be
31 ;;; loaded before it can be compiled.
32 ;;;
33
34 (in-package 'pcl)
35
36 (proclaim '(declaration
37 #-Genera values ;I use this so that Zwei can remind
38 ;me what values a function returns.
39
40 #-Genera arglist ;Tells me what the pretty arglist
41 ;of something (which probably takes
42 ;&rest args) is.
43
44 #-Genera indentation ;Tells ZWEI how to indent things
45 ;like defclass.
46 class
47 variable-rebinding
48 pcl-fast-call
49 specializer-names
50 ))
51
52 ;;; Age old functions which CommonLisp cleaned-up away. They probably exist
53 ;;; in other packages in all CommonLisp implementations, but I will leave it
54 ;;; to the compiler to optimize into calls to them.
55 ;;;
56 ;;; Common Lisp BUG:
57 ;;; Some Common Lisps define these in the Lisp package which causes
58 ;;; all sorts of lossage. Common Lisp should explictly specify which
59 ;;; symbols appear in the Lisp package.
60 ;;;
61 (eval-when (compile load eval)
62
63 (defmacro memq (item list) `(member ,item ,list :test #'eq))
64 (defmacro assq (item list) `(assoc ,item ,list :test #'eq))
65 (defmacro rassq (item list) `(rassoc ,item ,list :test #'eq))
66 (defmacro delq (item list) `(delete ,item ,list :test #'eq))
67 (defmacro posq (item list) `(position ,item ,list :test #'eq))
68 (defmacro neq (x y) `(not (eq ,x ,y)))
69
70
71 (defun make-caxr (n form)
72 (declare (type fixnum n))
73 (if (< n 4)
74 `(,(nth n '(car cadr caddr cadddr)) ,form)
75 (make-caxr (the fixnum (- n 4)) `(cddddr ,form))))
76
77 (defun make-cdxr (n form)
78 (declare (type fixnum n))
79 (cond ((zerop n) form)
80 ((< n 5) `(,(nth n '(identity cdr cddr cdddr cddddr)) ,form))
81 (t (make-cdxr (the fixnum (- n 4)) `(cddddr ,form)))))
82 )
83
84
85 (defun true (&rest ignore) (declare (ignore ignore)) t)
86 (defun false (&rest ignore) (declare (ignore ignore)) nil)
87 (defun zero (&rest ignore) (declare (ignore ignore)) 0)
88 (defvar *keyword-package* (find-package 'keyword))
89
90 (defun make-plist (keys vals)
91 (if (null vals)
92 ()
93 (list* (car keys)
94 (car vals)
95 (make-plist (cdr keys) (cdr vals)))))
96
97 (defun remtail (list tail)
98 (if (eq list tail) () (cons (car list) (remtail (cdr list) tail))))
99
100 ;;; ONCE-ONLY does the same thing as it does in zetalisp. I should have just
101 ;;; lifted it from there but I am honest. Not only that but this one is
102 ;;; written in Common Lisp. I feel a lot like bootstrapping, or maybe more
103 ;;; like rebuilding Rome.
104 ;;;
105 ;;; Modified 5/8/92 to work right on THE forms and to not wrap an
106 ;;; extra lambda if none of the variables are complex -- TL.
107
108 (defun un-the (form)
109 "Returns the actual form within a form that may start with THE."
110 (if (and (listp form) (eq (car form) 'the))
111 (un-the (third form))
112 form))
113
114 (defun simple-eval-access-p (form)
115 "Returns whether evaluation of the form is 'simple', i.e. does not
116 require computation to calculate. This is true of constants, variables,
117 and functions."
118 (or (constantp form) ;; Form is a constant?
119 (symbolp form) ;; Form is a variable?
120 (and (listp form)
121 (eq (car form) 'function)) ;; Form is a function?
122 (and (listp form) ;; If form starts with THE, the real form
123 (eq (car form) 'the) ;; third element.
124 (simple-eval-access-p (third form)))))
125
126 (defmacro once-only (vars &body body)
127 (let ((gensym-var (gensym))
128 (run-time-vars (gensym "RUN-TIME-VARS"))
129 (run-time-vals (gensym "RUN-TIME-VALS"))
130 (expand-time-val-forms ()))
131 (dolist (var vars)
132 (push `(if (simple-eval-access-p ,var)
133 ,var
134 (let ((,gensym-var (gensym ,(symbol-name var))))
135 (push ,gensym-var ,run-time-vars)
136 (push ,var ,run-time-vals)
137 ,gensym-var))
138 expand-time-val-forms))
139 `(let* (,run-time-vars
140 ,run-time-vals
141 (wrapped-body
142 (let ,(mapcar #'list vars (reverse expand-time-val-forms))
143 ,@body)))
144 (if ,run-time-vars
145 `(let ,(mapcar #'list (reverse ,run-time-vars)
146 (reverse ,run-time-vals))
147 ,wrapped-body)
148 wrapped-body))))
149
150 #-(or cmu) ; And probably others, but this is the only I know.
151 (unless (fboundp 'declaim)
152 (defmacro declaim (&rest decl-specs)
153 (let ((proclamations NIL))
154 (declare (list proclamations))
155 (dolist (decl-spec decl-specs)
156 #-(or cmu kcl)
157 (when (eq (car decl-spec) 'ftype)
158 (dolist (function-name (cddr decl-spec))
159 (setf (get function-name 'ftype-declaimed-p) T)))
160 (push `(proclaim ',decl-spec) proclamations))
161 (if (cdr proclamations)
162 `(progn ,@proclamations)
163 (car proclamations)))))
164
165 #-(or cmu kcl)
166 (defun function-ftype-declaimed-p (name)
167 "Returns whether the function given by name already has its ftype declaimed."
168 (get name 'ftype-declaimed-p))
169
170
171 (deftype index () `(integer 0 ,most-positive-fixnum))
172
173 (defmacro pop-key-value (key
174 settable-lambda-list
175 &optional
176 default-value)
177 ;; If key is on the settable-lambda-list, then it and its value is
178 ;; destructively removed from the list, and its value is returned.
179 ;; Else, default-value is returned and the settable-lambda-list
180 ;; stays the same.
181 (once-only (key)
182 `(let ((list-ptr ,settable-lambda-list))
183 (if (eq (car list-ptr) ,key)
184 (progn
185 (setf ,settable-lambda-list (cddr list-ptr))
186 (cadr list-ptr))
187 (progn
188 (setf list-ptr (cdr list-ptr))
189 (let ((next-cdr (cdr list-ptr)))
190 (loop (when (null next-cdr)
191 (return ,default-value))
192 (when (eq (car next-cdr) ,key)
193 (setf (cdr list-ptr) (cddr next-cdr))
194 (return (cadr next-cdr)))
195 (setf next-cdr
196 (cdr (setf list-ptr (cdr next-cdr)))))))))))
197
198 (defmacro copy-simple-vector (orig)
199 "Fast way to copy a simple-vector."
200 #-kcl
201 (once-only (orig)
202 `(let* ((i 0)
203 (n (length (the simple-vector ,orig)))
204 (new (make-array n)))
205 (declare (type index i n) (type simple-vector new))
206 (tagbody
207 begin-loop
208 (if (>= i n) (go end-loop))
209 (setf (svref new i) (svref (the simple-vector ,orig) i))
210 (setf i (the index (1+ i)))
211 (go begin-loop)
212 end-loop)
213 new))
214 #+kcl
215 `(copy-seq (the simple-vector ,orig)))
216
217 (defun lambda-list-legal-p (lambda-list
218 &optional
219 (options-allowed-p T)
220 (keywords-allowed lambda-list-keywords))
221 (when (listp lambda-list)
222 (dolist (element lambda-list T)
223 (unless (or (symbolp element)
224 (memq element keywords-allowed)
225 (and options-allowed-p (listp element)))
226 (return NIL)))))
227
228
229 (defun lambda-list-required-args (lambda-list)
230 (let ((collection NIL))
231 (dolist (element lambda-list)
232 (if (memq element lambda-list-keywords)
233 (return)
234 (push element collection)))
235 (nreverse collection)))
236
237 (defun npermutation-p (list1 list2)
238 "Returns whether list1 is a permutation of list2"
239 (if (null list1)
240 (null list2)
241 (unless (null list2)
242 (when (memq (car list1) list2)
243 (npermutation-p (cdr list1)
244 (delete (car list1) list2 :count 1))))))
245
246 (defun permutation-p (list1 list2)
247 "Returns whether list1 is a permutation of list2"
248 (npermutation-p list1 (copy-list list2)))
249
250 (defun count-non-nils (list)
251 "Returns the count of non nil elements in the list."
252 (if list
253 (let ((non-nil-count 0)
254 (list-ptr list))
255 (declare (type fixnum non-nil-count))
256 (loop (when (car list-ptr)
257 (setf non-nil-count (the fixnum (1+ non-nil-count))))
258 (unless (setf list-ptr (cdr list-ptr))
259 (return non-nil-count))))
260 0))
261
262 (eval-when (compile load eval)
263 (proclaim '(ftype (function (T &optional T) (values T T T)) extract-declarations))
264 (defun extract-declarations (body &optional environment)
265 (declare (values documentation declarations body))
266 (let (documentation declarations form)
267 (when (and (stringp (car body))
268 (cdr body))
269 (setq documentation (pop body)))
270 (block outer
271 (loop
272 (when (null body) (return-from outer nil))
273 (setq form (car body))
274 (when (block inner
275 (loop (cond ((not (listp form))
276 (return-from outer nil))
277 ((eq (car form) 'declare)
278 (return-from inner 't))
279 (t
280 (multiple-value-bind (newform macrop)
281 (macroexpand-1 form environment)
282 (if (or (not (eq newform form)) macrop)
283 (setq form newform)
284 (return-from outer nil)))))))
285 (pop body)
286 (dolist (declaration (cdr form))
287 (push declaration declarations)))))
288 (values documentation
289 (and declarations `((declare ,.(nreverse declarations))))
290 body)))
291 )
292
293 ;#+Lucid
294 ;(eval-when (compile load eval)
295 ; (eval `(defstruct (,(intern "FASLESCAPE" (find-package 'lucid))))))
296
297 (defun make-keyword (symbol)
298 (intern (symbol-name symbol) *keyword-package*))
299
300 (eval-when (compile load eval)
301
302 (defun string-append (&rest strings)
303 (setq strings (copy-list strings)) ;The explorer can't even
304 ;rplaca an &rest arg?
305 (do ((string-loc strings (cdr string-loc)))
306 ((null string-loc)
307 (apply #'concatenate 'string strings))
308 (rplaca string-loc (string (car string-loc)))))
309 )
310
311 (defun symbol-append (sym1 sym2 &optional (package *package*))
312 (intern (string-append sym1 sym2) package))
313
314 (defmacro check-member (place list &key (test #'eql) (pretty-name place))
315 (once-only (place list)
316 `(or (member ,place ,list :test ,test)
317 (error "The value of ~A, ~S is not one of ~S."
318 ',pretty-name ,place ,list))))
319
320 (defmacro alist-entry (alist key make-entry-fn)
321 (once-only (alist key)
322 `(or (assq ,key ,alist)
323 (progn (setf ,alist (cons (,make-entry-fn ,key) ,alist))
324 (car ,alist)))))
325
326 ;;; A simple version of destructuring-bind.
327
328 ;;; This does no more error checking than CAR and CDR themselves do. Some
329 ;;; attempt is made to be smart about preserving intermediate values. It
330 ;;; could be better, although the only remaining case should be easy for
331 ;;; the compiler to spot since it compiles to PUSH POP.
332 ;;;
333 ;;; Common Lisp BUG:
334 ;;; Common Lisp should have destructuring-bind.
335 ;;;
336 (defmacro destructuring-bind (pattern form &body body)
337 (multiple-value-bind (ignore declares body)
338 (extract-declarations body)
339 (declare (ignore ignore))
340 (multiple-value-bind (setqs binds)
341 (destructure pattern form)
342 `(let ,binds
343 ,@declares
344 ,@setqs
345 (progn .destructure-form.)
346 . ,body))))
347
348 (eval-when (compile load eval)
349 (defun destructure (pattern form)
350 (declare (values setqs binds))
351 (let ((*destructure-vars* ())
352 (setqs ()))
353 (declare (special *destructure-vars*))
354 (setq *destructure-vars* '(.destructure-form.)
355 setqs (list `(setq .destructure-form. ,form))
356 form '.destructure-form.)
357 (values (nconc setqs (nreverse (destructure-internal pattern form)))
358 (delete nil *destructure-vars*))))
359
360 (defun destructure-internal (pattern form)
361 ;; When we are called, pattern must be a list. Form should be a symbol
362 ;; which we are free to setq containing the value to be destructured.
363 ;; Optimizations are performed for the last element of pattern cases.
364 ;; we assume that the compiler is smart about gensyms which are bound
365 ;; but only for a short period of time.
366 (declare (special *destructure-vars*))
367 (let ((gensym (gensym))
368 (pending-pops 0)
369 (var nil)
370 (setqs ()))
371 (declare (type fixnum pending-pops))
372 (labels
373 ((make-pop (var form pop-into)
374 (prog1
375 (cond ((zerop pending-pops)
376 `(progn ,(and var `(setq ,var (car ,form)))
377 ,(and pop-into `(setq ,pop-into (cdr ,form)))))
378 ((null pop-into)
379 (and var `(setq ,var ,(make-caxr pending-pops form))))
380 (t
381 `(progn (setq ,pop-into ,(make-cdxr pending-pops form))
382 ,(and var `(setq ,var (pop ,pop-into))))))
383 (setq pending-pops 0))))
384 (do ((pat pattern (cdr pat)))
385 ((null pat) ())
386 (if (symbolp (setq var (car pat)))
387 (progn
388 #-:coral (unless (memq var '(nil ignore))
389 (push var *destructure-vars*))
390 #+:coral (push var *destructure-vars*)
391 (cond ((null (cdr pat))
392 (push (make-pop var form ()) setqs))
393 ((symbolp (cdr pat))
394 (push (make-pop var form (cdr pat)) setqs)
395 (push (cdr pat) *destructure-vars*)
396 (return ()))
397 #-:coral
398 ((memq var '(nil ignore)) (incf pending-pops))
399 #-:coral
400 ((memq (cadr pat) '(nil ignore))
401 (push (make-pop var form ()) setqs)
402 (incf pending-pops 1))
403 (t
404 (push (make-pop var form form) setqs))))
405 (progn
406 (push `(let ((,gensym ()))
407 ,(make-pop gensym
408 form
409 (if (symbolp (cdr pat)) (cdr pat) form))
410 ,@(nreverse
411 (destructure-internal
412 (if (consp pat) (car pat) pat)
413 gensym)))
414 setqs)
415 (when (symbolp (cdr pat))
416 (push (cdr pat) *destructure-vars*)
417 (return)))))
418 setqs)))
419 )
420
421
422 (defmacro collecting-once (&key initial-value)
423 `(let* ((head ,initial-value)
424 (tail ,(and initial-value `(last head))))
425 (values #'(lambda (value)
426 (if (null head)
427 (setq head (setq tail (list value)))
428 (unless (memq value head)
429 (setq tail
430 (cdr (rplacd tail (list value)))))))
431 #'(lambda nil head))))
432
433 (defmacro doplist ((key val) plist &body body &environment env)
434 (multiple-value-bind (doc decls bod)
435 (extract-declarations body env)
436 (declare (ignore doc))
437 `(let ((.plist-tail. ,plist) ,key ,val)
438 ,@decls
439 (loop (when (null .plist-tail.) (return nil))
440 (setq ,key (pop .plist-tail.))
441 (when (null .plist-tail.)
442 (error "Malformed plist in doplist, odd number of elements."))
443 (setq ,val (pop .plist-tail.))
444 (progn ,@bod)))))
445
446 (defmacro if* (condition true &rest false)
447 `(if ,condition ,true (progn ,@false)))
448
449 (defmacro dolist-carefully ((var list improper-list-handler) &body body)
450 `(let ((,var nil)
451 (.dolist-carefully. ,list))
452 (loop (when (null .dolist-carefully.) (return nil))
453 (if (consp .dolist-carefully.)
454 (progn
455 (setq ,var (pop .dolist-carefully.))
456 ,@body)
457 (,improper-list-handler)))))
458
459 ;;
460 ;;;;;; printing-random-thing
461 ;;
462 ;;; Similar to printing-random-object in the lisp machine but much simpler
463 ;;; and machine independent.
464 (defmacro printing-random-thing ((thing stream) &body body)
465 (once-only (stream)
466 `(progn (format ,stream "#<")
467 ,@body
468 (format ,stream " ")
469 (printing-random-thing-internal ,thing ,stream)
470 (format ,stream ">"))))
471
472 (defun printing-random-thing-internal (thing stream)
473 (declare (ignore thing stream))
474 nil)
475
476 ;;
477 ;;;;;;
478 ;;
479
480 (defun capitalize-words (string &optional (dashes-p t))
481 (let ((string (copy-seq (string string))))
482 (declare (string string))
483 (do* ((flag t flag)
484 (length (length string) length)
485 (char nil char)
486 (i 0 (+ i 1)))
487 ((= i length) string)
488 (declare (type fixnum i length))
489 (setq char (elt string i))
490 (cond ((both-case-p char)
491 (if flag
492 (and (setq flag (lower-case-p char))
493 (setf (elt string i) (char-upcase char)))
494 (and (not flag) (setf (elt string i) (char-downcase char))))
495 (setq flag nil))
496 ((char-equal char #\-)
497 (setq flag t)
498 (unless dashes-p (setf (elt string i) #\space)))
499 (t (setq flag nil))))))
500
501 #-(or lucid kcl excl cmu)
502 (eval-when (compile)
503 (warn "****** Things would go faster if you fix define-compiler-macro for
504 your lisp")
505 )
506
507 #+(or lucid kcl excl)
508 (defmacro define-compiler-macro (name arglist &body body)
509 `(#+lucid lcl:def-compiler-macro
510 #+kcl si::define-compiler-macro
511 #+excl excl::defcmacro
512 ,name ,arglist
513 ,@body))
514
515 #-(or lucid kcl excl cmu)
516 (defmacro define-compiler-macro (name arglist &body body)
517 (declare (ignore name arglist body))
518 NIL)
519
520 (defmacro safe-subtypep (type1 type2)
521 #+(or cmu kcl excl)
522 `(subtypep ,type1 ,type2)
523 #+lucid
524 (once-only (type1 type2)
525 `(if (and (lcl:type-specifier-p ,type1)
526 (lcl:type-specifier-p ,type2))
527 (subtypep ,type1 ,type2)
528 (values nil nil)))
529 #-(or cmu kcl excl lucid)
530 (declare (ignore type1 type2))
531 #-(or cmu kcl excl lucid)
532 `(values nil nil))
533
534 (defun make-constant-function (value)
535 #'(lambda (object)
536 (declare (ignore object))
537 value))
538
539 (defun function-returning-nil (x)
540 (declare (ignore x))
541 nil)
542
543 (defun documented-function-returning-nil (args next-methods)
544 (declare (ignore args next-methods))
545 nil)
546
547 (defun function-returning-t (x)
548 (declare (ignore x))
549 t)
550
551 (defun documented-function-returning-t (args next-methods)
552 (declare (ignore args next-methods))
553 t)
554
555
556 #|| ; Anything that used this should use eval instead.
557 (defun reduce-constant (old)
558 (let ((new (eval old)))
559 (if (eq new old)
560 new
561 (if (constantp new)
562 (reduce-constant new)
563 new))))
564 ||#
565
566 (defmacro gathering1 (gatherer &body body)
567 `(gathering ((.gathering1. ,gatherer))
568 (macrolet ((gather1 (x) `(gather ,x .gathering1.)))
569 ,@body)))
570
571 ;;;
572 ;;;
573 ;;;
574 (defmacro vectorizing (&key (size 0))
575 `(let* ((limit ,size)
576 (result (make-array limit))
577 (index 0))
578 (declare (type fixnum index))
579 (values #'(lambda (value)
580 (if (= index limit)
581 (error "vectorizing more elements than promised.")
582 (progn
583 (setf (svref result index) value)
584 (setf index (the fixnum (1+ index)))
585 value)))
586 #'(lambda () result))))
587
588 ;;;
589 ;;; These are augmented definitions of list-elements and list-tails from
590 ;;; iterate.lisp. These versions provide the extra :by keyword which can
591 ;;; be used to specify the step function through the list.
592 ;;;
593 (defmacro *list-elements (list &key (by #'cdr))
594 `(let ((tail ,list))
595 #'(lambda (finish)
596 (if (endp tail)
597 (funcall finish)
598 (prog1 (car tail)
599 (setq tail (funcall ,by tail)))))))
600
601 (defmacro *list-tails (list &key (by #'cdr))
602 `(let ((tail ,list))
603 #'(lambda (finish)
604 (prog1 (if (endp tail)
605 (funcall finish)
606 tail)
607 (setq tail (funcall ,by tail))))))
608
609
610 ;;;
611 ;;; Functions and types for dealing with functions.
612 ;;;
613
614 (defun really-function-p (x)
615 "Returns whether X is really a function (as per X3J13)"
616 #+cmu (functionp x)
617 #+lucid (procedurep x)
618 #-(or cmu lucid)
619 (and (functionp x) (not (or (symbolp x) (consp x)))))
620
621 (defun really-compiled-function-p (function)
622 "Returns whether FUNCTION is really a compiled function and not an
623 interpreted function masquerading as a compiled function."
624 #-cmu
625 (compiled-function-p function)
626 #+cmu
627 (the boolean
628 (and (compiled-function-p function)
629 (not (eval:interpreted-function-p function)))))
630
631 (deftype real-function ()
632 #+cmu 'function
633 #+lucid 'system:procedure
634 #-(or cmu lucid) `(satisfies really-function-p))
635
636 (defmacro funcall-function (form &rest args)
637 #+cmu `(funcall (the function ,form) ,@args)
638 #+lucid `(funcall (the system:procedure ,form) ,@args)
639 #-(or cmu lucid) `(funcall ,form ,@args))
640
641 (defmacro apply-function (form &rest args)
642 #+cmu `(apply (the function ,form) ,@args)
643 #+lucid `(apply (the system:procedure ,form) ,@args)
644 #-(or cmu lucid) `(apply ,form ,@args))
645
646 (defmacro function-funcall (form &rest args)
647 `(funcall-function ,form ,@args))
648
649 (defmacro function-apply (form &rest args)
650 `(apply-function ,form ,@args))
651
652 (defmacro funcall-compiled (form &rest args)
653 `(funcall (the compiled-function ,form) ,@args))
654
655 (defmacro apply-compiled (form &rest args)
656 `(apply (the compiled-function ,form) ,@args))
657
658 (defmacro force-compile (fn-name)
659 "If the function named by FN-NAME isn't compiled, then compile it."
660 (once-only (fn-name)
661 `(unless (really-compiled-function-p (symbol-function ,fn-name))
662 (compile ,fn-name))))
663
664
665
666
667 ;;;
668 ;;; Convert a function name to its standard setf function name. We have to
669 ;;; do this hack because not all Common Lisps have yet converted to having
670 ;;; setf function specs.
671 ;;;
672 ;;; In a port that does have setf function specs you can use those just by
673 ;;; making the obvious simple changes to these functions. The rest of PCL
674 ;;; believes that there are function names like (SETF <foo>), this is the
675 ;;; only place that knows about this hack.
676 ;;;
677 (eval-when (compile load eval)
678 ; In 15e (and also 16c), using the built in setf mechanism costs
679 ; a hash table lookup every time a setf function is called.
680 ; Uncomment the next line to use the built in setf mechanism.
681 ;#+cmu (pushnew :setf *features*)
682 )
683
684 (eval-when (compile load eval)
685
686 #-setf
687 (defvar *setf-function-names* (make-hash-table :size 200 :test #'eq))
688
689 (defun get-setf-function-name (name)
690 #+setf `(setf ,name)
691 #-setf
692 (or (gethash name *setf-function-names*)
693 (setf (gethash name *setf-function-names*)
694 (let ((pkg (symbol-package name)))
695 (if pkg
696 (intern (format nil
697 "SETF ~A ~A"
698 (package-name pkg)
699 (symbol-name name))
700 *the-pcl-package*)
701 (make-symbol (format nil "SETF ~A" (symbol-name name))))))))
702
703 ;;;
704 ;;; Call this to define a setf macro for a function with the same behavior as
705 ;;; specified by the SETF function cleanup proposal. Specifically, this will
706 ;;; cause: (SETF (FOO a b) x) to expand to (|SETF FOO| x a b).
707 ;;;
708 ;;; do-standard-defsetf A macro interface for use at top level
709 ;;; in files. Unfortunately, users may
710 ;;; have to use this for a while.
711 ;;;
712 ;;; do-standard-defsetfs-for-defclass A special version called by defclass.
713 ;;;
714 ;;; do-standard-defsetf-1 A functional interface called by the
715 ;;; above, defmethod and defgeneric.
716 ;;; Since this is all a crock anyways,
717 ;;; users are free to call this as well.
718 ;;;
719 (defmacro do-standard-defsetf (&rest function-names)
720 `(eval-when (compile load eval)
721 (dolist (fn-name ',function-names) (do-standard-defsetf-1 fn-name))))
722
723 (defun do-standard-defsetfs-for-defclass (accessors)
724 (dolist (name accessors) (do-standard-defsetf-1 name)))
725
726 (defun do-standard-defsetf-1 (function-name)
727 #+setf
728 (declare (ignore function-name))
729 #+setf nil
730 #-setf
731 (unless (and (setfboundp function-name)
732 (get function-name 'standard-setf))
733 (setf (get function-name 'standard-setf) t)
734 (let* ((setf-function-name (get-setf-function-name function-name)))
735
736 #+Genera
737 (let ((fn #'(lambda (form)
738 (lt::help-defsetf
739 '(&rest accessor-args) '(new-value) function-name 'nil
740 `(`(,',setf-function-name ,new-value .,accessor-args))
741 form))))
742 (setf (get function-name 'lt::setf-method) fn
743 (get function-name 'lt::setf-method-internal) fn))
744
745 #+Lucid
746 (lucid::set-simple-setf-method
747 function-name
748 #'(lambda (form new-value)
749 (let* ((bindings (mapcar #'(lambda (x) `(,(gensym) ,x))
750 (cdr form)))
751 (vars (mapcar #'car bindings)))
752 ;; This may wrap spurious LET bindings around some form,
753 ;; but the PQC compiler will unwrap then.
754 `(LET (,.bindings)
755 (,setf-function-name ,new-value . ,vars)))))
756
757 #+kcl
758 (let ((helper (gensym)))
759 (setf (macro-function helper)
760 #'(lambda (form env)
761 (declare (ignore env))
762 (let* ((loc-args (butlast (cdr form)))
763 (bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) loc-args))
764 (vars (mapcar #'car bindings)))
765 `(let ,bindings
766 (,setf-function-name ,(car (last form)) ,@vars)))))
767 (eval `(defsetf ,function-name ,helper)))
768 #+Xerox
769 (flet ((setf-expander (body env)
770 (declare (ignore env))
771 (let ((temps
772 (mapcar #'(lambda (x) (declare (ignore x)) (gensym))
773 (cdr body)))
774 (forms (cdr body))
775 (vars (list (gensym))))
776 (values temps
777 forms
778 vars
779 `(,setf-function-name ,@vars ,@temps)
780 `(,function-name ,@temps)))))
781 (let ((setf-method-expander (intern (concatenate 'string
782 (symbol-name function-name)
783 "-setf-expander")
784 (symbol-package function-name))))
785 (setf (get function-name :setf-method-expander) setf-method-expander
786 (symbol-function setf-method-expander) #'setf-expander)))
787
788 #-(or Genera Lucid kcl Xerox)
789 (eval `(defsetf ,function-name (&rest accessor-args) (new-value)
790 (let* ((bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) accessor-args))
791 (vars (mapcar #'car bindings)))
792 `(let ,bindings
793 (,',setf-function-name ,new-value ,@vars)))))
794
795 )))
796
797 (defun setfboundp (symbol)
798 #-(or Genera Lucid KCL Xerox :coral cmu)
799 (declare (ignore symbol))
800 #+Genera (not (null (get-properties (symbol-plist symbol)
801 'lt::(derived-setf-function trivial-setf-method
802 setf-equivalence setf-method))))
803 #+Lucid (locally
804 (declare (special lucid::*setf-inverse-table*
805 lucid::*simple-setf-method-table*
806 lucid::*setf-method-expander-table*))
807 (or (gethash symbol lucid::*setf-inverse-table*)
808 (gethash symbol lucid::*simple-setf-method-table*)
809 (gethash symbol lucid::*setf-method-expander-table*)))
810 #+kcl (or (get symbol 'si::setf-method)
811 (get symbol 'si::setf-update-fn)
812 (get symbol 'si::setf-lambda))
813 #+Xerox (or (get symbol :setf-inverse)
814 (get symbol 'il:setf-inverse)
815 (get symbol 'il:setfn)
816 (get symbol :shared-setf-inverse)
817 (get symbol :setf-method-expander)
818 (get symbol 'il:setf-method-expander))
819 #+:coral (or (get symbol 'ccl::setf-inverse)
820 (get symbol 'ccl::setf-method-expander))
821 #+cmu (fboundp `(setf ,symbol))
822 #-(or Genera Lucid KCL Xerox :coral cmu) nil)
823
824 );eval-when
825
826
827 ;;;
828 ;;; PCL, like user code, must endure the fact that we don't have a properly
829 ;;; working setf. Many things work because they get mentioned by a defclass
830 ;;; or defmethod before they are used, but others have to be done by hand.
831 ;;;
832 (do-standard-defsetf
833 class-wrapper ;***
834 generic-function-name
835 method-function-plist
836 method-function-get
837 plist-value
838 object-plist
839 gdefinition
840 slot-value-using-class
841 )
842
843 (defsetf slot-value set-slot-value)
844
845 (defvar *redefined-functions* nil)
846 (defvar *redefined-macros* nil)
847
848 (defmacro original-definition (name)
849 `(get ,name ':definition-before-pcl))
850
851 (defun redefine-function (name new)
852 (pushnew name *redefined-functions*)
853 (unless (original-definition name)
854 (setf (original-definition name)
855 (symbol-function name)))
856 (setf (symbol-function name)
857 (symbol-function new)))
858
859 (defun redefine-macro (name new)
860 (pushnew name *redefined-macros*)
861 (unless (original-definition name)
862 (setf (original-definition name)
863 (macro-function name)))
864 (setf (macro-function name)
865 (macro-function new)))
866
867 (defun pcl::reset-pcl-package () ; Try to do this safely
868 (let* ((vars '(pcl::*pcl-directory*
869 pcl::*default-pathname-extensions*
870 pcl::*pathname-extensions*
871 pcl::*redefined-functions*))
872 (names (mapcar #'symbol-name vars))
873 (values (mapcar #'symbol-value vars)))
874 (let ((pkg (find-package "PCL")))
875 (do-symbols (sym pkg)
876 (when (eq pkg (symbol-package sym))
877 (if (constantp sym)
878 (unintern sym pkg)
879 (progn
880 (makunbound sym)
881 (unless (eq sym 'pcl::reset-pcl-package)
882 (fmakunbound sym))
883 #+cmu (fmakunbound `(setf ,sym))
884 (setf (symbol-plist sym) nil))))))
885 (let ((pkg (find-package "SLOT-ACCESSOR-NAME")))
886 (when pkg
887 (do-symbols (sym pkg)
888 (makunbound sym)
889 (fmakunbound sym)
890 (setf (symbol-plist sym) nil))))
891 (let ((pcl (find-package "PCL")))
892 (mapcar #'(lambda (name value)
893 (let ((var (intern name pcl)))
894 (proclaim `(special ,var))
895 (set var value)))
896 names values))
897 (dolist (sym pcl::*redefined-functions*)
898 (setf (symbol-function sym) (get sym ':definition-before-pcl)))
899 nil))
900

  ViewVC Help
Powered by ViewVC 1.1.5