1 ;;;; macros, global variable definitions, and other miscellaneous support stuff
2 ;;;; used by the rest of the PCL subsystem
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from software originally released by Xerox
8 ;;;; Corporation. Copyright and release statements follow. Later modifications
9 ;;;; to the software are in the public domain and are provided with
10 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
13 ;;;; copyright information from original PCL sources:
15 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
16 ;;;; All rights reserved.
18 ;;;; Use and copying of this software and preparation of derivative works based
19 ;;;; upon this software are permitted. Any distribution of this software or
20 ;;;; derivative works must comply with all applicable United States export
23 ;;;; This software is made available AS IS, and Xerox Corporation makes no
24 ;;;; warranty about the software, its performance or its conformity to any
29 (/show
"starting pcl/macros.lisp")
32 ;; As of sbcl-0.7.0.6, SBCL actively uses this declaration
33 ;; to propagate information needed to set up nice debug
34 ;; names (as seen e.g. in BACKTRACE) for method functions.
36 ;; These nonstandard declarations seem to be used privately
37 ;; within PCL itself to pass information around, so we can't
41 ;; This declaration may also be used within PCL to pass
42 ;; information around, I'm not sure. -- WHN 2000-12-30
45 (/show
"done with DECLAIM DECLARATION")
47 (defun get-declaration (name declarations
&optional default
)
48 (dolist (d declarations default
)
49 (dolist (form (cdr d
))
50 (when (and (consp form
) (eq (car form
) name
))
51 (return-from get-declaration
(cdr form
))))))
53 (/show
"pcl/macros.lisp 85")
55 (defmacro doplist
((key val
) plist
&body body
)
56 `(let ((.plist-tail.
,plist
) ,key
,val
)
57 (loop (when (null .plist-tail.
) (return nil
))
58 (setq ,key
(pop .plist-tail.
))
59 (when (null .plist-tail.
)
60 (error "malformed plist, odd number of elements"))
61 (setq ,val
(pop .plist-tail.
))
64 (/show
"pcl/macros.lisp 101")
66 (defmacro dolist-carefully
((var list improper-list-handler
) &body body
)
68 (.dolist-carefully.
,list
))
69 (loop (when (null .dolist-carefully.
) (return nil
))
70 (if (consp .dolist-carefully.
)
72 (setq ,var
(pop .dolist-carefully.
))
74 (,improper-list-handler
)))))
78 ;;;; This is documented in the CLOS specification.
80 (/show
"pcl/macros.lisp 119")
82 (defvar *find-class
* (make-hash-table :test
'eq
))
84 (defmacro find-class-cell-class
(cell)
87 (defmacro find-class-cell-predicate
(cell)
90 (defmacro make-find-class-cell
(class-name)
91 (declare (ignore class-name
))
92 '(list* nil
#'constantly-nil nil
))
94 (defun find-class-cell (symbol &optional dont-create-p
)
95 (or (gethash symbol
*find-class
*)
97 (unless (legal-class-name-p symbol
)
98 (error "~S is not a legal class name." symbol
))
99 (setf (gethash symbol
*find-class
*) (make-find-class-cell symbol
)))))
101 (/show
"pcl/macros.lisp 157")
103 (defvar *create-classes-from-internal-structure-definitions-p
* t
)
105 (defun find-class-from-cell (symbol cell
&optional
(errorp t
))
106 (or (find-class-cell-class cell
)
107 (and *create-classes-from-internal-structure-definitions-p
*
108 (or (structure-type-p symbol
) (condition-type-p symbol
))
109 (ensure-non-standard-class symbol
))
110 (cond ((null errorp
) nil
)
111 ((legal-class-name-p symbol
)
112 (error "There is no class named ~S." symbol
))
114 (error "~S is not a legal class name." symbol
)))))
116 (defun find-class-predicate-from-cell (symbol cell
&optional
(errorp t
))
117 (unless (find-class-cell-class cell
)
118 (find-class-from-cell symbol cell errorp
))
119 (find-class-cell-predicate cell
))
121 (defun legal-class-name-p (x)
124 (defun find-class (symbol &optional
(errorp t
) environment
)
125 (declare (ignore environment
))
126 (find-class-from-cell symbol
127 (find-class-cell symbol errorp
)
130 (defun find-class-predicate (symbol &optional
(errorp t
) environment
)
131 (declare (ignore environment
))
132 (find-class-predicate-from-cell symbol
133 (find-class-cell symbol errorp
)
136 ;;; This DEFVAR was originally in defs.lisp, now moved here.
138 ;;; Possible values are NIL, EARLY, BRAID, or COMPLETE.
140 ;;; KLUDGE: This should probably become
141 ;;; (DECLAIM (TYPE (MEMBER NIL :EARLY :BRAID :COMPLETE) *BOOT-STATE*))
142 (defvar *boot-state
* nil
)
144 (/show
"pcl/macros.lisp 187")
146 (define-compiler-macro find-class
(&whole form
147 symbol
&optional
(errorp t
) environment
)
148 (declare (ignore environment
))
149 (if (and (constantp symbol
)
150 (legal-class-name-p (eval symbol
))
152 (member *boot-state
* '(braid complete
)))
153 (let ((symbol (eval symbol
))
154 (errorp (not (null (eval errorp
))))
155 (class-cell (make-symbol "CLASS-CELL")))
156 `(let ((,class-cell
(load-time-value (find-class-cell ',symbol
))))
157 (or (find-class-cell-class ,class-cell
)
159 `(find-class-from-cell ',symbol
,class-cell t
)
160 `(and (classoid-cell-classoid
161 ',(find-classoid-cell symbol
))
162 (find-class-from-cell ',symbol
,class-cell nil
))))))
165 (defun (setf find-class
) (new-value name
&optional errorp environment
)
166 (declare (ignore errorp environment
))
167 (if (legal-class-name-p name
)
168 (let ((cell (find-class-cell name
)))
169 (setf (find-class-cell-class cell
) new-value
)
170 (when (and (eq *boot-state
* 'complete
) (null new-value
))
171 (setf (find-classoid name
) nil
))
172 (when (or (eq *boot-state
* 'complete
)
173 (eq *boot-state
* 'braid
))
174 (when (and new-value
(class-wrapper new-value
))
175 (setf (find-class-cell-predicate cell
)
176 (fdefinition (class-predicate-name new-value
))))
177 (update-ctors 'setf-find-class
:class new-value
:name name
))
179 (error "~S is not a legal class name." name
)))
181 (/show
"pcl/macros.lisp 230")
183 (defun (setf find-class-predicate
)
185 (if (legal-class-name-p symbol
)
186 (setf (find-class-cell-predicate (find-class-cell symbol
)) new-value
)
187 (error "~S is not a legal class name." symbol
)))
189 (defun find-wrapper (symbol)
190 (class-wrapper (find-class symbol
)))
192 (/show
"pcl/macros.lisp 241")
194 (defmacro function-funcall
(form &rest args
)
195 `(funcall (the function
,form
) ,@args
))
197 (defmacro function-apply
(form &rest args
)
198 `(apply (the function
,form
) ,@args
))
200 (/show
"pcl/macros.lisp 249")
202 (defun get-setf-fun-name (name)
205 (defsetf slot-value set-slot-value
)
207 (/show
"finished with pcl/macros.lisp")