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

Contents of /src/pcl/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.21.4.4 - (show annotations)
Thu Mar 20 23:41:00 2003 UTC (11 years ago) by gerd
Branch: cold-pcl
Changes since 1.21.4.3: +3 -3 lines
* std-class.lisp (inform-type-system-about-class)
(shared-initialize :after): New methods for condition-class.

* macros.lisp (find-class-from-cell): Test both structure-type-p
and condition-type-p.  Use ensure-non-standard-class.

* low.lisp (structure-type-p): Return false for conditions.
(condition-type-p): New function.

* env.lisp (coerce-to-pcl-class, make-instance, change-class)
(frob): Remove methods specializing on kernel::class.

* defs.lisp (specializer-from-type): Use
ensure-non-standard-class.
(condition-class): New metaclass.

* cmucl-documentation.lisp (setf documentation): Test
both structure-type-p and condition-type-p.

* cache.lisp (wrapper-class*): Call ensure-non-standard-class.
(raise-metatype): Handle condition-class.

* braid.lisp (find-structure-class): Variable removed.
(bootstrap-initialize-class): Add supplied-p parameter for the
prototype because class null has a nil prototype.
(ensure-non-standard-class): Renamed from find-structure-class.
Handle conditions.
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
28 (ext:file-comment
29 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/macros.lisp,v 1.21.4.4 2003/03/20 23:41:00 gerd Exp $")
30 ;;;
31 ;;; Macros global variable definitions, and other random support stuff used
32 ;;; by the rest of the system.
33 ;;;
34 ;;; For simplicity (not having to use eval-when a lot), this file must be
35 ;;; loaded before it can be compiled.
36 ;;;
37
38 (in-package :pcl)
39
40 (declaim (declaration class variable-rebinding method-name
41 method-lambda-list))
42
43 (eval-when (:compile-toplevel :load-toplevel :execute)
44
45 ;; (CLASS-PREDICATE <CLASS-NAME>
46 (ext:define-function-name-syntax class-predicate (name)
47 (symbolp (cadr name)))
48
49 ;; (SLOT-ACCESSOR <CLASS> <SLOT> <READER/WRITER/BOUNDP>)
50 ;; <CLASS> is :GLOBAL for functions used by ACCESSOR-SLOT-VALUE etc.
51 (ext:define-function-name-syntax slot-accessor (name)
52 (and (symbolp (cadr name))
53 (consp (cddr name))
54 (symbolp (caddr name))
55 (consp (cdddr name))
56 (member (cadddr name) '(reader writer boundp))))
57
58 ;; (METHOD NAME QUALIFIERS (SPECIALIZERS))
59 (ext:define-function-name-syntax method (name)
60 (ext:valid-function-name-p (cadr name)))
61
62 ;; (FAST-METHOD NAME QUALIFIERS (SPECIALIZERS))
63 (ext:define-function-name-syntax fast-method (name)
64 (ext:valid-function-name-p (cadr name)))
65
66 ;; (EFFECTIVE-METHOD GF-NAME METHOD-SPEC ...)
67 (ext:define-function-name-syntax effective-method (name)
68 (ext:valid-function-name-p (cadr name)))
69
70 ;; (CALL FUNCTION)?
71 )
72
73 ;;;
74 ;;; Age old functions which CommonLisp cleaned-up away. They probably exist
75 ;;; in other packages in all CommonLisp implementations, but I will leave it
76 ;;; to the compiler to optimize into calls to them.
77 ;;;
78 (eval-when (:compile-toplevel :load-toplevel :execute)
79 (defmacro memq (item list) `(member ,item ,list :test #'eq))
80 (defmacro assq (item list) `(assoc ,item ,list :test #'eq))
81 (defmacro rassq (item list) `(rassoc ,item ,list :test #'eq))
82 (defmacro delq (item list) `(delete ,item ,list :test #'eq))
83 (defmacro posq (item list) `(position ,item ,list :test #'eq))
84 (defmacro neq (x y) `(not (eq ,x ,y))))
85
86 (defun true (&rest ignore) (declare (ignore ignore)) t)
87 (defun false (&rest ignore) (declare (ignore ignore)) nil)
88 (defun zero (&rest ignore) (declare (ignore ignore)) 0)
89
90 (defun get-declaration (name declarations &optional default)
91 (dolist (d declarations default)
92 (dolist (form (cdr d))
93 (when (and (consp form) (eq (car form) name))
94 (return-from get-declaration (cdr form))))))
95
96
97 (defvar *keyword-package* (find-package "KEYWORD"))
98
99 (defun make-keyword (symbol)
100 (intern (symbol-name symbol) *keyword-package*))
101
102 (defmacro doplist ((key val) plist &body body &environment env)
103 (multiple-value-bind (bod decls doc)
104 (system:parse-body body env)
105 (declare (ignore doc))
106 `(let ((.plist-tail. ,plist) ,key ,val)
107 ,@decls
108 (loop (when (null .plist-tail.) (return nil))
109 (setq ,key (pop .plist-tail.))
110 (when (null .plist-tail.)
111 (error "Malformed plist in doplist, odd number of elements."))
112 (setq ,val (pop .plist-tail.))
113 (progn ,@bod)))))
114
115 (defmacro dolist-carefully ((var list improper-list-handler) &body body)
116 `(let ((,var nil)
117 (.dolist-carefully. ,list))
118 (loop (when (null .dolist-carefully.) (return nil))
119 (if (consp .dolist-carefully.)
120 (progn
121 (setq ,var (pop .dolist-carefully.))
122 ,@body)
123 (,improper-list-handler)))))
124
125 ;;
126 ;;;;;; printing-random-thing
127 ;;
128 ;;; Similar to printing-random-object in the lisp machine but much simpler
129 ;;; and machine independent.
130 (defmacro printing-random-thing ((thing stream) &body body)
131 `(print-unreadable-object (,thing ,stream :identity t) ,@body))
132
133 (defun printing-random-thing-internal (thing stream)
134 (declare (ignore thing stream))
135 nil)
136
137 ;;;
138 ;;; FIND-CLASS
139 ;;;
140 ;;; This is documented in the CLOS specification.
141 ;;;
142 (defvar *find-class* (make-hash-table :test #'eq))
143
144 (defun function-returning-nil (x)
145 (declare (ignore x))
146 nil)
147
148 (defmacro find-class-cell-class (cell)
149 `(car ,cell))
150
151 (defmacro find-class-cell-predicate (cell)
152 `(cadr ,cell))
153
154 (defmacro find-class-cell-make-instance-function-keys (cell)
155 `(cddr ,cell))
156
157 (defmacro make-find-class-cell (class-name)
158 (declare (ignore class-name))
159 '(list* nil #'function-returning-nil nil))
160
161 (defun find-class-cell (symbol &optional dont-create-p)
162 (or (gethash symbol *find-class*)
163 (unless dont-create-p
164 (unless (legal-class-name-p symbol)
165 (error "~@<~S is not a legal class name.~@:>" symbol))
166 (setf (gethash symbol *find-class*) (make-find-class-cell symbol)))))
167
168 (defvar *create-classes-from-internal-structure-definitions-p* t)
169
170 (defun find-class-from-cell (symbol cell &optional (errorp t))
171 (or (find-class-cell-class cell)
172 (and *create-classes-from-internal-structure-definitions-p*
173 (or (condition-type-p symbol) (structure-type-p symbol))
174 (ensure-non-standard-class symbol))
175 (cond ((null errorp) nil)
176 ((legal-class-name-p symbol)
177 (error "No class named ~S." symbol))
178 (t
179 (error "~S is not a legal class name." symbol)))))
180
181 (defun find-class-predicate-from-cell (symbol cell &optional (errorp t))
182 (unless (find-class-cell-class cell)
183 (find-class-from-cell symbol cell errorp))
184 (find-class-cell-predicate cell))
185
186 (defun legal-class-name-p (x)
187 (and (symbolp x) (not (null x))))
188
189 (defun find-class (symbol &optional (errorp t) environment)
190 "Returns the PCL class metaobject named by SYMBOL. An error of type
191 SIMPLE-ERROR is signaled if the class does not exist unless ERRORP
192 is NIL in which case NIL is returned. SYMBOL cannot be a keyword."
193 (declare (ignore environment))
194 (find-class-from-cell symbol (find-class-cell symbol t) errorp))
195
196 (defun find-class-predicate (symbol &optional (errorp t) environment)
197 (declare (ignore environment))
198 (find-class-predicate-from-cell
199 symbol (find-class-cell symbol errorp) errorp))
200
201 (defvar *boot-state* nil) ; duplicate defvar to defs.lisp
202
203 ;;;
204 ;;; When compiling #+BOOTABLE, *BOOT-STATE* is COMPLETE because that's
205 ;;; the setting of the host PCL. We'd could use something like
206 ;;; *COMPILE-STATE* to tell the compiler macro when it should optimize
207 ;;; or not in such a setting. For simplicity we just don't optimize
208 ;;; in the bootable PCL.
209 ;;;
210 (define-compiler-macro find-class (&whole form symbol
211 &optional (errorp t) environment)
212 (declare (ignore environment))
213 (if (and (constantp symbol)
214 (legal-class-name-p (eval symbol))
215 (constantp errorp)
216 (member *boot-state* '(braid complete))
217 (not (intersection '(:loadable-pcl :bootable-pcl) *features*)))
218 (let ((symbol (eval symbol))
219 (errorp (not (null (eval errorp))))
220 (class-cell (make-symbol "CLASS-CELL")))
221 `(let ((,class-cell (load-time-value (find-class-cell ',symbol))))
222 (or (find-class-cell-class ,class-cell)
223 ,(if errorp
224 `(find-class-from-cell ',symbol ,class-cell t)
225 `(and (kernel:class-cell-class
226 ',(kernel:find-class-cell symbol))
227 (find-class-from-cell ',symbol ,class-cell nil))))))
228 form))
229
230 (defun (setf find-class) (new-value symbol)
231 (if (legal-class-name-p symbol)
232 (let ((cell (find-class-cell symbol)))
233 (setf (find-class-cell-class cell) new-value)
234 (when (or (eq *boot-state* 'complete)
235 (eq *boot-state* 'braid))
236 (when (and new-value (class-wrapper new-value))
237 (setf (find-class-cell-predicate cell)
238 (fdefinition (class-predicate-name new-value))))
239 (update-ctors 'setf-find-class :class new-value :name symbol))
240 new-value)
241 (error "~S is not a legal class name." symbol)))
242
243 (defun (setf find-class-predicate) (new-value symbol)
244 (if (legal-class-name-p symbol)
245 (setf (find-class-cell-predicate (find-class-cell symbol)) new-value)
246 (error "~S is not a legal class name." symbol)))
247
248 (defmacro function-funcall (form &rest args)
249 `(funcall (the function ,form) ,@args))
250
251 (defmacro function-apply (form &rest args)
252 `(apply (the function ,form) ,@args))
253
254
255 (defsetf slot-value set-slot-value)
256
257 (declaim (inline car-safe))
258
259 (defun car-safe (obj)
260 (when (consp obj)
261 (car obj)))
262
263 (defvar *cold-boot-state* nil)
264
265 #+pcl-debug
266 (defmacro %print (&rest args)
267 `(when *cold-boot-state*
268 (system:%primitive print ,@args)))
269
270 #-pcl-debug
271 (defmacro %print (&rest args)
272 (declare (ignore args)))
273
274 #+bootable-pcl
275 (defmacro /show (msg)
276 `(system:%primitive print ,msg))
277
278 #-bootable-pcl
279 (defmacro /show (&rest args)
280 )
281

  ViewVC Help
Powered by ViewVC 1.1.5