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

Contents of /src/pcl/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.24 - (hide annotations)
Fri Apr 18 08:54:41 2003 UTC (11 years ago) by gerd
Branch: MAIN
CVS Tags: remove_negative_zero_not_zero
Changes since 1.23: +9 -7 lines
	Return block names for PCL function names.  From Eric Marsden.

	* src/pcl/macros.lisp (class-predicate, slot-accessor)
	<function names>: Return block names.

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

  ViewVC Help
Powered by ViewVC 1.1.5