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

Contents of /src/pcl/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.20 - (hide annotations)
Mon Aug 26 16:58:06 2002 UTC (11 years, 8 months ago) by pmai
Branch: MAIN
Changes since 1.19: +1 -50 lines
Patch by Gerd Moellmann to remove unused functionality from macros.lisp.
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 pmai 1.20 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/macros.lisp,v 1.20 2002/08/26 16:58:06 pmai 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 pw 1.15 (declaim (declaration
41     values ;;I use this so that Zwei can remind
42     ;;me what values a function returns.
43 wlott 1.1
44 pw 1.15 arglist ;;Tells me what the pretty arglist
45     ;;of something (which probably takes
46     ;;&rest args) is.
47 wlott 1.1
48 pw 1.15 indentation ;;Tells ZWEI how to indent things
49     ;;like defclass.
50     class
51     variable-rebinding
52     pcl-fast-call
53     method-name
54     method-lambda-list
55     ))
56 wlott 1.1
57     ;;; Age old functions which CommonLisp cleaned-up away. They probably exist
58     ;;; in other packages in all CommonLisp implementations, but I will leave it
59     ;;; to the compiler to optimize into calls to them.
60     ;;;
61     ;;; Common Lisp BUG:
62     ;;; Some Common Lisps define these in the Lisp package which causes
63     ;;; all sorts of lossage. Common Lisp should explictly specify which
64     ;;; symbols appear in the Lisp package.
65     ;;;
66     (eval-when (compile load eval)
67    
68     (defmacro memq (item list) `(member ,item ,list :test #'eq))
69     (defmacro assq (item list) `(assoc ,item ,list :test #'eq))
70     (defmacro rassq (item list) `(rassoc ,item ,list :test #'eq))
71     (defmacro delq (item list) `(delete ,item ,list :test #'eq))
72     (defmacro posq (item list) `(position ,item ,list :test #'eq))
73     (defmacro neq (x y) `(not (eq ,x ,y)))
74    
75     )
76    
77     (defun true (&rest ignore) (declare (ignore ignore)) t)
78     (defun false (&rest ignore) (declare (ignore ignore)) nil)
79     (defun zero (&rest ignore) (declare (ignore ignore)) 0)
80    
81 ram 1.5 (defun get-declaration (name declarations &optional default)
82     (dolist (d declarations default)
83     (dolist (form (cdr d))
84     (when (and (consp form) (eq (car form) name))
85     (return-from get-declaration (cdr form))))))
86 wlott 1.1
87 ram 1.5
88     (defvar *keyword-package* (find-package 'keyword))
89    
90 wlott 1.1 (defun make-keyword (symbol)
91     (intern (symbol-name symbol) *keyword-package*))
92    
93     (defmacro doplist ((key val) plist &body body &environment env)
94 pmai 1.19 (multiple-value-bind (bod decls doc)
95     (system:parse-body body env)
96 wlott 1.1 (declare (ignore doc))
97     `(let ((.plist-tail. ,plist) ,key ,val)
98     ,@decls
99     (loop (when (null .plist-tail.) (return nil))
100     (setq ,key (pop .plist-tail.))
101     (when (null .plist-tail.)
102     (error "Malformed plist in doplist, odd number of elements."))
103     (setq ,val (pop .plist-tail.))
104     (progn ,@bod)))))
105    
106 ram 1.3 (defmacro dolist-carefully ((var list improper-list-handler) &body body)
107     `(let ((,var nil)
108     (.dolist-carefully. ,list))
109     (loop (when (null .dolist-carefully.) (return nil))
110     (if (consp .dolist-carefully.)
111     (progn
112     (setq ,var (pop .dolist-carefully.))
113     ,@body)
114     (,improper-list-handler)))))
115 wlott 1.1
116     ;;
117     ;;;;;; printing-random-thing
118     ;;
119     ;;; Similar to printing-random-object in the lisp machine but much simpler
120     ;;; and machine independent.
121     (defmacro printing-random-thing ((thing stream) &body body)
122 pw 1.14 `(print-unreadable-object (,thing ,stream :identity t) ,@body))
123 wlott 1.1
124     (defun printing-random-thing-internal (thing stream)
125     (declare (ignore thing stream))
126     nil)
127    
128     ;;
129     ;;;;;;
130     ;;
131    
132     (defun capitalize-words (string &optional (dashes-p t))
133     (let ((string (copy-seq (string string))))
134     (declare (string string))
135     (do* ((flag t flag)
136     (length (length string) length)
137     (char nil char)
138     (i 0 (+ i 1)))
139     ((= i length) string)
140     (setq char (elt string i))
141     (cond ((both-case-p char)
142     (if flag
143     (and (setq flag (lower-case-p char))
144     (setf (elt string i) (char-upcase char)))
145     (and (not flag) (setf (elt string i) (char-downcase char))))
146     (setq flag nil))
147     ((char-equal char #\-)
148     (setq flag t)
149     (unless dashes-p (setf (elt string i) #\space)))
150     (t (setq flag nil))))))
151    
152 ram 1.5 ;;;
153     ;;; FIND-CLASS
154     ;;;
155     ;;; This is documented in the CLOS specification.
156     ;;;
157     (defvar *find-class* (make-hash-table :test #'eq))
158 wlott 1.1
159 ram 1.3 (defun function-returning-nil (x)
160     (declare (ignore x))
161     nil)
162    
163 ram 1.5 (defmacro find-class-cell-class (cell)
164     `(car ,cell))
165 ram 1.3
166 ram 1.5 (defmacro find-class-cell-predicate (cell)
167 phg 1.6 `(cadr ,cell))
168 ram 1.3
169 phg 1.6 (defmacro find-class-cell-make-instance-function-keys (cell)
170     `(cddr ,cell))
171    
172 ram 1.5 (defmacro make-find-class-cell (class-name)
173     (declare (ignore class-name))
174 phg 1.6 '(list* nil #'function-returning-nil nil))
175 ram 1.5
176     (defun find-class-cell (symbol &optional dont-create-p)
177     (or (gethash symbol *find-class*)
178     (unless dont-create-p
179     (unless (legal-class-name-p symbol)
180     (error "~S is not a legal class name." symbol))
181     (setf (gethash symbol *find-class*) (make-find-class-cell symbol)))))
182    
183     (defvar *create-classes-from-internal-structure-definitions-p* t)
184    
185     (defun find-class-from-cell (symbol cell &optional (errorp t))
186     (or (find-class-cell-class cell)
187     (and *create-classes-from-internal-structure-definitions-p*
188     (structure-type-p symbol)
189     (find-structure-class symbol))
190     (cond ((null errorp) nil)
191     ((legal-class-name-p symbol)
192     (error "No class named: ~S." symbol))
193     (t
194     (error "~S is not a legal class name." symbol)))))
195    
196     (defun find-class-predicate-from-cell (symbol cell &optional (errorp t))
197     (unless (find-class-cell-class cell)
198     (find-class-from-cell symbol cell errorp))
199     (find-class-cell-predicate cell))
200    
201     (defun legal-class-name-p (x)
202     (and (symbolp x)
203     (not (keywordp x))))
204    
205     (defun find-class (symbol &optional (errorp t) environment)
206 pw 1.13 "Returns the PCL class metaobject named by SYMBOL. An error of type
207     SIMPLE-ERROR is signaled if the class does not exist unless ERRORP
208     is NIL in which case NIL is returned. SYMBOL cannot be a keyword."
209 ram 1.5 (declare (ignore environment))
210 pw 1.13 (find-class-from-cell
211     symbol (find-class-cell symbol t) errorp))
212 ram 1.5
213     (defun find-class-predicate (symbol &optional (errorp t) environment)
214     (declare (ignore environment))
215 phg 1.6 (find-class-predicate-from-cell
216     symbol (find-class-cell symbol errorp) errorp))
217 ram 1.5
218 pw 1.7 (defvar *boot-state* nil) ; duplicate defvar to defs.lisp
219    
220     ; Use this definition in any CL implementation supporting
221     ; both define-compiler-macro and load-time-value.
222 pw 1.14 ; Note that in CMU, lisp:find-class /= pcl:find-class
223 pw 1.7 (define-compiler-macro find-class (&whole form
224     symbol &optional (errorp t) environment)
225     (declare (ignore environment))
226     (if (and (constantp symbol)
227     (legal-class-name-p (eval symbol))
228     (constantp errorp)
229     (member *boot-state* '(braid complete)))
230     (let ((symbol (eval symbol))
231     (errorp (not (null (eval errorp))))
232     (class-cell (make-symbol "CLASS-CELL")))
233     `(let ((,class-cell (load-time-value (find-class-cell ',symbol))))
234     (or (find-class-cell-class ,class-cell)
235     ,(if errorp
236     `(find-class-from-cell ',symbol ,class-cell t)
237     `(and (kernel:class-cell-class
238     ',(kernel:find-class-cell symbol))
239     (find-class-from-cell ',symbol ,class-cell nil))))))
240     form))
241    
242 dtc 1.11 (defun (setf find-class) (new-value symbol)
243 ram 1.5 (if (legal-class-name-p symbol)
244 phg 1.6 (let ((cell (find-class-cell symbol)))
245     (setf (find-class-cell-class cell) new-value)
246     (when (or (eq *boot-state* 'complete)
247     (eq *boot-state* 'braid))
248 pw 1.8 (when (and new-value (class-wrapper new-value))
249     (setf (find-class-cell-predicate cell)
250     (symbol-function (class-predicate-name new-value))))
251 phg 1.6 (when (and new-value (not (forward-referenced-class-p new-value)))
252 pw 1.7
253 phg 1.6 (dolist (keys+aok (find-class-cell-make-instance-function-keys cell))
254     (update-initialize-info-internal
255     (initialize-info new-value (car keys+aok) nil (cdr keys+aok))
256 pw 1.8 'make-instance-function))))
257     new-value)
258 ram 1.5 (error "~S is not a legal class name." symbol)))
259    
260 dtc 1.11 (defun (setf find-class-predicate) (new-value symbol)
261 ram 1.5 (if (legal-class-name-p symbol)
262     (setf (find-class-cell-predicate (find-class-cell symbol)) new-value)
263     (error "~S is not a legal class name." symbol)))
264    
265 ram 1.3 (defmacro function-funcall (form &rest args)
266 pw 1.14 `(funcall (the function ,form) ,@args))
267 ram 1.3
268     (defmacro function-apply (form &rest args)
269 pw 1.14 `(apply (the function ,form) ,@args))
270 ram 1.3
271    
272     (defsetf slot-value set-slot-value)
273    
274     (defvar *redefined-functions* nil)
275    
276     (defmacro original-definition (name)
277 pmai 1.18 `(get ,name :definition-before-pcl))
278 ram 1.3
279     (defun redefine-function (name new)
280     (pushnew name *redefined-functions*)
281     (unless (original-definition name)
282     (setf (original-definition name)
283     (symbol-function name)))
284     (setf (symbol-function name)
285     (symbol-function new)))
286 ram 1.4

  ViewVC Help
Powered by ViewVC 1.1.5