/[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.5 - (hide annotations)
Sat Mar 22 12:28:19 2003 UTC (11 years ago) by gerd
Branch: cold-pcl
Changes since 1.21.4.4: +2 -2 lines
* pkg.lisp: Some fixes of symbol names etc.

* braid.lisp (no-applicable-method-error, no-next-method-error)
(no-primary-method-error): Added -error suffix for ANSI.

* env.lisp (describe-object): Don't print slots for condition
classes.

* pkg.lisp ("PCL"): Fix a typo in an export.

* env.lisp (make-load-form): New method for classes.

* macros.lisp (legal-class-name-p): Don't check for nil.  DEFCLASS
with nil as class name fails anyway because it tries to redefine
standard type NIL.

* braid.lisp (slot-initargs-from-structure-slotd): Make it a
local function in ensure-non-standard-class.
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.21.4.5 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/macros.lisp,v 1.21.4.5 2003/03/22 12:28:19 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.21.4.1 (declaim (declaration class variable-rebinding method-name
41     method-lambda-list))
42 wlott 1.1
43 gerd 1.21.4.1 (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 wlott 1.1 ;;; 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 pmai 1.21 (eval-when (:compile-toplevel :load-toplevel :execute)
79 gerd 1.21.4.1 (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 wlott 1.1
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 ram 1.5 (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 wlott 1.1
96 ram 1.5
97 gerd 1.21.4.1 (defvar *keyword-package* (find-package "KEYWORD"))
98 ram 1.5
99 wlott 1.1 (defun make-keyword (symbol)
100     (intern (symbol-name symbol) *keyword-package*))
101    
102     (defmacro doplist ((key val) plist &body body &environment env)
103 pmai 1.19 (multiple-value-bind (bod decls doc)
104     (system:parse-body body env)
105 wlott 1.1 (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 ram 1.3 (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 wlott 1.1
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 pw 1.14 `(print-unreadable-object (,thing ,stream :identity t) ,@body))
132 wlott 1.1
133     (defun printing-random-thing-internal (thing stream)
134     (declare (ignore thing stream))
135     nil)
136    
137 ram 1.5 ;;;
138     ;;; FIND-CLASS
139     ;;;
140     ;;; This is documented in the CLOS specification.
141     ;;;
142     (defvar *find-class* (make-hash-table :test #'eq))
143 wlott 1.1
144 ram 1.3 (defun function-returning-nil (x)
145     (declare (ignore x))
146     nil)
147    
148 ram 1.5 (defmacro find-class-cell-class (cell)
149     `(car ,cell))
150 ram 1.3
151 ram 1.5 (defmacro find-class-cell-predicate (cell)
152 phg 1.6 `(cadr ,cell))
153 ram 1.3
154 phg 1.6 (defmacro find-class-cell-make-instance-function-keys (cell)
155     `(cddr ,cell))
156    
157 ram 1.5 (defmacro make-find-class-cell (class-name)
158     (declare (ignore class-name))
159 phg 1.6 '(list* nil #'function-returning-nil nil))
160 ram 1.5
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 gerd 1.21.4.1 (error "~@<~S is not a legal class name.~@:>" symbol))
166 ram 1.5 (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 gerd 1.21.4.4 (or (condition-type-p symbol) (structure-type-p symbol))
174     (ensure-non-standard-class symbol))
175 ram 1.5 (cond ((null errorp) nil)
176     ((legal-class-name-p symbol)
177 gerd 1.21.4.1 (error "No class named ~S." symbol))
178 ram 1.5 (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 gerd 1.21.4.5 (symbolp x))
188 ram 1.5
189     (defun find-class (symbol &optional (errorp t) environment)
190 pw 1.13 "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 ram 1.5 (declare (ignore environment))
194 gerd 1.21.4.1 (find-class-from-cell symbol (find-class-cell symbol t) errorp))
195 ram 1.5
196     (defun find-class-predicate (symbol &optional (errorp t) environment)
197     (declare (ignore environment))
198 phg 1.6 (find-class-predicate-from-cell
199     symbol (find-class-cell symbol errorp) errorp))
200 ram 1.5
201 pw 1.7 (defvar *boot-state* nil) ; duplicate defvar to defs.lisp
202    
203 gerd 1.21.4.1 ;;;
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 pw 1.7 (declare (ignore environment))
213     (if (and (constantp symbol)
214     (legal-class-name-p (eval symbol))
215     (constantp errorp)
216 gerd 1.21.4.1 (member *boot-state* '(braid complete))
217     (not (intersection '(:loadable-pcl :bootable-pcl) *features*)))
218 pw 1.7 (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 dtc 1.11 (defun (setf find-class) (new-value symbol)
231 ram 1.5 (if (legal-class-name-p symbol)
232 phg 1.6 (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 pw 1.8 (when (and new-value (class-wrapper new-value))
237     (setf (find-class-cell-predicate cell)
238 gerd 1.21.4.1 (fdefinition (class-predicate-name new-value))))
239     (update-ctors 'setf-find-class :class new-value :name symbol))
240 pw 1.8 new-value)
241 ram 1.5 (error "~S is not a legal class name." symbol)))
242    
243 dtc 1.11 (defun (setf find-class-predicate) (new-value symbol)
244 ram 1.5 (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 ram 1.3 (defmacro function-funcall (form &rest args)
249 pw 1.14 `(funcall (the function ,form) ,@args))
250 ram 1.3
251     (defmacro function-apply (form &rest args)
252 pw 1.14 `(apply (the function ,form) ,@args))
253 ram 1.3
254    
255     (defsetf slot-value set-slot-value)
256    
257 gerd 1.21.4.1 (declaim (inline car-safe))
258 ram 1.3
259 gerd 1.21.4.1 (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 ram 1.4

  ViewVC Help
Powered by ViewVC 1.1.5