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

Contents of /src/pcl/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.28 - (show annotations)
Fri May 23 11:05:16 2003 UTC (10 years, 11 months ago) by gerd
Branch: MAIN
Changes since 1.27: +7 -1 lines
	* src/pcl/macros.lisp (pcl-internal-function-name-p): New
	function.
	* src/pcl/boot.lisp (set-arg-info1): Use it instead of
	relying on valid-function-name-p to return nil as second
	value for PCL-internal functions.
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 (file-comment
29 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/macros.lisp,v 1.28 2003/05/23 11:05:16 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 (define-function-name-syntax class-predicate (name)
47 (when (symbolp (cadr name))
48 (values t (cadr name))))
49
50 ;; (SLOT-ACCESSOR <CLASS> <SLOT> <READER/WRITER/BOUNDP>)
51 ;; <CLASS> is :GLOBAL for functions used by ACCESSOR-SLOT-VALUE etc.
52 (define-function-name-syntax slot-accessor (name)
53 (values (and (symbolp (cadr name))
54 (consp (cddr name))
55 (symbolp (caddr name))
56 (consp (cdddr name))
57 (member (cadddr name) '(reader writer boundp)))
58 (caddr name)))
59
60 ;; (METHOD NAME QUALIFIERS (SPECIALIZERS))
61 (define-function-name-syntax method (name)
62 (valid-function-name-p (cadr name)))
63
64 ;; (FAST-METHOD NAME QUALIFIERS (SPECIALIZERS))
65 (define-function-name-syntax fast-method (name)
66 (valid-function-name-p (cadr name)))
67
68 ;; (EFFECTIVE-METHOD GF-NAME METHOD-SPEC ...)
69 (define-function-name-syntax effective-method (name)
70 (valid-function-name-p (cadr name))))
71
72 (defun pcl-internal-function-name-p (name)
73 (and (consp name)
74 (memq (car name)
75 '(class-predicate slot-accessor
76 method fast-method effective-method))))
77
78 (import '(cl::make-keyword))
79
80 (defmacro posq (item list)
81 `(position ,item ,list :test #'eq))
82
83 (defmacro neq (x y)
84 `(not (eq ,x ,y)))
85
86 (declaim (inline car-safe))
87 (defun car-safe (obj)
88 (when (consp obj)
89 (car obj)))
90
91 (defmacro doplist ((key val) plist &body body &environment env)
92 (multiple-value-bind (bod decls doc)
93 (system:parse-body body env)
94 (declare (ignore doc))
95 `(let ((.plist-tail. ,plist) ,key ,val)
96 ,@decls
97 (loop (when (null .plist-tail.) (return nil))
98 (setq ,key (pop .plist-tail.))
99 (when (null .plist-tail.)
100 (error "Malformed plist in doplist, odd number of elements."))
101 (setq ,val (pop .plist-tail.))
102 (progn ,@bod)))))
103
104
105 ;;;
106 ;;; FIND-CLASS
107 ;;;
108 ;;; This is documented in the CLOS specification.
109 ;;;
110 (defvar *find-class* (make-hash-table :test #'eq))
111
112 (defun function-returning-nil (x)
113 (declare (ignore x))
114 nil)
115
116 (defmacro find-class-cell-class (cell)
117 `(car ,cell))
118
119 (defmacro find-class-cell-predicate (cell)
120 `(cadr ,cell))
121
122 (defmacro make-find-class-cell (class-name)
123 (declare (ignore class-name))
124 '(list* nil #'function-returning-nil nil))
125
126 (defun find-class-cell (symbol &optional dont-create-p)
127 (or (gethash symbol *find-class*)
128 (unless dont-create-p
129 (unless (legal-class-name-p symbol)
130 (error "~@<~S is not a legal class name.~@:>" symbol))
131 (setf (gethash symbol *find-class*) (make-find-class-cell symbol)))))
132
133 (defvar *create-classes-from-internal-structure-definitions-p* t)
134
135 (defun find-class-from-cell (symbol cell &optional (errorp t))
136 (or (find-class-cell-class cell)
137 (and *create-classes-from-internal-structure-definitions-p*
138 (or (condition-type-p symbol) (structure-type-p symbol))
139 (ensure-non-standard-class symbol))
140 (cond ((null errorp) nil)
141 ((legal-class-name-p symbol)
142 (error "No class named ~S." symbol))
143 (t
144 (error "~S is not a legal class name." symbol)))))
145
146 (defun find-class-predicate-from-cell (symbol cell &optional (errorp t))
147 (unless (find-class-cell-class cell)
148 (find-class-from-cell symbol cell errorp))
149 (find-class-cell-predicate cell))
150
151 (defun legal-class-name-p (x)
152 (symbolp x))
153
154 (defun find-class (symbol &optional (errorp t) environment)
155 "Returns the PCL class metaobject named by SYMBOL. An error of type
156 SIMPLE-ERROR is signaled if the class does not exist unless ERRORP
157 is NIL in which case NIL is returned. SYMBOL cannot be a keyword."
158 (declare (ignore environment))
159 (find-class-from-cell symbol (find-class-cell symbol t) errorp))
160
161 (defun find-class-predicate (symbol &optional (errorp t) environment)
162 (declare (ignore environment))
163 (find-class-predicate-from-cell
164 symbol (find-class-cell symbol errorp) errorp))
165
166 (defvar *boot-state* nil) ; duplicate defvar to defs.lisp
167
168 ;;;
169 ;;; When compiling #+BOOTABLE, *BOOT-STATE* is COMPLETE because that's
170 ;;; the setting of the host PCL. We'd could use something like
171 ;;; *COMPILE-STATE* to tell the compiler macro when it should optimize
172 ;;; or not in such a setting. For simplicity we just don't optimize
173 ;;; in the bootable PCL.
174 ;;;
175 (define-compiler-macro find-class (&whole form symbol
176 &optional (errorp t) environment)
177 (declare (ignore environment))
178 (if (and (constantp symbol)
179 (legal-class-name-p (eval symbol))
180 (constantp errorp)
181 (member *boot-state* '(braid complete))
182 (not (intersection '(:loadable-pcl :bootable-pcl) *features*)))
183 (let ((symbol (eval symbol))
184 (errorp (not (null (eval errorp))))
185 (class-cell (make-symbol "CLASS-CELL")))
186 `(let ((,class-cell (load-time-value (find-class-cell ',symbol))))
187 (or (find-class-cell-class ,class-cell)
188 ,(if errorp
189 `(find-class-from-cell ',symbol ,class-cell t)
190 `(and (kernel:class-cell-class
191 ',(kernel:find-class-cell symbol))
192 (find-class-from-cell ',symbol ,class-cell nil))))))
193 form))
194
195 (defun (setf find-class) (new-value name &optional errorp environment)
196 (declare (ignore errorp environment))
197 (if (legal-class-name-p name)
198 (let ((cell (find-class-cell name)))
199 (setf (find-class-cell-class cell) new-value)
200 (when (and (eq *boot-state* 'complete) (null new-value))
201 (setf (kernel::find-class name) nil))
202 (when (memq *boot-state* '(complete braid))
203 (when (and new-value (class-wrapper new-value))
204 (setf (find-class-cell-predicate cell)
205 (fdefinition (class-predicate-name new-value))))
206 (update-ctors 'setf-find-class :class new-value :name name))
207 new-value)
208 (error "~S is not a legal class name." name)))
209
210 (defun (setf find-class-predicate) (new-value symbol)
211 (if (legal-class-name-p symbol)
212 (setf (find-class-cell-predicate (find-class-cell symbol)) new-value)
213 (error "~S is not a legal class name." symbol)))
214
215 (defmacro function-funcall (form &rest args)
216 `(funcall (the function ,form) ,@args))
217
218 (defmacro function-apply (form &rest args)
219 `(apply (the function ,form) ,@args))
220
221
222 (defsetf slot-value set-slot-value)
223
224 (defvar *cold-boot-state* nil)
225
226 #+pcl-debug
227 (defmacro %print (&rest args)
228 `(when *cold-boot-state*
229 (system:%primitive print ,@args)))
230
231 #-pcl-debug
232 (defmacro %print (&rest args)
233 (declare (ignore args)))
234
235 #+bootable-pcl
236 (defmacro /show (msg)
237 `(system:%primitive print ,msg))
238
239 #-bootable-pcl
240 (defmacro /show (&rest args)
241 (declare (ignore args)))
242

  ViewVC Help
Powered by ViewVC 1.1.5