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

Contents of /src/pcl/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.29.48.1 - (hide annotations)
Mon Feb 8 17:15:53 2010 UTC (4 years, 2 months ago) by rtoy
Branch: intl-branch
CVS Tags: intl-branch-working-2010-02-11-1000
Changes since 1.29: +2 -1 lines
Add (intl:textdomain "cmucl") to the files to set the textdomain.
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 gerd 1.25 (file-comment
29 rtoy 1.29.48.1 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/macros.lisp,v 1.29.48.1 2010/02/08 17:15:53 rtoy 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 rtoy 1.29.48.1 (intl:textdomain "cmucl")
40 wlott 1.1
41 gerd 1.22 (declaim (declaration class variable-rebinding method-name
42     method-lambda-list))
43 wlott 1.1
44 gerd 1.22 (eval-when (:compile-toplevel :load-toplevel :execute)
45    
46     ;; (CLASS-PREDICATE <CLASS-NAME>
47 gerd 1.25 (define-function-name-syntax class-predicate (name)
48 gerd 1.24 (when (symbolp (cadr name))
49     (values t (cadr name))))
50 gerd 1.22
51     ;; (SLOT-ACCESSOR <CLASS> <SLOT> <READER/WRITER/BOUNDP>)
52     ;; <CLASS> is :GLOBAL for functions used by ACCESSOR-SLOT-VALUE etc.
53 gerd 1.25 (define-function-name-syntax slot-accessor (name)
54 gerd 1.24 (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 gerd 1.22
61     ;; (METHOD NAME QUALIFIERS (SPECIALIZERS))
62 gerd 1.25 (define-function-name-syntax method (name)
63     (valid-function-name-p (cadr name)))
64 gerd 1.22
65     ;; (FAST-METHOD NAME QUALIFIERS (SPECIALIZERS))
66 gerd 1.25 (define-function-name-syntax fast-method (name)
67     (valid-function-name-p (cadr name)))
68 gerd 1.22
69     ;; (EFFECTIVE-METHOD GF-NAME METHOD-SPEC ...)
70 gerd 1.25 (define-function-name-syntax effective-method (name)
71     (valid-function-name-p (cadr name))))
72 gerd 1.28
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 gerd 1.22
79 gerd 1.29 (import '(lisp::make-keyword))
80 gerd 1.22
81 gerd 1.25 (defmacro posq (item list)
82     `(position ,item ,list :test #'eq))
83 wlott 1.1
84 gerd 1.25 (defmacro neq (x y)
85 emarsden 1.26 `(not (eq ,x ,y)))
86 ram 1.5
87 gerd 1.25 (declaim (inline car-safe))
88     (defun car-safe (obj)
89     (when (consp obj)
90     (car obj)))
91 wlott 1.1
92     (defmacro doplist ((key val) plist &body body &environment env)
93 pmai 1.19 (multiple-value-bind (bod decls doc)
94     (system:parse-body body env)
95 wlott 1.1 (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 gerd 1.25
106 ram 1.5 ;;;
107     ;;; FIND-CLASS
108     ;;;
109     ;;; This is documented in the CLOS specification.
110     ;;;
111     (defvar *find-class* (make-hash-table :test #'eq))
112 wlott 1.1
113 ram 1.3 (defun function-returning-nil (x)
114     (declare (ignore x))
115     nil)
116    
117 ram 1.5 (defmacro find-class-cell-class (cell)
118     `(car ,cell))
119 ram 1.3
120 ram 1.5 (defmacro find-class-cell-predicate (cell)
121 phg 1.6 `(cadr ,cell))
122 ram 1.3
123 ram 1.5 (defmacro make-find-class-cell (class-name)
124     (declare (ignore class-name))
125 phg 1.6 '(list* nil #'function-returning-nil nil))
126 ram 1.5
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 gerd 1.22 (error "~@<~S is not a legal class name.~@:>" symbol))
132 ram 1.5 (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 gerd 1.22 (or (condition-type-p symbol) (structure-type-p symbol))
140     (ensure-non-standard-class symbol))
141 ram 1.5 (cond ((null errorp) nil)
142     ((legal-class-name-p symbol)
143 gerd 1.22 (error "No class named ~S." symbol))
144 ram 1.5 (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 gerd 1.22 (symbolp x))
154 ram 1.5
155     (defun find-class (symbol &optional (errorp t) environment)
156 pw 1.13 "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 ram 1.5 (declare (ignore environment))
160 gerd 1.22 (find-class-from-cell symbol (find-class-cell symbol t) errorp))
161 ram 1.5
162     (defun find-class-predicate (symbol &optional (errorp t) environment)
163     (declare (ignore environment))
164 phg 1.6 (find-class-predicate-from-cell
165     symbol (find-class-cell symbol errorp) errorp))
166 ram 1.5
167 pw 1.7 (defvar *boot-state* nil) ; duplicate defvar to defs.lisp
168    
169 gerd 1.22 ;;;
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 pw 1.7 (declare (ignore environment))
179     (if (and (constantp symbol)
180     (legal-class-name-p (eval symbol))
181     (constantp errorp)
182 gerd 1.22 (member *boot-state* '(braid complete))
183     (not (intersection '(:loadable-pcl :bootable-pcl) *features*)))
184 pw 1.7 (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 gerd 1.23 (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 phg 1.6 (setf (find-class-cell-class cell) new-value)
201 gerd 1.23 (when (and (eq *boot-state* 'complete) (null new-value))
202     (setf (kernel::find-class name) nil))
203     (when (memq *boot-state* '(complete braid))
204 pw 1.8 (when (and new-value (class-wrapper new-value))
205     (setf (find-class-cell-predicate cell)
206 gerd 1.22 (fdefinition (class-predicate-name new-value))))
207 gerd 1.23 (update-ctors 'setf-find-class :class new-value :name name))
208 pw 1.8 new-value)
209 gerd 1.23 (error "~S is not a legal class name." name)))
210 ram 1.5
211 dtc 1.11 (defun (setf find-class-predicate) (new-value symbol)
212 ram 1.5 (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 ram 1.3 (defmacro function-funcall (form &rest args)
217 pw 1.14 `(funcall (the function ,form) ,@args))
218 ram 1.3
219     (defmacro function-apply (form &rest args)
220 pw 1.14 `(apply (the function ,form) ,@args))
221 ram 1.3
222    
223     (defsetf slot-value set-slot-value)
224 gerd 1.22
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 gerd 1.27 (declare (ignore args)))
243 ram 1.4

  ViewVC Help
Powered by ViewVC 1.1.5