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

Contents of /src/pcl/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5