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

Contents of /src/pcl/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3.1.1 - (show annotations) (vendor branch)
Mon Dec 14 12:53:08 1992 UTC (21 years, 4 months ago) by ram
Branch: patch_16
Changes since 1.3: +31 -28 lines
This is is March-92-PCL 2c
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 (if (< n 4)
73 `(,(nth n '(car cadr caddr cadddr)) ,form)
74 (make-caxr (- n 4) `(cddddr ,form))))
75
76 (defun make-cdxr (n form)
77 (cond ((zerop n) form)
78 ((< n 5) `(,(nth n '(identity cdr cddr cdddr cddddr)) ,form))
79 (t (make-cdxr (- n 4) `(cddddr ,form)))))
80 )
81
82 (defun true (&rest ignore) (declare (ignore ignore)) t)
83 (defun false (&rest ignore) (declare (ignore ignore)) nil)
84 (defun zero (&rest ignore) (declare (ignore ignore)) 0)
85
86 (defun make-plist (keys vals)
87 (if (null vals)
88 ()
89 (list* (car keys)
90 (car vals)
91 (make-plist (cdr keys) (cdr vals)))))
92
93 (defun remtail (list tail)
94 (if (eq list tail) () (cons (car list) (remtail (cdr list) tail))))
95
96 ;;; ONCE-ONLY does the same thing as it does in zetalisp. I should have just
97 ;;; lifted it from there but I am honest. Not only that but this one is
98 ;;; written in Common Lisp. I feel a lot like bootstrapping, or maybe more
99 ;;; like rebuilding Rome.
100 (defmacro once-only (vars &body body)
101 (let ((gensym-var (gensym))
102 (run-time-vars (gensym))
103 (run-time-vals (gensym))
104 (expand-time-val-forms ()))
105 (dolist (var vars)
106 (push `(if (or (symbolp ,var)
107 (numberp ,var)
108 (and (listp ,var)
109 (member (car ,var) '(quote function))))
110 ,var
111 (let ((,gensym-var (gensym)))
112 (push ,gensym-var ,run-time-vars)
113 (push ,var ,run-time-vals)
114 ,gensym-var))
115 expand-time-val-forms))
116 `(let* (,run-time-vars
117 ,run-time-vals
118 (wrapped-body
119 (let ,(mapcar #'list vars (reverse expand-time-val-forms))
120 ,@body)))
121 `(let ,(mapcar #'list (reverse ,run-time-vars)
122 (reverse ,run-time-vals))
123 ,wrapped-body))))
124
125 (eval-when (compile load eval)
126 (defun extract-declarations (body &optional environment)
127 ;;(declare (values documentation declarations body))
128 (let (documentation declarations form)
129 (when (and (stringp (car body))
130 (cdr body))
131 (setq documentation (pop body)))
132 (block outer
133 (loop
134 (when (null body) (return-from outer nil))
135 (setq form (car body))
136 (when (block inner
137 (loop (cond ((not (listp form))
138 (return-from outer nil))
139 ((eq (car form) 'declare)
140 (return-from inner 't))
141 (t
142 (multiple-value-bind (newform macrop)
143 (macroexpand-1 form environment)
144 (if (or (not (eq newform form)) macrop)
145 (setq form newform)
146 (return-from outer nil)))))))
147 (pop body)
148 (dolist (declaration (cdr form))
149 (push declaration declarations)))))
150 (values documentation
151 (and declarations `((declare ,.(nreverse declarations))))
152 body)))
153 )
154
155 #+Lucid
156 (eval-when (compile load eval)
157 (eval `(defstruct ,(intern "FASLESCAPE" (find-package 'lucid)))))
158
159 (defvar *keyword-package* (find-package 'keyword))
160
161 (defun make-keyword (symbol)
162 (intern (symbol-name symbol) *keyword-package*))
163
164 (eval-when (compile load eval)
165
166 (defun string-append (&rest strings)
167 (setq strings (copy-list strings)) ;The explorer can't even
168 ;rplaca an &rest arg?
169 (do ((string-loc strings (cdr string-loc)))
170 ((null string-loc)
171 (apply #'concatenate 'string strings))
172 (rplaca string-loc (string (car string-loc)))))
173 )
174
175 (defun symbol-append (sym1 sym2 &optional (package *package*))
176 (intern (string-append sym1 sym2) package))
177
178 (defmacro check-member (place list &key (test #'eql) (pretty-name place))
179 (once-only (place list)
180 `(or (member ,place ,list :test ,test)
181 (error "The value of ~A, ~S is not one of ~S."
182 ',pretty-name ,place ,list))))
183
184 (defmacro alist-entry (alist key make-entry-fn)
185 (once-only (alist key)
186 `(or (assq ,key ,alist)
187 (progn (setf ,alist (cons (,make-entry-fn ,key) ,alist))
188 (car ,alist)))))
189
190 ;;; A simple version of destructuring-bind.
191
192 ;;; This does no more error checking than CAR and CDR themselves do. Some
193 ;;; attempt is made to be smart about preserving intermediate values. It
194 ;;; could be better, although the only remaining case should be easy for
195 ;;; the compiler to spot since it compiles to PUSH POP.
196 ;;;
197 ;;; Common Lisp BUG:
198 ;;; Common Lisp should have destructuring-bind.
199 ;;;
200 (defmacro destructuring-bind (pattern form &body body)
201 (multiple-value-bind (ignore declares body)
202 (extract-declarations body)
203 (declare (ignore ignore))
204 (multiple-value-bind (setqs binds)
205 (destructure pattern form)
206 `(let ,binds
207 ,@declares
208 ,@setqs
209 (progn .destructure-form.)
210 . ,body))))
211
212 (eval-when (compile load eval)
213 (defun destructure (pattern form)
214 ;;(declare (values setqs binds))
215 (let ((*destructure-vars* ())
216 (setqs ()))
217 (declare (special *destructure-vars*))
218 (setq *destructure-vars* '(.destructure-form.)
219 setqs (list `(setq .destructure-form. ,form))
220 form '.destructure-form.)
221 (values (nconc setqs (nreverse (destructure-internal pattern form)))
222 (delete nil *destructure-vars*))))
223
224 (defun destructure-internal (pattern form)
225 ;; When we are called, pattern must be a list. Form should be a symbol
226 ;; which we are free to setq containing the value to be destructured.
227 ;; Optimizations are performed for the last element of pattern cases.
228 ;; we assume that the compiler is smart about gensyms which are bound
229 ;; but only for a short period of time.
230 (declare (special *destructure-vars*))
231 (let ((gensym (gensym))
232 (pending-pops 0)
233 (var nil)
234 (setqs ()))
235 (labels
236 ((make-pop (var form pop-into)
237 (prog1
238 (cond ((zerop pending-pops)
239 `(progn ,(and var `(setq ,var (car ,form)))
240 ,(and pop-into `(setq ,pop-into (cdr ,form)))))
241 ((null pop-into)
242 (and var `(setq ,var ,(make-caxr pending-pops form))))
243 (t
244 `(progn (setq ,pop-into ,(make-cdxr pending-pops form))
245 ,(and var `(setq ,var (pop ,pop-into))))))
246 (setq pending-pops 0))))
247 (do ((pat pattern (cdr pat)))
248 ((null pat) ())
249 (if (symbolp (setq var (car pat)))
250 (progn
251 #-:coral (unless (memq var '(nil ignore))
252 (push var *destructure-vars*))
253 #+:coral (push var *destructure-vars*)
254 (cond ((null (cdr pat))
255 (push (make-pop var form ()) setqs))
256 ((symbolp (cdr pat))
257 (push (make-pop var form (cdr pat)) setqs)
258 (push (cdr pat) *destructure-vars*)
259 (return ()))
260 #-:coral
261 ((memq var '(nil ignore)) (incf pending-pops))
262 #-:coral
263 ((memq (cadr pat) '(nil ignore))
264 (push (make-pop var form ()) setqs)
265 (incf pending-pops 1))
266 (t
267 (push (make-pop var form form) setqs))))
268 (progn
269 (push `(let ((,gensym ()))
270 ,(make-pop gensym
271 form
272 (if (symbolp (cdr pat)) (cdr pat) form))
273 ,@(nreverse
274 (destructure-internal
275 (if (consp pat) (car pat) pat)
276 gensym)))
277 setqs)
278 (when (symbolp (cdr pat))
279 (push (cdr pat) *destructure-vars*)
280 (return)))))
281 setqs)))
282 )
283
284
285 (defmacro collecting-once (&key initial-value)
286 `(let* ((head ,initial-value)
287 (tail ,(and initial-value `(last head))))
288 (values #'(lambda (value)
289 (if (null head)
290 (setq head (setq tail (list value)))
291 (unless (memq value head)
292 (setq tail
293 (cdr (rplacd tail (list value)))))))
294 #'(lambda nil head))))
295
296 (defmacro doplist ((key val) plist &body body &environment env)
297 (multiple-value-bind (doc decls bod)
298 (extract-declarations body env)
299 (declare (ignore doc))
300 `(let ((.plist-tail. ,plist) ,key ,val)
301 ,@decls
302 (loop (when (null .plist-tail.) (return nil))
303 (setq ,key (pop .plist-tail.))
304 (when (null .plist-tail.)
305 (error "Malformed plist in doplist, odd number of elements."))
306 (setq ,val (pop .plist-tail.))
307 (progn ,@bod)))))
308
309 (defmacro if* (condition true &rest false)
310 `(if ,condition ,true (progn ,@false)))
311
312 (defmacro dolist-carefully ((var list improper-list-handler) &body body)
313 `(let ((,var nil)
314 (.dolist-carefully. ,list))
315 (loop (when (null .dolist-carefully.) (return nil))
316 (if (consp .dolist-carefully.)
317 (progn
318 (setq ,var (pop .dolist-carefully.))
319 ,@body)
320 (,improper-list-handler)))))
321
322 ;;
323 ;;;;;; printing-random-thing
324 ;;
325 ;;; Similar to printing-random-object in the lisp machine but much simpler
326 ;;; and machine independent.
327 (defmacro printing-random-thing ((thing stream) &body body)
328 (once-only (stream)
329 `(progn (format ,stream "#<")
330 ,@body
331 (format ,stream " ")
332 (printing-random-thing-internal ,thing ,stream)
333 (format ,stream ">"))))
334
335 (defun printing-random-thing-internal (thing stream)
336 (declare (ignore thing stream))
337 nil)
338
339 ;;
340 ;;;;;;
341 ;;
342
343 (defun capitalize-words (string &optional (dashes-p t))
344 (let ((string (copy-seq (string string))))
345 (declare (string string))
346 (do* ((flag t flag)
347 (length (length string) length)
348 (char nil char)
349 (i 0 (+ i 1)))
350 ((= i length) string)
351 (setq char (elt string i))
352 (cond ((both-case-p char)
353 (if flag
354 (and (setq flag (lower-case-p char))
355 (setf (elt string i) (char-upcase char)))
356 (and (not flag) (setf (elt string i) (char-downcase char))))
357 (setq flag nil))
358 ((char-equal char #\-)
359 (setq flag t)
360 (unless dashes-p (setf (elt string i) #\space)))
361 (t (setq flag nil))))))
362
363 #-(or lucid kcl)
364 (eval-when (compile load eval)
365 ;(warn "****** Things will go faster if you fix define-compiler-macro")
366 )
367
368 (defmacro define-compiler-macro (name arglist &body body)
369 #+(or lucid kcl)
370 `(#+lucid lcl:def-compiler-macro #+kcl si::define-compiler-macro
371 ,name ,arglist
372 ,@body)
373 #-(or kcl lucid)
374 nil)
375
376
377 ;;;
378 ;;; FIND-CLASS
379 ;;;
380 ;;; This is documented in the CLOS specification.
381 ;;;
382 (defvar *find-class* (make-hash-table :test #'eq))
383
384 (defun make-constant-function (value)
385 #'(lambda (object)
386 (declare (ignore object))
387 value))
388
389 (defun function-returning-nil (x)
390 (declare (ignore x))
391 nil)
392
393 (defun function-returning-t (x)
394 (declare (ignore x))
395 t)
396
397 (defmacro find-class-cell-class (cell)
398 `(car ,cell))
399
400 (defmacro find-class-cell-predicate (cell)
401 `(cdr ,cell))
402
403 (defmacro make-find-class-cell (class-name)
404 (declare (ignore class-name))
405 '(cons nil #'function-returning-nil))
406
407 (defun find-class-cell (symbol &optional dont-create-p)
408 (or (gethash symbol *find-class*)
409 (unless dont-create-p
410 (unless (legal-class-name-p symbol)
411 (error "~S is not a legal class name." symbol))
412 (setf (gethash symbol *find-class*) (make-find-class-cell symbol)))))
413
414 (defvar *create-classes-from-internal-structure-definitions-p* t)
415
416 (defun find-class-from-cell (symbol cell &optional (errorp t))
417 (or (find-class-cell-class cell)
418 (and *create-classes-from-internal-structure-definitions-p*
419 (structure-type-p symbol)
420 (find-structure-class symbol))
421 (cond ((null errorp) nil)
422 ((legal-class-name-p symbol)
423 (error "No class named: ~S." symbol))
424 (t
425 (error "~S is not a legal class name." symbol)))))
426
427 (defun find-class-predicate-from-cell (symbol cell &optional (errorp t))
428 (unless (find-class-cell-class cell)
429 (find-class-from-cell symbol cell errorp))
430 (find-class-cell-predicate cell))
431
432 (defun legal-class-name-p (x)
433 (and (symbolp x)
434 (not (keywordp x))))
435
436 (defun find-class (symbol &optional (errorp t) environment)
437 (declare (ignore environment))
438 (find-class-from-cell symbol (find-class-cell symbol errorp) errorp))
439
440 (defun find-class-predicate (symbol &optional (errorp t) environment)
441 (declare (ignore environment))
442 (find-class-predicate-from-cell symbol (find-class-cell symbol errorp) errorp))
443
444 #-setf
445 (defsetf find-class (symbol &optional (errorp t) environment) (new-value)
446 (declare (ignore errorp environment))
447 `(SETF\ PCL\ FIND-CLASS ,new-value ,symbol))
448
449 (defun #-setf SETF\ PCL\ FIND-CLASS #+setf (setf find-class) (new-value symbol)
450 (if (legal-class-name-p symbol)
451 (setf (find-class-cell-class (find-class-cell symbol)) new-value)
452 (error "~S is not a legal class name." symbol)))
453
454 #-setf
455 (defsetf find-class-predicate (symbol &optional (errorp t) environment) (new-value)
456 (declare (ignore errorp environment))
457 `(SETF\ PCL\ FIND-CLASS-PREDICATE ,new-value ,symbol))
458
459 (defun #-setf SETF\ PCL\ FIND-CLASS-PREDICATE #+setf (setf find-class-predicate)
460 (new-value symbol)
461 (if (legal-class-name-p symbol)
462 (setf (find-class-cell-predicate (find-class-cell symbol)) new-value)
463 (error "~S is not a legal class name." symbol)))
464
465 (defun find-wrapper (symbol)
466 (class-wrapper (find-class symbol)))
467
468 #|| ; Anything that used this should use eval instead.
469 (defun reduce-constant (old)
470 (let ((new (eval old)))
471 (if (eq new old)
472 new
473 (if (constantp new)
474 (reduce-constant new)
475 new))))
476 ||#
477
478 (defmacro gathering1 (gatherer &body body)
479 `(gathering ((.gathering1. ,gatherer))
480 (macrolet ((gather1 (x) `(gather ,x .gathering1.)))
481 ,@body)))
482
483 ;;;
484 ;;;
485 ;;;
486 (defmacro vectorizing (&key (size 0))
487 `(let* ((limit ,size)
488 (result (make-array limit))
489 (index 0))
490 (values #'(lambda (value)
491 (if (= index limit)
492 (error "vectorizing more elements than promised.")
493 (progn
494 (setf (svref result index) value)
495 (incf index)
496 value)))
497 #'(lambda () result))))
498
499 ;;;
500 ;;; These are augmented definitions of list-elements and list-tails from
501 ;;; iterate.lisp. These versions provide the extra :by keyword which can
502 ;;; be used to specify the step function through the list.
503 ;;;
504 (defmacro *list-elements (list &key (by #'cdr))
505 `(let ((tail ,list))
506 #'(lambda (finish)
507 (if (endp tail)
508 (funcall finish)
509 (prog1 (car tail)
510 (setq tail (funcall ,by tail)))))))
511
512 (defmacro *list-tails (list &key (by #'cdr))
513 `(let ((tail ,list))
514 #'(lambda (finish)
515 (prog1 (if (endp tail)
516 (funcall finish)
517 tail)
518 (setq tail (funcall ,by tail))))))
519
520 (defmacro function-funcall (form &rest args)
521 #-cmu `(funcall ,form ,@args)
522 #+cmu `(funcall (the function ,form) ,@args))
523
524 (defmacro function-apply (form &rest args)
525 #-cmu `(apply ,form ,@args)
526 #+cmu `(apply (the function ,form) ,@args))
527
528
529 ;;;
530 ;;; Convert a function name to its standard setf function name. We have to
531 ;;; do this hack because not all Common Lisps have yet converted to having
532 ;;; setf function specs.
533 ;;;
534 ;;; In a port that does have setf function specs you can use those just by
535 ;;; making the obvious simple changes to these functions. The rest of PCL
536 ;;; believes that there are function names like (SETF <foo>), this is the
537 ;;; only place that knows about this hack.
538 ;;;
539 (eval-when (compile load eval)
540 ; In 15e (and also 16c), using the built in setf mechanism costs
541 ; a hash table lookup every time a setf function is called.
542 ; Uncomment the next line to use the built in setf mechanism.
543 ;#+cmu (pushnew :setf *features*)
544 )
545
546 (eval-when (compile load eval)
547
548 #-setf
549 (defvar *setf-function-names* (make-hash-table :size 200 :test #'eq))
550
551 (defun get-setf-function-name (name)
552 #+setf `(setf ,name)
553 #-setf
554 (or (gethash name *setf-function-names*)
555 (setf (gethash name *setf-function-names*)
556 (let ((pkg (symbol-package name)))
557 (if pkg
558 (intern (format nil
559 "SETF ~A ~A"
560 (package-name pkg)
561 (symbol-name name))
562 *the-pcl-package*)
563 (make-symbol (format nil "SETF ~A" (symbol-name name))))))))
564
565 ;;;
566 ;;; Call this to define a setf macro for a function with the same behavior as
567 ;;; specified by the SETF function cleanup proposal. Specifically, this will
568 ;;; cause: (SETF (FOO a b) x) to expand to (|SETF FOO| x a b).
569 ;;;
570 ;;; do-standard-defsetf A macro interface for use at top level
571 ;;; in files. Unfortunately, users may
572 ;;; have to use this for a while.
573 ;;;
574 ;;; do-standard-defsetfs-for-defclass A special version called by defclass.
575 ;;;
576 ;;; do-standard-defsetf-1 A functional interface called by the
577 ;;; above, defmethod and defgeneric.
578 ;;; Since this is all a crock anyways,
579 ;;; users are free to call this as well.
580 ;;;
581 (defmacro do-standard-defsetf (&rest function-names)
582 `(eval-when (compile load eval)
583 (dolist (fn-name ',function-names) (do-standard-defsetf-1 fn-name))))
584
585 (defun do-standard-defsetfs-for-defclass (accessors)
586 (dolist (name accessors) (do-standard-defsetf-1 name)))
587
588 (defun do-standard-defsetf-1 (function-name)
589 #+setf
590 (declare (ignore function-name))
591 #+setf nil
592 #-setf
593 (unless (and (setfboundp function-name)
594 (get function-name 'standard-setf))
595 (setf (get function-name 'standard-setf) t)
596 (let* ((setf-function-name (get-setf-function-name function-name)))
597
598 #+Genera
599 (let ((fn #'(lambda (form)
600 (lt::help-defsetf
601 '(&rest accessor-args) '(new-value) function-name 'nil
602 `(`(,',setf-function-name ,new-value .,accessor-args))
603 form))))
604 (setf (get function-name 'lt::setf-method) fn
605 (get function-name 'lt::setf-method-internal) fn))
606
607 #+Lucid
608 (lucid::set-simple-setf-method
609 function-name
610 #'(lambda (form new-value)
611 (let* ((bindings (mapcar #'(lambda (x) `(,(gensym) ,x))
612 (cdr form)))
613 (vars (mapcar #'car bindings)))
614 ;; This may wrap spurious LET bindings around some form,
615 ;; but the PQC compiler will unwrap then.
616 `(LET (,.bindings)
617 (,setf-function-name ,new-value . ,vars)))))
618
619 #+kcl
620 (let ((helper (gensym)))
621 (setf (macro-function helper)
622 #'(lambda (form env)
623 (declare (ignore env))
624 (let* ((loc-args (butlast (cdr form)))
625 (bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) loc-args))
626 (vars (mapcar #'car bindings)))
627 `(let ,bindings
628 (,setf-function-name ,(car (last form)) ,@vars)))))
629 (eval `(defsetf ,function-name ,helper)))
630 #+Xerox
631 (flet ((setf-expander (body env)
632 (declare (ignore env))
633 (let ((temps
634 (mapcar #'(lambda (x) (declare (ignore x)) (gensym))
635 (cdr body)))
636 (forms (cdr body))
637 (vars (list (gensym))))
638 (values temps
639 forms
640 vars
641 `(,setf-function-name ,@vars ,@temps)
642 `(,function-name ,@temps)))))
643 (let ((setf-method-expander (intern (concatenate 'string
644 (symbol-name function-name)
645 "-setf-expander")
646 (symbol-package function-name))))
647 (setf (get function-name :setf-method-expander) setf-method-expander
648 (symbol-function setf-method-expander) #'setf-expander)))
649
650 #-(or Genera Lucid kcl Xerox)
651 (eval `(defsetf ,function-name (&rest accessor-args) (new-value)
652 (let* ((bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) accessor-args))
653 (vars (mapcar #'car bindings)))
654 `(let ,bindings
655 (,',setf-function-name ,new-value ,@vars)))))
656
657 )))
658
659 (defun setfboundp (symbol)
660 #+Genera (not (null (get-properties (symbol-plist symbol)
661 'lt::(derived-setf-function trivial-setf-method
662 setf-equivalence setf-method))))
663 #+Lucid (locally
664 (declare (special lucid::*setf-inverse-table*
665 lucid::*simple-setf-method-table*
666 lucid::*setf-method-expander-table*))
667 (or (gethash symbol lucid::*setf-inverse-table*)
668 (gethash symbol lucid::*simple-setf-method-table*)
669 (gethash symbol lucid::*setf-method-expander-table*)))
670 #+kcl (or (get symbol 'si::setf-method)
671 (get symbol 'si::setf-update-fn)
672 (get symbol 'si::setf-lambda))
673 #+Xerox (or (get symbol :setf-inverse)
674 (get symbol 'il:setf-inverse)
675 (get symbol 'il:setfn)
676 (get symbol :shared-setf-inverse)
677 (get symbol :setf-method-expander)
678 (get symbol 'il:setf-method-expander))
679 #+:coral (or (get symbol 'ccl::setf-inverse)
680 (get symbol 'ccl::setf-method-expander))
681 #+cmu (fboundp `(setf ,symbol))
682 #-(or Genera Lucid KCL Xerox :coral cmu) nil)
683
684 );eval-when
685
686
687 ;;;
688 ;;; PCL, like user code, must endure the fact that we don't have a properly
689 ;;; working setf. Many things work because they get mentioned by a defclass
690 ;;; or defmethod before they are used, but others have to be done by hand.
691 ;;;
692 (do-standard-defsetf
693 class-wrapper ;***
694 generic-function-name
695 method-function-plist
696 method-function-get
697 plist-value
698 object-plist
699 gdefinition
700 slot-value-using-class
701 )
702
703 (defsetf slot-value set-slot-value)
704
705 (defvar *redefined-functions* nil)
706
707 (defmacro original-definition (name)
708 `(get ,name ':definition-before-pcl))
709
710 (defun redefine-function (name new)
711 (pushnew name *redefined-functions*)
712 (unless (original-definition name)
713 (setf (original-definition name)
714 (symbol-function name)))
715 (setf (symbol-function name)
716 (symbol-function new)))
717
718 (defun pcl::reset-pcl-package () ; Try to do this safely
719 (let* ((vars '(pcl::*pcl-directory*
720 pcl::*default-pathname-extensions*
721 pcl::*pathname-extensions*
722 pcl::*redefined-functions*))
723 (names (mapcar #'symbol-name vars))
724 (values (mapcar #'symbol-value vars)))
725 (let ((pkg (find-package "PCL")))
726 (do-symbols (sym pkg)
727 (when (eq pkg (symbol-package sym))
728 (if (constantp sym)
729 (unintern sym pkg)
730 (progn
731 (makunbound sym)
732 (unless (eq sym 'pcl::reset-pcl-package)
733 (fmakunbound sym))
734 #+cmu (fmakunbound `(setf ,sym))
735 (setf (symbol-plist sym) nil))))))
736 (let ((pkg (find-package "SLOT-ACCESSOR-NAME")))
737 (when pkg
738 (do-symbols (sym pkg)
739 (makunbound sym)
740 (fmakunbound sym)
741 (setf (symbol-plist sym) nil))))
742 (let ((pcl (find-package "PCL")))
743 (mapcar #'(lambda (name value)
744 (let ((var (intern name pcl)))
745 (proclaim `(special ,var))
746 (set var value)))
747 names values))
748 (dolist (sym pcl::*redefined-functions*)
749 (setf (symbol-function sym) (get sym ':definition-before-pcl)))
750 nil))

  ViewVC Help
Powered by ViewVC 1.1.5