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

Contents of /src/pcl/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5