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 (let ((table *find-class*))
96 (with-locked-hash-table (table)
97 (or (gethash symbol table)
99 (unless (legal-class-name-p symbol)
100 (error "~S is not a legal class name." symbol))
101 (setf (gethash symbol table) (make-find-class-cell symbol)))))))
103 (/show "pcl/macros.lisp 157")
105 (defvar *create-classes-from-internal-structure-definitions-p* t)
107 (defun find-class-from-cell (symbol cell &optional (errorp t))
108 (or (find-class-cell-class cell)
109 (and *create-classes-from-internal-structure-definitions-p*
110 (or (structure-type-p symbol) (condition-type-p symbol))
111 (ensure-non-standard-class symbol))
112 (cond ((null errorp) nil)
113 ((legal-class-name-p symbol)
114 (error "There is no class named ~S." symbol))
116 (error "~S is not a legal class name." symbol)))))
118 (defun legal-class-name-p (x)
121 (defun find-class (symbol &optional (errorp t) environment)
122 (declare (ignore environment))
123 (find-class-from-cell symbol
124 (find-class-cell symbol errorp)
128 ;;; This DEFVAR was originally in defs.lisp, now moved here.
130 ;;; Possible values are NIL, EARLY, BRAID, or COMPLETE.
132 ;;; KLUDGE: This should probably become
133 ;;; (DECLAIM (TYPE (MEMBER NIL :EARLY :BRAID :COMPLETE) *BOOT-STATE*))
134 (defvar *boot-state* nil)
136 (/show "pcl/macros.lisp 187")
138 (define-compiler-macro find-class (&whole form
139 symbol &optional (errorp t) environment)
140 (declare (ignore environment))
141 (if (and (constantp symbol)
142 (legal-class-name-p (setf symbol (constant-form-value symbol)))
144 (member *boot-state* '(braid complete)))
145 (let ((errorp (not (null (constant-form-value errorp))))
146 (class-cell (make-symbol "CLASS-CELL")))
147 `(let ((,class-cell (load-time-value (find-class-cell ',symbol))))
148 (or (find-class-cell-class ,class-cell)
150 `(find-class-from-cell ',symbol ,class-cell t)
151 `(and (classoid-cell-classoid
152 ',(find-classoid-cell symbol))
153 (find-class-from-cell ',symbol ,class-cell nil))))))
156 (defun (setf find-class) (new-value name &optional errorp environment)
157 (declare (ignore errorp environment))
158 (cond ((legal-class-name-p name)
159 (with-single-package-locked-error
160 (:symbol name "using ~A as the class-name argument in ~
162 (let* ((cell (find-class-cell name))
163 (class (find-class-cell-class cell)))
164 (setf (find-class-cell-class cell) new-value)
165 (when (eq *boot-state* 'complete)
168 (setf (find-classoid name) new-value)
170 ;; KLUDGE: This horror comes about essentially
171 ;; because we use the proper name of a classoid
172 ;; to do TYPEP, which needs to be available
173 ;; early, and also to determine whether TYPE-OF
174 ;; should return the name or the class (using
175 ;; CLASSOID-PROPER-NAME). So if we are removing
176 ;; proper nameness, arrange for
177 ;; CLASSOID-PROPER-NAME to do the right thing
178 ;; too. (This is almost certainly not the right
179 ;; solution; instead, CLASSOID-NAME and
180 ;; FIND-CLASSOID should be direct parallels to
181 ;; CLASS-NAME and FIND-CLASS, and TYPEP on
182 ;; not-yet-final classes should be compileable.
183 (let ((classoid (layout-classoid (slot-value class 'wrapper))))
184 (setf (classoid-name classoid) nil))))
186 (let ((classoid (layout-classoid (slot-value new-value 'wrapper))))
187 (setf (find-classoid name) classoid)
188 (set-class-type-translation new-value classoid))))
189 (when (or (eq *boot-state* 'complete)
190 (eq *boot-state* 'braid))
191 (update-ctors 'setf-find-class :class new-value :name name))
194 (error "~S is not a legal class name." name))))
196 (/show "pcl/macros.lisp 241")
198 (defmacro function-funcall (form &rest args)
199 `(funcall (the function ,form) ,@args))
201 (defmacro function-apply (form &rest args)
202 `(apply (the function ,form) ,@args))
204 (/show "pcl/macros.lisp 249")
206 (defun get-setf-fun-name (name)
209 (defsetf slot-value set-slot-value)
211 (/show "finished with pcl/macros.lisp")