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

Contents of /src/pcl/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide annotations)
Mon Jun 1 18:38:30 1992 UTC (21 years, 10 months ago) by ram
Branch: MAIN
Branch point for: patch_16
Changes since 1.2: +319 -9 lines
This is March-92-PCL-2a.
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     ;;; 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 ram 1.3 specializer-names
50 wlott 1.1 ))
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 ram 1.3 ;;(declare (values documentation declarations body))
128 wlott 1.1 (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 ram 1.3 ;;(declare (values setqs binds))
215 wlott 1.1 (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 ram 1.3 (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 wlott 1.1
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 ram 1.3 #-(or lucid kcl)
364     (eval-when (compile load eval)
365     ;(warn "****** Things will go faster if you fix define-compiler-macro")
366     )
367 wlott 1.1
368 ram 1.3 (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 wlott 1.1 ;;;
378     ;;; FIND-CLASS
379     ;;;
380     ;;; This is documented in the CLOS specification.
381     ;;;
382     (defvar *find-class* (make-hash-table :test #'eq))
383    
384 ram 1.3 (defun make-constant-function (value)
385     #'(lambda (object)
386     (declare (ignore object))
387     value))
388 wlott 1.1
389 ram 1.3 (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 wlott 1.1 (or (gethash symbol *find-class*)
409 ram 1.3 (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 wlott 1.1 (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 ram 1.3 (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 wlott 1.1 (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 ram 1.3 (defun #-setf SETF\ PCL\ FIND-CLASS #+setf (setf find-class) (new-value symbol)
450 wlott 1.1 (if (legal-class-name-p symbol)
451 ram 1.3 (setf (find-class-cell-class (find-class-cell symbol)) new-value)
452 wlott 1.1 (error "~S is not a legal class name." symbol)))
453    
454 ram 1.3 #-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 wlott 1.1 (defun find-wrapper (symbol)
466     (class-wrapper (find-class symbol)))
467    
468 ram 1.2 #|| ; Anything that used this should use eval instead.
469 wlott 1.1 (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 ram 1.2 ||#
477 wlott 1.1
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 ram 1.2
520 ram 1.3 (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 (setfboundp function-name)
594     (let* ((setf-function-name (get-setf-function-name function-name)))
595    
596     #+Genera
597     (let ((fn #'(lambda (form)
598     (lt::help-defsetf
599     '(&rest accessor-args) '(new-value) function-name 'nil
600     `(`(,',setf-function-name ,new-value .,accessor-args))
601     form))))
602     (setf (get function-name 'lt::setf-method) fn
603     (get function-name 'lt::setf-method-internal) fn))
604    
605     #+Lucid
606     (lucid::set-simple-setf-method
607     function-name
608     #'(lambda (form new-value)
609     (let* ((bindings (mapcar #'(lambda (x) `(,(gensym) ,x))
610     (cdr form)))
611     (vars (mapcar #'car bindings)))
612     ;; This may wrap spurious LET bindings around some form,
613     ;; but the PQC compiler will unwrap then.
614     `(LET (,.bindings)
615     (,setf-function-name ,new-value . ,vars)))))
616    
617     #+kcl
618     (let ((helper (gensym)))
619     (setf (macro-function helper)
620     #'(lambda (form env)
621     (declare (ignore env))
622     (let* ((loc-args (butlast (cdr form)))
623     (bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) loc-args))
624     (vars (mapcar #'car bindings)))
625     `(let ,bindings
626     (,setf-function-name ,(car (last form)) ,@vars)))))
627     (eval `(defsetf ,function-name ,helper)))
628     #+Xerox
629     (flet ((setf-expander (body env)
630     (declare (ignore env))
631     (let ((temps
632     (mapcar #'(lambda (x) (declare (ignore x)) (gensym))
633     (cdr body)))
634     (forms (cdr body))
635     (vars (list (gensym))))
636     (values temps
637     forms
638     vars
639     `(,setf-function-name ,@vars ,@temps)
640     `(,function-name ,@temps)))))
641     (let ((setf-method-expander (intern (concatenate 'string
642     (symbol-name function-name)
643     "-setf-expander")
644     (symbol-package function-name))))
645     (setf (get function-name :setf-method-expander) setf-method-expander
646     (symbol-function setf-method-expander) #'setf-expander)))
647    
648     #-(or Genera Lucid kcl Xerox)
649     (eval `(defsetf ,function-name (&rest accessor-args) (new-value)
650     (let* ((bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) accessor-args))
651     (vars (mapcar #'car bindings)))
652     `(let ,bindings
653     (,',setf-function-name ,new-value ,@vars)))))
654    
655     )))
656    
657     (defun setfboundp (symbol)
658     #+Genera (not (null (get-properties (symbol-plist symbol)
659     'lt::(derived-setf-function trivial-setf-method
660     setf-equivalence setf-method))))
661     #+Lucid (locally
662     (declare (special lucid::*setf-inverse-table*
663     lucid::*simple-setf-method-table*
664     lucid::*setf-method-expander-table*))
665     (or (gethash symbol lucid::*setf-inverse-table*)
666     (gethash symbol lucid::*simple-setf-method-table*)
667     (gethash symbol lucid::*setf-method-expander-table*)))
668     #+kcl (or (get symbol 'si::setf-method)
669     (get symbol 'si::setf-update-fn)
670     (get symbol 'si::setf-lambda))
671     #+Xerox (or (get symbol :setf-inverse)
672     (get symbol 'il:setf-inverse)
673     (get symbol 'il:setfn)
674     (get symbol :shared-setf-inverse)
675     (get symbol :setf-method-expander)
676     (get symbol 'il:setf-method-expander))
677     #+:coral (or (get symbol 'ccl::setf-inverse)
678     (get symbol 'ccl::setf-method-expander))
679     #+cmu (fboundp `(setf ,symbol))
680     #-(or Genera Lucid KCL Xerox :coral cmu) nil)
681    
682     );eval-when
683    
684    
685     ;;;
686     ;;; PCL, like user code, must endure the fact that we don't have a properly
687     ;;; working setf. Many things work because they get mentioned by a defclass
688     ;;; or defmethod before they are used, but others have to be done by hand.
689     ;;;
690     (do-standard-defsetf
691     class-wrapper ;***
692     generic-function-name
693     method-function-plist
694     method-function-get
695     plist-value
696     object-plist
697     gdefinition
698     slot-value-using-class
699     )
700    
701     (defsetf slot-value set-slot-value)
702    
703     (defvar *redefined-functions* nil)
704    
705     (defmacro original-definition (name)
706     `(get ,name ':definition-before-pcl))
707    
708     (defun redefine-function (name new)
709     (pushnew name *redefined-functions*)
710     (unless (original-definition name)
711     (setf (original-definition name)
712     (symbol-function name)))
713     (setf (symbol-function name)
714     (symbol-function new)))
715    
716     (defun reset-pcl-package () ; Try to do this safely
717     (let* ((vars '(*pcl-directory* *default-pathname-extensions* *pathname-extensions*))
718     (names (mapcar #'symbol-name vars))
719     (values (mapcar #'symbol-value vars)))
720     (when (boundp '*redefined-functions*)
721     (dolist (sym *redefined-functions*)
722     (setf (symbol-function sym) (original-definition sym)))
723     #||;; maybe even this isn't good enough
724     #+genera (scl:pkg-kill "PCL")
725     #+lucid (lcl:delete-package "PCL")
726     #-(or genera lucid) (rename-package "PCL" (symbol-name (gensym)))
727     (make-package "PCL" :use '("LISP"))
728     ||#
729     (let ((pkg (find-package "PCL")))
730     (do-symbols (sym pkg)
731     (when (eq pkg (symbol-package sym))
732     (unless (constantp sym)
733     (makunbound sym))
734     (fmakunbound sym)
735     (setf (symbol-plist sym) nil))))
736     (let ((pkg (find-package "SLOT-ACCESSOR-NAME")))
737     (do-symbols (sym pkg)
738     (makunbound sym)
739     (fmakunbound sym)
740     (setf (symbol-plist sym) nil)))
741     (let ((pcl (find-package "PCL")))
742     (mapcar #'(lambda (name value)
743     (let ((var (intern name pcl)))
744     (proclaim `(special ,var))
745     (set var value)))
746     names values)))
747     nil))

  ViewVC Help
Powered by ViewVC 1.1.5