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

Contents of /src/code/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.113.10.6 - (hide annotations)
Sat Feb 13 17:10:09 2010 UTC (4 years, 2 months ago) by rtoy
Branch: intl-branch
CVS Tags: intl-branch-working-2010-02-19-1000
Changes since 1.113.10.5: +7 -13 lines
Oops.  The restart-case :reports only have a stream parameter.
1 ram 1.1 ;;; -*- Log: code.log; Package: Lisp -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.20 ;;; This code was written as part of the CMU Common Lisp project at
5     ;;; Carnegie Mellon University, and has been placed in the public domain.
6     ;;;
7     (ext:file-comment
8 rtoy 1.113.10.6 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/macros.lisp,v 1.113.10.6 2010/02/13 17:10:09 rtoy Exp $")
9 ram 1.20 ;;;
10 ram 1.1 ;;; **********************************************************************
11     ;;;
12     ;;; This file contains the macros that are part of the standard
13     ;;; Spice Lisp environment.
14     ;;;
15     ;;; Written by Scott Fahlman and Rob MacLachlan.
16 ram 1.22 ;;; Modified by Bill Chiles to adhere to the wall.
17 ram 1.1 ;;;
18 wlott 1.10 (in-package "LISP")
19 rtoy 1.113.10.1 (intl:textdomain "cmucl")
20    
21 wlott 1.13 (export '(defvar defparameter defconstant when unless setf
22 ram 1.39 defsetf psetf shiftf rotatef push pushnew pop
23 ram 1.1 incf decf remf case typecase with-open-file
24     with-open-stream with-input-from-string with-output-to-string
25     locally etypecase ctypecase ecase ccase
26 ram 1.39 get-setf-expansion define-setf-expander
27 ram 1.18 define-modify-macro destructuring-bind nth-value
28 wlott 1.33 otherwise ; Sacred to CASE and related macros.
29 pw 1.67 define-compiler-macro))
30 ram 1.1
31     (in-package "EXTENSIONS")
32     (export '(do-anonymous collect iterate))
33    
34     (in-package "LISP")
35    
36    
37     ;;; Parse-Body -- Public
38     ;;;
39     ;;; Parse out declarations and doc strings, *not* expanding macros.
40     ;;; Eventually the environment arg should be flushed, since macros can't expand
41     ;;; into declarations anymore.
42     ;;;
43     (defun parse-body (body environment &optional (doc-string-allowed t))
44 rtoy 1.113.10.3 _N"This function is to parse the declarations and doc-string out of the body of
45 ram 1.1 a defun-like form. Body is the list of stuff which is to be parsed.
46     Environment is ignored. If Doc-String-Allowed is true, then a doc string
47     will be parsed out of the body and returned. If it is false then a string
48     will terminate the search for declarations. Three values are returned: the
49     tail of Body after the declarations and doc strings, a list of declare forms,
50     and the doc-string, or NIL if none."
51     (declare (ignore environment))
52     (let ((decls ())
53     (doc nil))
54     (do ((tail body (cdr tail)))
55     ((endp tail)
56     (values tail (nreverse decls) doc))
57     (let ((form (car tail)))
58     (cond ((and (stringp form) (cdr tail))
59     (if doc-string-allowed
60 pw 1.70 (setq doc form
61     ;; Only one doc string is allowed.
62     doc-string-allowed nil)
63 ram 1.1 (return (values tail (nreverse decls) doc))))
64     ((not (and (consp form) (symbolp (car form))))
65     (return (values tail (nreverse decls) doc)))
66     ((eq (car form) 'declare)
67     (push form decls))
68     (t
69     (return (values tail (nreverse decls) doc))))))))
70    
71    
72     ;;;; DEFMACRO:
73    
74     ;;; Defmacro -- Public
75     ;;;
76     ;;; Parse the definition and make an expander function. The actual
77     ;;; definition is done by %defmacro which we expand into.
78     ;;;
79     (defmacro defmacro (name lambda-list &body body)
80 gerd 1.94 (when lisp::*enable-package-locked-errors*
81 emarsden 1.93 (multiple-value-bind (valid block-name)
82     (ext:valid-function-name-p name)
83     (declare (ignore valid))
84     (let ((package (symbol-package block-name)))
85     (when package
86     (when (ext:package-definition-lock package)
87     (restart-case
88 gerd 1.94 (error 'lisp::package-locked-error
89 emarsden 1.93 :package package
90 rtoy 1.113.10.3 :format-control _"defining macro ~A"
91 emarsden 1.93 :format-arguments (list name))
92     (continue ()
93 rtoy 1.113.10.6 :report (lambda (stream)
94 rtoy 1.113.10.5 (write-string _"Ignore the lock and continue" stream)))
95 emarsden 1.93 (unlock-package ()
96 rtoy 1.113.10.6 :report (lambda (stream)
97 rtoy 1.113.10.5 (write-string _"Disable the package's definition-lock then continue" stream))
98 emarsden 1.97 (setf (ext:package-definition-lock package) nil))
99     (unlock-all ()
100 rtoy 1.113.10.6 :report (lambda (stream)
101 rtoy 1.113.10.5 (write-string _"Unlock all packages, then continue" stream))
102 emarsden 1.97 (lisp::unlock-all-packages))))))))
103 wlott 1.13 (let ((whole (gensym "WHOLE-"))
104     (environment (gensym "ENV-")))
105 ram 1.1 (multiple-value-bind
106     (body local-decs doc)
107 wlott 1.13 (parse-defmacro lambda-list whole body name 'defmacro
108     :environment environment)
109 ram 1.1 (let ((def `(lambda (,whole ,environment)
110     ,@local-decs
111     (block ,name
112     ,body))))
113 pw 1.69 `(progn
114     (eval-when (:compile-toplevel)
115     (c::do-macro-compile-time ',name #',def))
116     (eval-when (:load-toplevel :execute)
117     (c::%defmacro ',name #',def ',lambda-list ,doc)))))))
118 ram 1.1
119    
120     ;;; %Defmacro, %%Defmacro -- Internal
121     ;;;
122     ;;; Defmacro expands into %Defmacro which is a function that is treated
123     ;;; magically the compiler. After the compiler has gotten the information it
124     ;;; wants out of macro definition, it compiles a call to %%Defmacro which
125     ;;; happens at load time. We have a %Defmacro function which just calls
126     ;;; %%Defmacro in order to keep the interpreter happy.
127     ;;;
128     ;;; Eventually %%Defmacro should deal with clearing old compiler information
129     ;;; for the functional value.
130     ;;;
131     (defun c::%defmacro (name definition lambda-list doc)
132 wlott 1.13 (assert (eval:interpreted-function-p definition))
133 emarsden 1.93 (setf (eval:interpreted-function-name definition) name)
134 wlott 1.13 (setf (eval:interpreted-function-arglist definition) lambda-list)
135 ram 1.1 (c::%%defmacro name definition doc))
136     ;;;
137     (defun c::%%defmacro (name definition doc)
138     (clear-info function where-from name)
139 wlott 1.10 (setf (macro-function name) definition)
140 ram 1.1 (setf (documentation name 'function) doc)
141     name)
142 wlott 1.33
143    
144    
145     ;;;; DEFINE-COMPILER-MACRO
146    
147     (defmacro define-compiler-macro (name lambda-list &body body)
148 rtoy 1.113.10.3 _N"Define a compiler-macro for NAME."
149 wlott 1.33 (let ((whole (gensym "WHOLE-"))
150     (environment (gensym "ENV-")))
151     (multiple-value-bind
152     (body local-decs doc)
153     (parse-defmacro lambda-list whole body name 'define-compiler-macro
154     :environment environment)
155     (let ((def `(lambda (,whole ,environment)
156     ,@local-decs
157     (block ,name
158     ,body))))
159 pw 1.69 `(progn
160     (eval-when (:compile-toplevel)
161     (c::do-compiler-macro-compile-time ',name #',def))
162     (eval-when (:load-toplevel :execute)
163     (c::%define-compiler-macro ',name #',def ',lambda-list ,doc)))))))
164    
165 wlott 1.33
166     (defun c::%define-compiler-macro (name definition lambda-list doc)
167     (assert (eval:interpreted-function-p definition))
168     (setf (eval:interpreted-function-name definition)
169     (let ((*print-case* :upcase))
170     (format nil "DEFINE-COMPILER-MACRO ~S" name)))
171     (setf (eval:interpreted-function-arglist definition) lambda-list)
172     (c::%%define-compiler-macro name definition doc))
173     ;;;
174     (defun c::%%define-compiler-macro (name definition doc)
175     (setf (compiler-macro-function name) definition)
176     (setf (documentation name 'compiler-macro) doc)
177     name)
178    
179 ram 1.1
180 dtc 1.63
181     ;;;; DEFINE-SYMBOL-MACRO
182    
183     ;;; define-symbol-macro -- Public
184     ;;;
185     (defmacro define-symbol-macro (name expansion)
186 toy 1.85 `(eval-when (:compile-toplevel :load-toplevel :execute)
187 dtc 1.63 (%define-symbol-macro ',name ',expansion)))
188     ;;;
189     (defun %define-symbol-macro (name expansion)
190     (unless (symbolp name)
191     (error 'simple-type-error :datum name :expected-type 'symbol
192 rtoy 1.113.10.3 :format-control _"Symbol macro name is not a symbol: ~S."
193 dtc 1.63 :format-arguments (list name)))
194     (ecase (info variable kind name)
195     ((:macro :global nil)
196     (setf (info variable kind name) :macro)
197     (setf (info variable macro-expansion name) expansion))
198     (:special
199     (error 'simple-program-error
200 rtoy 1.113.10.3 :format-control _"Symbol macro name already declared special: ~S."
201 dtc 1.63 :format-arguments (list name)))
202     (:constant
203     (error 'simple-program-error
204 rtoy 1.113.10.3 :format-control _"Symbol macro name already declared constant: ~S."
205 dtc 1.63 :format-arguments (list name))))
206     name)
207    
208 ram 1.1
209     ;;; DEFTYPE is a lot like DEFMACRO.
210    
211     (defmacro deftype (name arglist &body body)
212 rtoy 1.113.10.3 _N"Syntax like DEFMACRO, but defines a new type."
213 ram 1.1 (unless (symbolp name)
214 rtoy 1.113.10.3 (simple-program-error _"~S -- Type name not a symbol." name))
215 gerd 1.94 (and lisp::*enable-package-locked-errors*
216 emarsden 1.93 (symbol-package name)
217     (ext:package-definition-lock (symbol-package name))
218     (restart-case
219 gerd 1.94 (error 'lisp::package-locked-error
220 emarsden 1.93 :package (symbol-package name)
221 rtoy 1.113.10.3 :format-control _"defining type ~A"
222 emarsden 1.93 :format-arguments (list name))
223     (continue ()
224 rtoy 1.113.10.6 :report (lambda (stream)
225 rtoy 1.113.10.5 (write-string _"Ignore the lock and continue" stream)))
226 emarsden 1.93 (unlock-package ()
227 rtoy 1.113.10.6 :report (lambda (stream)
228 rtoy 1.113.10.5 (write-string _"Disable package's definition-lock then continue" stream))
229 emarsden 1.97 (setf (ext:package-definition-lock (symbol-package name)) nil))
230     (unlock-all ()
231 rtoy 1.113.10.6 :report (lambda (stream)
232 rtoy 1.113.10.5 (write-string _"Unlock all packages, then continue" stream))
233 emarsden 1.97 (lisp::unlock-all-packages))))
234 wlott 1.13 (let ((whole (gensym "WHOLE-")))
235 ram 1.1 (multiple-value-bind (body local-decs doc)
236 wlott 1.13 (parse-defmacro arglist whole body name 'deftype
237     :default-default ''*)
238 toy 1.85 `(eval-when (:compile-toplevel :load-toplevel :execute)
239 wlott 1.13 (%deftype ',name
240     #'(lambda (,whole)
241     ,@local-decs
242     (block ,name ,body))
243     ,@(when doc `(,doc)))))))
244 ram 1.7 ;;;
245     (defun %deftype (name expander &optional doc)
246 rtoy 1.107 (when (info declaration recognized name)
247 rtoy 1.113.10.3 (error _"Deftype already names a declaration: ~S." name))
248 ram 1.12 (ecase (info type kind name)
249     (:primitive
250 ram 1.36 (when *type-system-initialized*
251 rtoy 1.113.10.3 (error _"Illegal to redefine standard type: ~S." name)))
252 ram 1.36 (:instance
253 rtoy 1.113.10.3 (warn _"Redefining class ~S to be a DEFTYPE." name)
254 gerd 1.91 (undefine-structure (layout-info (%class-layout (kernel::find-class name))))
255 ram 1.43 (setf (class-cell-class (find-class-cell name)) nil)
256 ram 1.36 (setf (info type compiler-layout name) nil)
257     (setf (info type kind name) :defined))
258     (:defined)
259     ((nil)
260     (setf (info type kind name) :defined)))
261    
262 wlott 1.13 (setf (info type expander name) expander)
263 ram 1.7 (when doc
264     (setf (documentation name 'type) doc))
265 wlott 1.10 ;; ### Bootstrap hack -- we need to define types before %note-type-defined
266     ;; is defined.
267 ram 1.12 (when (fboundp 'c::%note-type-defined)
268 wlott 1.10 (c::%note-type-defined name))
269 ram 1.7 name)
270    
271 ram 1.1
272 ram 1.39 ;;; And so is DEFINE-SETF-EXPANDER.
273 ram 1.1
274 rtoy 1.113.10.3 (defparameter defsetf-error-string _N"Setf expander for ~S cannot be called with ~S args.")
275 ram 1.1
276 ram 1.39 (defmacro define-setf-expander (access-fn lambda-list &body body)
277 rtoy 1.113.10.3 _N"Syntax like DEFMACRO, but creates a Setf-Expansion generator. The body
278 ram 1.1 must be a form that returns the five magical values."
279     (unless (symbolp access-fn)
280 rtoy 1.113.10.3 (simple-program-error _"~S -- Access-function name not a symbol in DEFINE-SETF-EXPANDER."
281 ram 1.1 access-fn))
282    
283 wlott 1.13 (let ((whole (gensym "WHOLE-"))
284     (environment (gensym "ENV-")))
285 ram 1.1 (multiple-value-bind (body local-decs doc)
286     (parse-defmacro lambda-list whole body access-fn
287 dtc 1.58 'define-setf-expander
288 wlott 1.13 :environment environment)
289 toy 1.85 `(eval-when (:compile-toplevel :load-toplevel :execute)
290 ram 1.22 (%define-setf-macro
291     ',access-fn
292     #'(lambda (,whole ,environment)
293     ,@local-decs
294     (block ,access-fn ,body))
295     nil
296     ',doc)))))
297 ram 1.1
298 ram 1.39 (defmacro define-setf-method (&rest stuff)
299 rtoy 1.113.10.3 _N"Obsolete, use define-setf-expander."
300 ram 1.39 `(define-setf-expander ,@stuff))
301 ram 1.22
302 ram 1.39
303 ram 1.22 ;;; %DEFINE-SETF-MACRO -- Internal
304     ;;;
305     ;;; Do stuff for defining a setf macro.
306     ;;;
307     (defun %define-setf-macro (name expander inverse doc)
308     (cond ((not (fboundp `(setf ,name))))
309     ((info function accessor-for name)
310 rtoy 1.113.10.3 (warn _"Defining setf macro for destruct slot accessor; redefining as ~
311 ram 1.22 a normal function:~% ~S"
312     name)
313     (c::define-function-name name))
314     ((not (eq (symbol-package name) (symbol-package 'aref)))
315 rtoy 1.113.10.3 (warn _"Defining setf macro for ~S, but ~S is fbound."
316 ram 1.22 name `(setf ,name))))
317     (when (or inverse (info setf inverse name))
318     (setf (info setf inverse name) inverse))
319     (when (or expander (info setf expander name))
320     (setf (info setf expander name) expander))
321     (when doc
322     (setf (documentation name 'setf) doc))
323     name)
324    
325 wlott 1.13
326     ;;;; Destructuring-bind
327 ram 1.1
328 wlott 1.13 (defmacro destructuring-bind (lambda-list arg-list &rest body)
329 rtoy 1.113.10.3 _N"Bind the variables in LAMBDA-LIST to the contents of ARG-LIST."
330 wlott 1.13 (let* ((arg-list-name (gensym "ARG-LIST-")))
331     (multiple-value-bind
332 wlott 1.14 (body local-decls)
333 wlott 1.17 (parse-defmacro lambda-list arg-list-name body nil 'destructuring-bind
334 wlott 1.13 :annonymousp t :doc-string-allowed nil)
335     `(let ((,arg-list-name ,arg-list))
336 wlott 1.14 ,@local-decls
337 wlott 1.13 ,body))))
338    
339 ram 1.1
340     ;;;; Defun, Defvar, Defparameter, Defconstant:
341    
342     ;;; Defun -- Public
343     ;;;
344     ;;; Very similar to Defmacro, but simpler. We don't have to parse the
345     ;;; lambda-list.
346     ;;;
347 gerd 1.92 (defmacro defun (&whole source name lambda-list &parse-body (body decls doc))
348 gerd 1.86 (multiple-value-bind (valid block-name)
349     (valid-function-name-p name)
350 emarsden 1.90 (declare (ignore valid))
351 gerd 1.86 (let ((def `(lambda ,lambda-list
352     ,@decls
353     (block ,block-name ,@body))))
354     `(c::%defun ',name #',def ,doc ',source))))
355 ram 1.1
356    
357     ;;; %Defun, %%Defun -- Internal
358     ;;;
359     ;;; Similar to %Defmacro, ...
360     ;;;
361     (defun c::%%defun (name def doc &optional inline-expansion)
362     (setf (fdefinition name) def)
363     (when doc
364     (if (and (consp name) (eq (first name) 'setf))
365     (setf (documentation (second name) 'setf) doc)
366     (setf (documentation name 'function) doc)))
367 ram 1.12 (c::define-function-name name)
368     (when (eq (info function where-from name) :assumed)
369     (setf (info function where-from name) :defined)
370     (when (info function assumed-type name)
371     (setf (info function assumed-type name) nil)))
372 ram 1.1 (when (or inline-expansion
373     (info function inline-expansion name))
374     (setf (info function inline-expansion name) inline-expansion))
375     name)
376 gerd 1.95
377 ram 1.1 (defun c::%defun (name def doc source)
378     (declare (ignore source))
379 ram 1.3 (assert (eval:interpreted-function-p def))
380     (setf (eval:interpreted-function-name def) name)
381 gerd 1.95 (let ((inline-expansion nil))
382     (when (memq (info function inlinep name) '(:inline :maybe-inline))
383     (multiple-value-bind (lambda-expression closure-p)
384     (function-lambda-expression def)
385     (unless closure-p
386     (setq inline-expansion lambda-expression))))
387     (c::%%defun name def doc inline-expansion)))
388 ram 1.1
389     ;;; DEFCONSTANT -- Public
390     ;;;
391     (defmacro defconstant (var val &optional doc)
392 rtoy 1.113.10.3 _N"For defining global constants at top level. The DEFCONSTANT says that the
393 ram 1.1 value is constant and may be compiled into code. If the variable already has
394     a value, and this is not equal to the init, an error is signalled. The third
395     argument is an optional documentation string for the variable."
396 moore 1.72 `(progn
397     (eval-when (:compile-toplevel)
398     (c::do-defconstant-compile-time ',var ,val ',doc))
399     (eval-when (:load-toplevel :execute)
400 rtoy 1.99 (c::%%defconstant ',var ,val ',doc (c::source-location)))))
401    
402     (defun set-defvar-source-location (name source-location)
403     (setf (info :source-location :defvar name) source-location))
404 ram 1.1
405     ;;; %Defconstant, %%Defconstant -- Internal
406     ;;;
407     ;;; Like the other %mumbles except that we currently actually do something
408     ;;; interesting at load time, namely checking if the constant is being
409     ;;; redefined.
410     ;;;
411     (defun c::%defconstant (name value doc)
412 rtoy 1.99 (c::%%defconstant name value doc nil))
413 ram 1.1 ;;;
414 rtoy 1.99 (defun c::%%defconstant (name value doc source-location)
415 ram 1.1 (when doc
416     (setf (documentation name 'variable) doc))
417     (when (boundp name)
418     (unless (equalp (symbol-value name) value)
419 rtoy 1.113.10.3 (cerror _"Go ahead and change the value."
420     _"Constant ~S being redefined." name)))
421 ram 1.1 (setf (symbol-value name) value)
422     (setf (info variable kind name) :constant)
423     (clear-info variable constant-value name)
424 rtoy 1.99 (set-defvar-source-location name source-location)
425 ram 1.1 name)
426    
427    
428     (defmacro defvar (var &optional (val nil valp) (doc nil docp))
429 rtoy 1.113.10.3 _N"For defining global variables at top level. Declares the variable
430 ram 1.1 SPECIAL and, optionally, initializes it. If the variable already has a
431     value, the old value is not clobbered. The third argument is an optional
432     documentation string for the variable."
433     `(progn
434 pw 1.66 (declaim (special ,var))
435 ram 1.1 ,@(when valp
436     `((unless (boundp ',var)
437     (setq ,var ,val))))
438     ,@(when docp
439 rtoy 1.113.10.2 `((setf (documentation ',var 'variable) ',doc)
440     (eval-when (:load-toplevel :execute)
441     (setf (c::info variable textdomain ',var) ,intl::*default-domain*))))
442 rtoy 1.99 (set-defvar-source-location ',var (c::source-location))
443 ram 1.1 ',var))
444    
445     (defmacro defparameter (var val &optional (doc nil docp))
446 rtoy 1.113.10.3 _N"Defines a parameter that is not normally changed by the program,
447 ram 1.1 but that may be changed without causing an error. Declares the
448     variable special and sets its value to VAL. The third argument is
449     an optional documentation string for the parameter."
450     `(progn
451 pw 1.66 (declaim (special ,var))
452 ram 1.1 (setq ,var ,val)
453     ,@(when docp
454 rtoy 1.113.10.2 `((setf (documentation ',var 'variable) ',doc)
455     (eval-when (:load-toplevel :execute)
456     (setf (c::info variable textdomain ',var) ,intl::*default-domain*))))
457 rtoy 1.99 (set-defvar-source-location ',var (c::source-location))
458 ram 1.1 ',var))
459    
460    
461     ;;;; ASSORTED CONTROL STRUCTURES
462    
463    
464     (defmacro when (test &body forms)
465 rtoy 1.113.10.3 _N"First arg is a predicate. If it is non-null, the rest of the forms are
466 ram 1.1 evaluated as a PROGN."
467     `(cond (,test nil ,@forms)))
468    
469     (defmacro unless (test &rest forms)
470 rtoy 1.113.10.3 _N"First arg is a predicate. If it is null, the rest of the forms are
471 ram 1.1 evaluated as a PROGN."
472     `(cond ((not ,test) nil ,@forms)))
473    
474    
475     (defmacro return (&optional (value nil))
476     `(return-from nil ,value))
477    
478 gerd 1.92 (defmacro prog (varlist &parse-body (body decls))
479 ram 1.1 `(block nil
480     (let ,varlist
481     ,@decls
482     (tagbody ,@body))))
483    
484 gerd 1.92 (defmacro prog* (varlist &parse-body (body decls))
485 ram 1.1 `(block nil
486     (let* ,varlist
487     ,@decls
488     (tagbody ,@body))))
489    
490    
491     ;;; Prog1, Prog2 -- Public
492     ;;;
493     ;;; These just turn into a Let.
494     ;;;
495     (defmacro prog1 (result &rest body)
496     (let ((n-result (gensym)))
497     `(let ((,n-result ,result))
498     ,@body
499     ,n-result)))
500     ;;;
501     (defmacro prog2 (form1 result &rest body)
502     `(prog1 (progn ,form1 ,result) ,@body))
503    
504    
505     ;;; And, Or -- Public
506     ;;;
507     ;;; AND and OR are defined in terms of IF.
508     ;;;
509     (defmacro and (&rest forms)
510     (cond ((endp forms) t)
511     ((endp (rest forms)) (first forms))
512     (t
513     `(if ,(first forms)
514     (and ,@(rest forms))
515     nil))))
516     ;;;
517     (defmacro or (&rest forms)
518     (cond ((endp forms) nil)
519     ((endp (rest forms)) (first forms))
520     (t
521     (let ((n-result (gensym)))
522     `(let ((,n-result ,(first forms)))
523     (if ,n-result
524     ,n-result
525     (or ,@(rest forms))))))))
526    
527    
528     ;;; Cond -- Public
529     ;;;
530     ;;; COND also turns into IF.
531     ;;;
532     (defmacro cond (&rest clauses)
533     (if (endp clauses)
534     nil
535     (let ((clause (first clauses)))
536     (when (atom clause)
537 rtoy 1.113.10.3 (error _"Cond clause is not a list: ~S." clause))
538 ram 1.1 (let ((test (first clause))
539     (forms (rest clause)))
540     (if (endp forms)
541     (let ((n-result (gensym)))
542     `(let ((,n-result ,test))
543     (if ,n-result
544     ,n-result
545     (cond ,@(rest clauses)))))
546     `(if ,test
547     (progn ,@forms)
548     (cond ,@(rest clauses))))))))
549    
550    
551     ;;;; Multiple value macros:
552    
553     ;;; Multiple-Value-XXX -- Public
554     ;;;
555     ;;; All the multiple-value receiving forms are defined in terms of
556     ;;; Multiple-Value-Call.
557     ;;;
558 toy 1.83 (defmacro multiple-value-setq (varlist value-form)
559     (unless (and (listp varlist) (every #'symbolp varlist))
560 rtoy 1.113.10.3 (simple-program-error _"Varlist is not a list of symbols: ~S." varlist))
561 rtoy 1.105 (if varlist
562     `(values (setf (values ,@varlist) ,value-form))
563     `(values ,value-form)))
564 toy 1.81
565 ram 1.1 ;;;
566     (defmacro multiple-value-bind (varlist value-form &body body)
567     (unless (and (listp varlist) (every #'symbolp varlist))
568 rtoy 1.113.10.3 (simple-program-error _"Varlist is not a list of symbols: ~S." varlist))
569 ram 1.1 (if (= (length varlist) 1)
570     `(let ((,(car varlist) ,value-form))
571     ,@body)
572     (let ((ignore (gensym)))
573 rtoy 1.100 `(multiple-value-call #'(lambda (&optional ,@(mapcar #'list varlist) &rest ,ignore)
574 ram 1.1 (declare (ignore ,ignore))
575     ,@body)
576     ,value-form))))
577     ;;;
578     (defmacro multiple-value-list (value-form)
579     `(multiple-value-call #'list ,value-form))
580 ram 1.18
581    
582     (defmacro nth-value (n form)
583 rtoy 1.113.10.3 _N"Evaluates FORM and returns the Nth value (zero based). This involves no
584 ram 1.18 consing when N is a trivial constant integer."
585     (if (integerp n)
586     (let ((dummy-list nil)
587 wlott 1.30 (keeper (gensym "KEEPER-")))
588 ram 1.26 ;; We build DUMMY-LIST, a list of variables to bind to useless
589     ;; values, then we explicitly IGNORE those bindings and return
590 wlott 1.30 ;; KEEPER, the only thing we're really interested in right now.
591 ram 1.26 (dotimes (i n)
592 wlott 1.30 (push (gensym "IGNORE-") dummy-list))
593     `(multiple-value-bind (,@dummy-list ,keeper)
594 ram 1.26 ,form
595     (declare (ignore ,@dummy-list))
596 wlott 1.30 ,keeper))
597     (once-only ((n n))
598 dtc 1.62 `(case (the (values fixnum &rest t) ,n)
599 wlott 1.30 (0 (nth-value 0 ,form))
600     (1 (nth-value 1 ,form))
601     (2 (nth-value 2 ,form))
602 dtc 1.62 (T (nth (the (values fixnum &rest t) ,n)
603     (multiple-value-list ,form)))))))
604 ram 1.1
605    
606     ;;;; SETF and friends.
607    
608     ;;; Note: The expansions for SETF and friends sometimes create needless
609     ;;; LET-bindings of argument values. The compiler will remove most of
610     ;;; these spurious bindings, so SETF doesn't worry too much about creating
611     ;;; them.
612    
613     ;;; The inverse for a generalized-variable reference function is stored in
614     ;;; one of two ways:
615     ;;;
616 ram 1.38 ;;; A SETF inverse property corresponds to the short form of DEFSETF. It is
617 ram 1.1 ;;; the name of a function takes the same args as the reference form, plus a
618     ;;; new-value arg at the end.
619     ;;;
620 ram 1.38 ;;; A SETF method expander is created by the long form of DEFSETF or
621 dtc 1.58 ;;; by DEFINE-SETF-EXPANDER. It is a function that is called on the reference
622 ram 1.1 ;;; form and that produces five values: a list of temporary variables, a list
623     ;;; of value forms, a list of the single store-value form, a storing function,
624     ;;; and an accessing function.
625    
626 ram 1.39 (defun get-setf-expansion (form &optional environment)
627 rtoy 1.113.10.3 _N"Returns five values needed by the SETF machinery: a list of temporary
628 wlott 1.29 variables, a list of values with which to fill them, a list of temporaries
629     for the new values, the setting function, and the accessing function."
630 ram 1.1 (let (temp)
631     (cond ((symbolp form)
632 wlott 1.32 (multiple-value-bind
633     (expansion expanded)
634     (macroexpand-1 form environment)
635     (if expanded
636 ram 1.39 (get-setf-expansion expansion environment)
637 wlott 1.32 (let ((new-var (gensym)))
638     (values nil nil (list new-var)
639     `(setq ,form ,new-var) form)))))
640 ram 1.25 ;;
641     ;; Local functions inhibit global setf methods...
642 ram 1.22 ((and environment
643 ram 1.36 (let ((name (car form)))
644     (dolist (x (c::lexenv-functions environment) nil)
645     (when (and (eq (car x) name)
646     (not (c::defined-function-p (cdr x))))
647     (return t)))))
648 ram 1.38 (expand-or-get-setf-inverse form environment))
649 ram 1.1 ((setq temp (info setf inverse (car form)))
650 wlott 1.10 (get-setf-method-inverse form `(,temp) nil))
651 ram 1.1 ((setq temp (info setf expander (car form)))
652     (funcall temp form environment))
653     (t
654 ram 1.38 (expand-or-get-setf-inverse form environment)))))
655    
656 ram 1.39 (defun get-setf-method-multiple-value (form &optional env)
657 rtoy 1.113.10.3 _N"Obsolete: use GET-SETF-EXPANSION."
658 ram 1.39 (get-setf-expansion form env))
659 ram 1.38
660     ;;;
661     ;;; If a macro, expand one level and try again. If not, go for the
662     ;;; SETF function.
663     (defun expand-or-get-setf-inverse (form environment)
664     (multiple-value-bind
665     (expansion expanded)
666     (macroexpand-1 form environment)
667     (if expanded
668 ram 1.39 (get-setf-expansion expansion environment)
669 ram 1.38 (get-setf-method-inverse form `(funcall #'(setf ,(car form)))
670     t))))
671    
672 ram 1.1
673 wlott 1.10 (defun get-setf-method-inverse (form inverse setf-function)
674 ram 1.1 (let ((new-var (gensym))
675     (vars nil)
676     (vals nil))
677     (dolist (x (cdr form))
678     (push (gensym) vars)
679     (push x vals))
680     (setq vals (nreverse vals))
681     (values vars vals (list new-var)
682 wlott 1.10 (if setf-function
683     `(,@inverse ,new-var ,@vars)
684     `(,@inverse ,@vars ,new-var))
685 ram 1.1 `(,(car form) ,@vars))))
686    
687    
688 wlott 1.29 (defun get-setf-method (form &optional environment)
689 rtoy 1.113.10.3 _N"Obsolete: use GET-SETF-EXPANSION and handle multiple store values."
690 wlott 1.29 (multiple-value-bind
691     (temps value-forms store-vars store-form access-form)
692 ram 1.39 (get-setf-expansion form environment)
693 wlott 1.29 (when (cdr store-vars)
694 rtoy 1.113.10.3 (error _"GET-SETF-METHOD used for a form with multiple store ~
695 wlott 1.29 variables:~% ~S" form))
696     (values temps value-forms store-vars store-form access-form)))
697 ram 1.1
698 wlott 1.29
699 wlott 1.16 (defun defsetter (fn rest)
700 wlott 1.14 (let ((arglist (car rest))
701     (arglist-var (gensym "ARGS-"))
702     (new-var (car (cadr rest))))
703     (multiple-value-bind
704     (body local-decs doc)
705 wlott 1.16 (parse-defmacro arglist arglist-var (cddr rest) fn 'defsetf)
706 ram 1.1 (values
707 wlott 1.14 `(lambda (,arglist-var ,new-var)
708     ,@local-decs
709 wlott 1.16 ,body)
710 wlott 1.15 doc))))
711 ram 1.1
712    
713 wlott 1.16 (defmacro defsetf (access-fn &rest rest)
714 rtoy 1.113.10.3 _N"Associates a SETF update function or macro with the specified access
715 ram 1.1 function or macro. The format is complex. See the manual for
716     details."
717     (cond ((not (listp (car rest)))
718     `(eval-when (load compile eval)
719 ram 1.22 (%define-setf-macro ',access-fn nil ',(car rest)
720     ,(when (and (car rest) (stringp (cadr rest)))
721     `',(cadr rest)))))
722 wlott 1.29 ((and (cdr rest) (listp (cadr rest)))
723     (destructuring-bind
724     (lambda-list (&rest store-variables) &body body)
725     rest
726     (let ((arglist-var (gensym "ARGS-"))
727     (access-form-var (gensym "ACCESS-FORM-"))
728     (env-var (gensym "ENVIRONMENT-")))
729     (multiple-value-bind
730     (body local-decs doc)
731     (parse-defmacro `(,lambda-list ,@store-variables)
732     arglist-var body access-fn 'defsetf
733     :annonymousp t)
734     `(eval-when (load compile eval)
735     (%define-setf-macro
736     ',access-fn
737     #'(lambda (,access-form-var ,env-var)
738     (declare (ignore ,env-var))
739     (%defsetf ,access-form-var ,(length store-variables)
740     #'(lambda (,arglist-var)
741     ,@local-decs
742     (block ,access-fn
743     ,body))))
744     nil
745     ',doc))))))
746     (t
747 rtoy 1.113.10.3 (error _"Ill-formed DEFSETF for ~S." access-fn))))
748 ram 1.1
749 wlott 1.29 (defun %defsetf (orig-access-form num-store-vars expander)
750 wlott 1.34 (collect ((subforms) (subform-vars) (subform-exprs) (store-vars))
751     (dolist (subform (cdr orig-access-form))
752     (if (constantp subform)
753     (subforms subform)
754     (let ((var (gensym)))
755     (subforms var)
756     (subform-vars var)
757     (subform-exprs subform))))
758     (dotimes (i num-store-vars)
759     (store-vars (gensym)))
760     (values (subform-vars)
761     (subform-exprs)
762     (store-vars)
763     (funcall expander (cons (subforms) (store-vars)))
764     `(,(car orig-access-form) ,@(subforms)))))
765 wlott 1.29
766    
767 ram 1.23 ;;; SETF -- Public
768     ;;;
769     ;;; Except for atoms, we always call GET-SETF-METHOD, since it has some
770     ;;; non-trivial semantics. But when there is a setf inverse, and G-S-M uses
771     ;;; it, then we return a call to the inverse, rather than returning a hairy let
772     ;;; form. This is probably important mainly as a convenince in allowing the
773     ;;; use of setf inverses without the full interpreter.
774     ;;;
775 ram 1.1 (defmacro setf (&rest args &environment env)
776 rtoy 1.113.10.3 _N"Takes pairs of arguments like SETQ. The first is a place and the second
777 ram 1.1 is the value that is supposed to go into that place. Returns the last
778     value. The place argument may be any of the access forms for which SETF
779     knows a corresponding setting form."
780 ram 1.22 (let ((nargs (length args)))
781     (cond
782     ((= nargs 2)
783 ram 1.23 (let ((place (first args))
784     (value-form (second args)))
785     (if (atom place)
786     `(setq ,place ,value-form)
787     (multiple-value-bind (dummies vals newval setter getter)
788 ram 1.39 (get-setf-expansion place env)
789 ram 1.23 (declare (ignore getter))
790     (let ((inverse (info setf inverse (car place))))
791     (if (and inverse (eq inverse (car setter)))
792     `(,inverse ,@(cdr place) ,value-form)
793 wlott 1.29 `(let* (,@(mapcar #'list dummies vals))
794     (multiple-value-bind ,newval ,value-form
795     ,setter))))))))
796 ram 1.22 ((oddp nargs)
797 rtoy 1.113.10.3 (error _"Odd number of args to SETF."))
798 ram 1.22 (t
799     (do ((a args (cddr a)) (l nil))
800     ((null a) `(progn ,@(nreverse l)))
801     (setq l (cons (list 'setf (car a) (cadr a)) l)))))))
802 ram 1.1
803     (defmacro psetf (&rest args &environment env)
804 rtoy 1.113.10.3 _N"This is to SETF as PSETQ is to SETQ. Args are alternating place
805 ram 1.1 expressions and values to go into those places. All of the subforms and
806     values are determined, left to right, and only then are the locations
807     updated. Returns NIL."
808 wlott 1.29 (collect ((let*-bindings) (mv-bindings) (setters))
809     (do ((a args (cddr a)))
810     ((endp a))
811     (if (endp (cdr a))
812 rtoy 1.113.10.3 (simple-program-error _"Odd number of args to PSETF."))
813 wlott 1.29 (multiple-value-bind
814     (dummies vals newval setter getter)
815 ram 1.39 (get-setf-expansion (car a) env)
816 wlott 1.29 (declare (ignore getter))
817     (let*-bindings (mapcar #'list dummies vals))
818     (mv-bindings (list newval (cadr a)))
819     (setters setter)))
820     (labels ((thunk (let*-bindings mv-bindings)
821     (if let*-bindings
822     `(let* ,(car let*-bindings)
823     (multiple-value-bind ,@(car mv-bindings)
824     ,(thunk (cdr let*-bindings) (cdr mv-bindings))))
825     `(progn ,@(setters) nil))))
826     (thunk (let*-bindings) (mv-bindings)))))
827 ram 1.1
828 toy 1.73 (defmacro shiftf (&rest args &environment env)
829 rtoy 1.113.10.3 _N"One or more SETF-style place expressions, followed by a single
830 wlott 1.29 value expression. Evaluates all of the expressions in turn, then
831     assigns the value of each expression to the place on its left,
832     returning the value of the leftmost."
833 toy 1.73 (when args
834     (collect ((let*-bindings) (mv-bindings) (setters) (getters))
835     ;; The last arg isn't necessarily a place, so we have to handle
836     ;; that separately.
837     (dolist (arg (butlast args))
838     (multiple-value-bind
839     (temps subforms store-vars setter getter)
840     (get-setf-expansion arg env)
841     (loop
842     for temp in temps
843     for subform in subforms
844     do (let*-bindings `(,temp ,subform)))
845     (mv-bindings store-vars)
846     (setters setter)
847     (getters getter)))
848     ;; Handle the last arg specially here. Just put something to
849     ;; force the setter so the setter for the previous var gets set,
850     ;; and the getter is just the last arg itself.
851     (setters nil)
852     (getters (car (last args)))
853    
854     (labels ((thunk (mv-bindings getters)
855     (if mv-bindings
856     `((multiple-value-bind
857     ,(car mv-bindings)
858     ,(car getters)
859     ,@(thunk (cdr mv-bindings) (cdr getters))))
860     `(,@(butlast (setters))))))
861     `(let* ,(let*-bindings)
862     (multiple-value-bind ,(car (mv-bindings))
863     ,(car (getters))
864     ,@(thunk (mv-bindings) (cdr (getters)))
865     (values ,@(car (mv-bindings)))))))))
866 ram 1.1
867     (defmacro rotatef (&rest args &environment env)
868 rtoy 1.113.10.3 _N"Takes any number of SETF-style place expressions. Evaluates all of the
869 wlott 1.29 expressions in turn, then assigns to each place the value of the form to
870     its right. The rightmost form gets the value of the leftmost.
871     Returns NIL."
872     (when args
873     (collect ((let*-bindings) (mv-bindings) (setters) (getters))
874     (dolist (arg args)
875     (multiple-value-bind
876     (temps subforms store-vars setter getter)
877 ram 1.39 (get-setf-expansion arg env)
878 wlott 1.29 (loop
879     for temp in temps
880     for subform in subforms
881     do (let*-bindings `(,temp ,subform)))
882     (mv-bindings store-vars)
883     (setters setter)
884     (getters getter)))
885     (setters nil)
886     (getters (car (getters)))
887     (labels ((thunk (mv-bindings getters)
888     (if mv-bindings
889     `((multiple-value-bind
890     ,(car mv-bindings)
891     ,(car getters)
892     ,@(thunk (cdr mv-bindings) (cdr getters))))
893     (setters))))
894     `(let* ,(let*-bindings)
895     ,@(thunk (mv-bindings) (cdr (getters))))))))
896 ram 1.1
897    
898     (defmacro define-modify-macro (name lambda-list function &optional doc-string)
899 rtoy 1.113.10.3 _N"Creates a new read-modify-write macro like PUSH or INCF."
900 ram 1.1 (let ((other-args nil)
901     (rest-arg nil)
902 rtoy 1.110 (env (gensym "ENV-"))
903     (reference (gensym "PLACE-")))
904 ram 1.1
905     ;; Parse out the variable names and rest arg from the lambda list.
906     (do ((ll lambda-list (cdr ll))
907     (arg nil))
908     ((null ll))
909     (setq arg (car ll))
910     (cond ((eq arg '&optional))
911     ((eq arg '&rest)
912     (if (symbolp (cadr ll))
913     (setq rest-arg (cadr ll))
914 rtoy 1.113.10.3 (error _"Non-symbol &rest arg in definition of ~S." name))
915 ram 1.1 (if (null (cddr ll))
916     (return nil)
917 rtoy 1.113.10.3 (error _"Illegal stuff after &rest arg in Define-Modify-Macro.")))
918 ram 1.1 ((memq arg '(&key &allow-other-keys &aux))
919 rtoy 1.113.10.3 (error _"~S not allowed in Define-Modify-Macro lambda list." arg))
920 ram 1.1 ((symbolp arg)
921     (push arg other-args))
922     ((and (listp arg) (symbolp (car arg)))
923     (push (car arg) other-args))
924 rtoy 1.113.10.3 (t (error _"Illegal stuff in lambda list of Define-Modify-Macro."))))
925 ram 1.1 (setq other-args (nreverse other-args))
926     `(defmacro ,name (,reference ,@lambda-list &environment ,env)
927     ,doc-string
928     (multiple-value-bind (dummies vals newval setter getter)
929 wlott 1.13 (get-setf-method ,reference ,env)
930 ram 1.1 (do ((d dummies (cdr d))
931     (v vals (cdr v))
932     (let-list nil (cons (list (car d) (car v)) let-list)))
933     ((null d)
934     (push
935     (list (car newval)
936     ,(if rest-arg
937     `(list* ',function getter ,@other-args ,rest-arg)
938     `(list ',function getter ,@other-args)))
939     let-list)
940     `(let* ,(nreverse let-list)
941     ,setter)))))))
942    
943     (defmacro push (obj place &environment env)
944 rtoy 1.113.10.3 _N"Takes an object and a location holding a list. Conses the object onto
945 pw 1.56 the list, returning the modified list. OBJ is evaluated before PLACE."
946 toy 1.78
947     ;; This special case for place being a symbol isn't strictly needed.
948     ;; It's so we can do push (and pushnew) with a kernel.core.
949 toy 1.77 (if (and (symbolp place)
950     (eq place (macroexpand place env)))
951     `(setq ,place (cons ,obj ,place))
952     (multiple-value-bind (dummies vals newval setter getter)
953     (get-setf-expansion place env)
954 toy 1.79 (cond
955     ((cdr newval)
956     ;; Handle multiple values
957     (let ((g (mapcar #'(lambda (x)
958     (declare (ignore x))
959     (gensym))
960     (rest obj))))
961     `(multiple-value-bind ,g
962     ,obj
963     (let* (,@(mapcar #'list dummies vals))
964     (multiple-value-bind ,newval
965     (values ,@(mapcar #'(lambda (a b)
966     (list 'cons a b))
967     g (rest getter)))
968     ,setter)))))
969     (t
970     ;; A single value
971     (let ((g (gensym)))
972     `(let* ((,g ,obj)
973     ,@(mapcar #'list dummies vals)
974     (,@newval (cons ,g ,getter)))
975     ,setter)))))))
976 ram 1.1
977     (defmacro pushnew (obj place &rest keys &environment env)
978 rtoy 1.113.10.3 _N"Takes an object and a location holding a list. If the object is already
979 ram 1.1 in the list, does nothing. Else, conses the object onto the list. Returns
980     NIL. If there is a :TEST keyword, this is used for the comparison."
981 toy 1.77 (if (and (symbolp place)
982     (eq place (macroexpand place env)))
983     `(setq ,place (adjoin ,obj ,place ,@keys))
984     (multiple-value-bind (vars vals stores setter getter)
985 toy 1.78 (get-setf-expansion place env)
986 toy 1.79 (cond
987     ((cdr stores)
988     ;; Multiple values
989     (let ((g (mapcar #'(lambda (x)
990     (declare (ignore x))
991     (gensym))
992     (rest obj))))
993     `(multiple-value-bind ,g
994     ,obj
995     (let* (,@(mapcar #'list vars vals))
996     (multiple-value-bind ,stores
997     (values ,@(mapcar #'(lambda (a b)
998     `(adjoin ,a ,b ,@keys))
999     g (rest getter)))
1000     ,setter)))))
1001     (t
1002     ;; Single value
1003     (let ((g (gensym)))
1004     `(let* ((,g ,obj)
1005     ,@(mapcar #'list vars vals)
1006     (,@stores (adjoin ,g ,getter ,@keys)))
1007     ,setter)))))))
1008 ram 1.1
1009     (defmacro pop (place &environment env)
1010 rtoy 1.113.10.3 _N"The argument is a location holding a list. Pops one item off the front
1011 ram 1.1 of the list and returns it."
1012 toy 1.77 (if (and (symbolp place)
1013     (eq place (macroexpand place env)))
1014     `(prog1 (car ,place)
1015     (setq ,place (cdr ,place)))
1016     (multiple-value-bind (dummies vals newval setter getter)
1017     (get-setf-method place env)
1018     (do* ((d dummies (cdr d))
1019     (v vals (cdr v))
1020     (let-list nil))
1021     ((null d)
1022     (push (list (car newval) getter) let-list)
1023     `(let* ,(nreverse let-list)
1024     (prog1 (car ,(car newval))
1025     (setq ,(car newval) (cdr ,(car newval)))
1026     ,setter)))
1027     (push (list (car d) (car v)) let-list)))))
1028 ram 1.1
1029    
1030 rtoy 1.103 ;;; we can't use DEFINE-MODIFY-MACRO because of ANSI 5.1.3
1031     (defmacro incf (place &optional (delta 1) &environment env)
1032 rtoy 1.113.10.3 _N"The first argument is some location holding a number. This number is
1033 rtoy 1.103 incremented by the second argument, DELTA, which defaults to 1."
1034     (multiple-value-bind (dummies vals newval setter getter)
1035     (get-setf-method place env)
1036     (let ((d (gensym)))
1037     `(let* (,@(mapcar #'list dummies vals)
1038     (,d ,delta)
1039     (,(car newval) (+ ,getter ,d)))
1040     ,setter))))
1041    
1042     (defmacro decf (place &optional (delta 1) &environment env)
1043 rtoy 1.113.10.3 _N"The first argument is some location holding a number. This number is
1044 rtoy 1.103 decremented by the second argument, DELTA, which defaults to 1."
1045     (multiple-value-bind (dummies vals newval setter getter)
1046     (get-setf-method place env)
1047     (let ((d (gensym)))
1048     `(let* (,@(mapcar #'list dummies vals)
1049     (,d ,delta)
1050     (,(car newval) (- ,getter ,d)))
1051     ,setter))))
1052 ram 1.1
1053     (defmacro remf (place indicator &environment env)
1054 rtoy 1.113.10.3 _N"Place may be any place expression acceptable to SETF, and is expected
1055 ram 1.1 to hold a property list or (). This list is destructively altered to
1056     remove the property specified by the indicator. Returns T if such a
1057     property was present, NIL if not."
1058     (multiple-value-bind (dummies vals newval setter getter)
1059 wlott 1.13 (get-setf-method place env)
1060 ram 1.1 (do* ((d dummies (cdr d))
1061     (v vals (cdr v))
1062     (let-list nil)
1063     (ind-temp (gensym))
1064     (local1 (gensym))
1065     (local2 (gensym)))
1066     ((null d)
1067 rtoy 1.103 ;; See ANSI 5.1.3 for why we do out-of-order evaluation
1068     (push (list ind-temp indicator) let-list)
1069 ram 1.1 (push (list (car newval) getter) let-list)
1070     `(let* ,(nreverse let-list)
1071     (do ((,local1 ,(car newval) (cddr ,local1))
1072     (,local2 nil ,local1))
1073     ((atom ,local1) nil)
1074     (cond ((atom (cdr ,local1))
1075 rtoy 1.113.10.3 (error _"Odd-length property list in REMF."))
1076 ram 1.1 ((eq (car ,local1) ,ind-temp)
1077     (cond (,local2
1078     (rplacd (cdr ,local2) (cddr ,local1))
1079     (return t))
1080     (t (setq ,(car newval) (cddr ,(car newval)))
1081     ,setter
1082     (return t))))))))
1083     (push (list (car d) (car v)) let-list))))
1084    
1085    
1086     ;;; The built-in DEFSETFs.
1087    
1088     (defsetf car %rplaca)
1089     (defsetf cdr %rplacd)
1090     (defsetf caar (x) (v) `(%rplaca (car ,x) ,v))
1091     (defsetf cadr (x) (v) `(%rplaca (cdr ,x) ,v))
1092     (defsetf cdar (x) (v) `(%rplacd (car ,x) ,v))
1093     (defsetf cddr (x) (v) `(%rplacd (cdr ,x) ,v))
1094     (defsetf caaar (x) (v) `(%rplaca (caar ,x) ,v))
1095     (defsetf cadar (x) (v) `(%rplaca (cdar ,x) ,v))
1096     (defsetf cdaar (x) (v) `(%rplacd (caar ,x) ,v))
1097     (defsetf cddar (x) (v) `(%rplacd (cdar ,x) ,v))
1098     (defsetf caadr (x) (v) `(%rplaca (cadr ,x) ,v))
1099     (defsetf caddr (x) (v) `(%rplaca (cddr ,x) ,v))
1100     (defsetf cdadr (x) (v) `(%rplacd (cadr ,x) ,v))
1101     (defsetf cdddr (x) (v) `(%rplacd (cddr ,x) ,v))
1102     (defsetf caaaar (x) (v) `(%rplaca (caaar ,x) ,v))
1103     (defsetf cadaar (x) (v) `(%rplaca (cdaar ,x) ,v))
1104     (defsetf cdaaar (x) (v) `(%rplacd (caaar ,x) ,v))
1105     (defsetf cddaar (x) (v) `(%rplacd (cdaar ,x) ,v))
1106     (defsetf caadar (x) (v) `(%rplaca (cadar ,x) ,v))
1107     (defsetf caddar (x) (v) `(%rplaca (cddar ,x) ,v))
1108     (defsetf cdadar (x) (v) `(%rplacd (cadar ,x) ,v))
1109     (defsetf cdddar (x) (v) `(%rplacd (cddar ,x) ,v))
1110     (defsetf caaadr (x) (v) `(%rplaca (caadr ,x) ,v))
1111     (defsetf cadadr (x) (v) `(%rplaca (cdadr ,x) ,v))
1112     (defsetf cdaadr (x) (v) `(%rplacd (caadr ,x) ,v))
1113     (defsetf cddadr (x) (v) `(%rplacd (cdadr ,x) ,v))
1114     (defsetf caaddr (x) (v) `(%rplaca (caddr ,x) ,v))
1115     (defsetf cadddr (x) (v) `(%rplaca (cdddr ,x) ,v))
1116     (defsetf cdaddr (x) (v) `(%rplacd (caddr ,x) ,v))
1117     (defsetf cddddr (x) (v) `(%rplacd (cdddr ,x) ,v))
1118    
1119     (defsetf first %rplaca)
1120     (defsetf second (x) (v) `(%rplaca (cdr ,x) ,v))
1121     (defsetf third (x) (v) `(%rplaca (cddr ,x) ,v))
1122     (defsetf fourth (x) (v) `(%rplaca (cdddr ,x) ,v))
1123     (defsetf fifth (x) (v) `(%rplaca (cddddr ,x) ,v))
1124     (defsetf sixth (x) (v) `(%rplaca (cdr (cddddr ,x)) ,v))
1125     (defsetf seventh (x) (v) `(%rplaca (cddr (cddddr ,x)) ,v))
1126     (defsetf eighth (x) (v) `(%rplaca (cdddr (cddddr ,x)) ,v))
1127     (defsetf ninth (x) (v) `(%rplaca (cddddr (cddddr ,x)) ,v))
1128     (defsetf tenth (x) (v) `(%rplaca (cdr (cddddr (cddddr ,x))) ,v))
1129     (defsetf rest %rplacd)
1130    
1131     (defsetf elt %setelt)
1132     (defsetf aref %aset)
1133 wlott 1.10 (defsetf row-major-aref %set-row-major-aref)
1134 ram 1.1 (defsetf svref %svset)
1135     (defsetf char %charset)
1136     (defsetf bit %bitset)
1137     (defsetf schar %scharset)
1138     (defsetf sbit %sbitset)
1139 wlott 1.10 (defsetf %array-dimension %set-array-dimension)
1140     (defsetf %raw-bits %set-raw-bits)
1141 ram 1.1 (defsetf symbol-value set)
1142 wlott 1.28 (defsetf symbol-function fset)
1143     (defsetf symbol-plist %set-symbol-plist)
1144 ram 1.1 (defsetf nth %setnth)
1145     (defsetf fill-pointer %set-fill-pointer)
1146     (defsetf search-list %set-search-list)
1147    
1148 wlott 1.10 (defsetf sap-ref-8 %set-sap-ref-8)
1149 wlott 1.27 (defsetf signed-sap-ref-8 %set-signed-sap-ref-8)
1150 wlott 1.10 (defsetf sap-ref-16 %set-sap-ref-16)
1151 wlott 1.27 (defsetf signed-sap-ref-16 %set-signed-sap-ref-16)
1152 wlott 1.10 (defsetf sap-ref-32 %set-sap-ref-32)
1153 wlott 1.27 (defsetf signed-sap-ref-32 %set-signed-sap-ref-32)
1154 hallgren 1.44 (defsetf sap-ref-64 %set-sap-ref-64)
1155     (defsetf signed-sap-ref-64 %set-signed-sap-ref-64)
1156 wlott 1.10 (defsetf sap-ref-sap %set-sap-ref-sap)
1157     (defsetf sap-ref-single %set-sap-ref-single)
1158     (defsetf sap-ref-double %set-sap-ref-double)
1159 cshapiro 1.111 #+(or x86 long-float)
1160 dtc 1.54 (defsetf sap-ref-long %set-sap-ref-long)
1161 ram 1.1
1162 dtc 1.58 (define-setf-expander getf (place prop &optional default &environment env)
1163 ram 1.1 (multiple-value-bind (temps values stores set get)
1164 wlott 1.13 (get-setf-method place env)
1165 ram 1.1 (let ((newval (gensym))
1166     (ptemp (gensym))
1167 wlott 1.31 (def-temp (if default (gensym))))
1168     (values `(,@temps ,ptemp ,@(if default `(,def-temp)))
1169     `(,@values ,prop ,@(if default `(,default)))
1170 ram 1.1 `(,newval)
1171 wlott 1.31 `(let ((,(car stores) (%putf ,get ,ptemp ,newval)))
1172     ,set
1173     ,newval)
1174     `(getf ,get ,ptemp ,@(if default `(,def-temp)))))))
1175 ram 1.1
1176 dtc 1.58 (define-setf-expander get (symbol prop &optional default)
1177 ram 1.1 (let ((symbol-temp (gensym))
1178     (prop-temp (gensym))
1179     (def-temp (gensym))
1180     (newval (gensym)))
1181     (values `(,symbol-temp ,prop-temp ,@(if default `(,def-temp)))
1182     `(,symbol ,prop ,@(if default `(,default)))
1183     (list newval)
1184     `(%put ,symbol-temp ,prop-temp ,newval)
1185     `(get ,symbol-temp ,prop-temp ,@(if default `(,def-temp))))))
1186    
1187 dtc 1.58 (define-setf-expander gethash (key hashtable &optional default)
1188 ram 1.1 (let ((key-temp (gensym))
1189     (hashtable-temp (gensym))
1190     (default-temp (gensym))
1191     (new-value-temp (gensym)))
1192     (values
1193     `(,key-temp ,hashtable-temp ,@(if default `(,default-temp)))
1194     `(,key ,hashtable ,@(if default `(,default)))
1195     `(,new-value-temp)
1196     `(%puthash ,key-temp ,hashtable-temp ,new-value-temp)
1197     `(gethash ,key-temp ,hashtable-temp ,@(if default `(,default-temp))))))
1198    
1199     (defsetf subseq (sequence start &optional (end nil)) (v)
1200     `(progn (replace ,sequence ,v :start1 ,start :end1 ,end)
1201     ,v))
1202    
1203    
1204 ram 1.36 ;;; Evil hack invented by the gnomes of Vassar Street (though not as evil as
1205     ;;; it used to be.) The function arg must be constant, and is converted to an
1206     ;;; APPLY of ther SETF function, which ought to exist.
1207 ram 1.22 ;;;
1208 dtc 1.58 (define-setf-expander apply (function &rest args)
1209 ram 1.22 (unless (and (listp function)
1210     (= (list-length function) 2)
1211     (eq (first function) 'function)
1212     (symbolp (second function)))
1213 rtoy 1.113.10.3 (error _"Setf of Apply is only defined for function args like #'symbol."))
1214 ram 1.36 (let ((function (second function))
1215     (new-var (gensym))
1216     (vars nil))
1217     (dolist (x args)
1218     (declare (ignore x))
1219     (push (gensym) vars))
1220     (values vars args (list new-var)
1221     `(apply #'(setf ,function) ,new-var ,@vars)
1222     `(apply #',function ,@vars))))
1223 ram 1.1
1224    
1225 wlott 1.10 ;;; Special-case a BYTE bytespec so that the compiler can recognize it.
1226     ;;;
1227 dtc 1.58 (define-setf-expander ldb (bytespec place &environment env)
1228 rtoy 1.113.10.3 _N"The first argument is a byte specifier. The second is any place form
1229 ram 1.1 acceptable to SETF. Replaces the specified byte of the number in this
1230     place with bits from the low-order end of the new value."
1231     (multiple-value-bind (dummies vals newval setter getter)
1232 wlott 1.13 (get-setf-method place env)
1233 wlott 1.10 (if (and (consp bytespec) (eq (car bytespec) 'byte))
1234     (let ((n-size (gensym))
1235     (n-pos (gensym))
1236     (n-new (gensym)))
1237     (values (list* n-size n-pos dummies)
1238     (list* (second bytespec) (third bytespec) vals)
1239     (list n-new)
1240     `(let ((,(car newval) (dpb ,n-new (byte ,n-size ,n-pos)
1241     ,getter)))
1242     ,setter
1243     ,n-new)
1244     `(ldb (byte ,n-size ,n-pos) ,getter)))
1245     (let ((btemp (gensym))
1246     (gnuval (gensym)))
1247     (values (cons btemp dummies)
1248     (cons bytespec vals)
1249     (list gnuval)
1250     `(let ((,(car newval) (dpb ,gnuval ,btemp ,getter)))
1251     ,setter
1252     ,gnuval)
1253     `(ldb ,btemp ,getter))))))
1254 ram 1.1
1255    
1256 dtc 1.58 (define-setf-expander mask-field (bytespec place &environment env)
1257 rtoy 1.113.10.3 _N"The first argument is a byte specifier. The second is any place form
1258 ram 1.1 acceptable to SETF. Replaces the specified byte of the number in this place
1259     with bits from the corresponding position in the new value."
1260     (multiple-value-bind (dummies vals newval setter getter)
1261 wlott 1.13 (get-setf-method place env)
1262 ram 1.1 (let ((btemp (gensym))
1263     (gnuval (gensym)))
1264     (values (cons btemp dummies)
1265     (cons bytespec vals)
1266     (list gnuval)
1267     `(let ((,(car newval) (deposit-field ,gnuval ,btemp ,getter)))
1268     ,setter
1269     ,gnuval)
1270     `(mask-field ,btemp ,getter)))))
1271    
1272    
1273 dtc 1.58 (define-setf-expander the (type place &environment env)
1274 ram 1.1 (multiple-value-bind (dummies vals newval setter getter)
1275 wlott 1.13 (get-setf-method place env)
1276 ram 1.1 (values dummies
1277     vals
1278     newval
1279     (subst `(the ,type ,(car newval)) (car newval) setter)
1280     `(the ,type ,getter))))
1281 dtc 1.58
1282     (define-setf-expander values (&rest places &environment env)
1283     (collect ((setters) (getters))
1284     (let ((all-dummies '())
1285     (all-vals '())
1286     (newvals '()))
1287     (dolist (place places)
1288     (multiple-value-bind (dummies vals newval setter getter)
1289     (get-setf-expansion place env)
1290 rtoy 1.101 ;; ANSI CL 5.1.2.3 explains that extra places are set to
1291     ;; nil.
1292     (setf all-dummies (append all-dummies dummies (cdr newval)))
1293     (setf all-vals (append all-vals vals
1294     (mapcar (constantly nil) (cdr newval))))
1295     (setf newvals (append newvals (list (car newval))))
1296 dtc 1.58 (setters setter)
1297     (getters getter)))
1298     (values all-dummies all-vals newvals
1299     `(values ,@(setters)) `(values ,@(getters))))))
1300 ram 1.1
1301    
1302     ;;;; CASE, TYPECASE, & Friends.
1303    
1304 toy 1.85 (eval-when (:compile-toplevel :load-toplevel :execute)
1305 ram 1.1
1306     ;;; CASE-BODY returns code for all the standard "case" macros. Name is the
1307     ;;; macro name, and keyform is the thing to case on. Multi-p indicates whether
1308     ;;; a branch may fire off a list of keys; otherwise, a key that is a list is
1309     ;;; interpreted in some way as a single key. When multi-p, test is applied to
1310     ;;; the value of keyform and each key for a given branch; otherwise, test is
1311     ;;; applied to the value of keyform and the entire first element, instead of
1312     ;;; each part, of the case branch. When errorp, no t or otherwise branch is
1313     ;;; permitted, and an ERROR form is generated. When proceedp, it is an error
1314     ;;; to omit errorp, and the ERROR form generated is executed within a
1315     ;;; RESTART-CASE allowing keyform to be set and retested.
1316     ;;;
1317 toy 1.74 ;;; If ALLOW-OTHERWISE, then we allow T and OTHERWISE clauses and also
1318     ;;; generate an ERROR form. (This is for CCASE and ECASE which allow
1319     ;;; using T and OTHERWISE as regular keys.)
1320     ;;;
1321     (defun case-body (name keyform cases multi-p test errorp proceedp &optional allow-otherwise)
1322 ram 1.1 (let ((keyform-value (gensym))
1323     (clauses ())
1324     (keys ()))
1325 toy 1.88 (do* ((case-list cases (cdr case-list))
1326     (case (first case-list) (first case-list)))
1327     ((null case-list))
1328 ram 1.1 (cond ((atom case)
1329 rtoy 1.113.10.3 (error _"~S -- Bad clause in ~S." case name))
1330 toy 1.74 ((and (not allow-otherwise)
1331 toy 1.88 (memq (car case) '(t otherwise)))
1332 rtoy 1.98 (cond ((null (cdr case-list))
1333     ;; The CLHS says OTHERWISE clause is an OTHERWISE clause
1334     ;; only if it's the last case. Otherwise, it's just a
1335     ;; normal clause.
1336     (if errorp
1337 rtoy 1.113.10.3 (error _"No default clause allowed in ~S: ~S" name case)
1338 rtoy 1.98 (push `(t nil ,@(rest case)) clauses)))
1339     ((and (eq name 'case))
1340 rtoy 1.113.10.3 (error _"T and OTHERWISE may not be used as key designators for ~A" name))
1341 rtoy 1.102 ((eq (first case) t)
1342     ;; The key T is normal clause, because it's not
1343     ;; the last clause.
1344     (push (first case) keys)
1345     (push `((,test ,keyform-value
1346     ',(first case)) nil ,@(rest case)) clauses))))
1347 ram 1.1 ((and multi-p (listp (first case)))
1348     (setf keys (append (first case) keys))
1349     (push `((or ,@(mapcar #'(lambda (key)
1350     `(,test ,keyform-value ',key))
1351     (first case)))
1352     nil ,@(rest case))
1353     clauses))
1354     (t
1355 toy 1.74 (when (and allow-otherwise
1356     (memq (car case) '(t otherwise)))
1357 rtoy 1.113.10.3 (warn _"Bad style to use T or OTHERWISE in ECASE or CCASE"))
1358 ram 1.1 (push (first case) keys)
1359     (push `((,test ,keyform-value
1360     ',(first case)) nil ,@(rest case)) clauses))))
1361     (case-body-aux name keyform keyform-value clauses keys errorp proceedp
1362 toy 1.74 allow-otherwise
1363 ram 1.1 `(,(if multi-p 'member 'or) ,@keys))))
1364    
1365     ;;; CASE-BODY-AUX provides the expansion once CASE-BODY has groveled all the
1366     ;;; cases. Note: it is not necessary that the resulting code signal
1367     ;;; case-failure conditions, but that's what KMP's prototype code did. We call
1368     ;;; CASE-BODY-ERROR, because of how closures are compiled. RESTART-CASE has
1369     ;;; forms with closures that the compiler causes to be generated at the top of
1370     ;;; any function using the case macros, regardless of whether they are needed.
1371     ;;;
1372     (defun case-body-aux (name keyform keyform-value clauses keys
1373 toy 1.74 errorp proceedp allow-otherwise expected-type)
1374 ram 1.1 (if proceedp
1375     (let ((block (gensym))
1376     (again (gensym)))
1377     `(let ((,keyform-value ,keyform))
1378     (block ,block
1379     (tagbody
1380     ,again
1381     (return-from
1382     ,block
1383     (cond ,@(nreverse clauses)
1384     (t
1385     (setf ,keyform-value
1386     (setf ,keyform
1387     (case-body-error
1388     ',name ',keyform ,keyform-value
1389     ',expected-type ',keys)))
1390     (go ,again))))))))
1391     `(let ((,keyform-value ,keyform))
1392 pw 1.49 ,keyform-value ; prevent warnings when key not used eg (case key (t))
1393 ram 1.1 (cond
1394     ,@(nreverse clauses)
1395 toy 1.74 ,@(if (or errorp allow-otherwise)
1396 ram 1.1 `((t (error 'conditions::case-failure
1397     :name ',name
1398     :datum ,keyform-value
1399     :expected-type ',expected-type
1400     :possibilities ',keys))))))))
1401    
1402     ); eval-when
1403    
1404     (defun case-body-error (name keyform keyform-value expected-type keys)
1405     (restart-case
1406     (error 'conditions::case-failure
1407     :name name
1408     :datum keyform-value
1409     :expected-type expected-type
1410     :possibilities keys)
1411     (store-value (value)
1412     :report (lambda (stream)
1413 rtoy 1.113.10.3 (format stream _"Supply a new value for ~S." keyform))
1414 ram 1.1 :interactive read-evaluated-form
1415     value)))
1416    
1417    
1418     (defmacro case (keyform &body cases)
1419 rtoy 1.113.10.3 _N"CASE Keyform {({(Key*) | Key} Form*)}*
1420 rtoy 1.113 Evaluates the Forms in the first clause with a Key EQL to the value
1421     of Keyform. If a singleton key is T or Otherwise then the clause is
1422     a default clause."
1423 ram 1.1 (case-body 'case keyform cases t 'eql nil nil))
1424    
1425     (defmacro ccase (keyform &body cases)
1426 rtoy 1.113.10.3 _N"CCASE Keyform {({(Key*) | Key} Form*)}*
1427 ram 1.1 Evaluates the Forms in the first clause with a Key EQL to the value of
1428     Keyform. If none of the keys matches then a correctable error is
1429     signalled."
1430 toy 1.74 (case-body 'ccase keyform cases t 'eql nil t t))
1431 ram 1.1
1432     (defmacro ecase (keyform &body cases)
1433 rtoy 1.113.10.3 _N"ECASE Keyform {({(Key*) | Key} Form*)}*
1434 ram 1.1 Evaluates the Forms in the first clause with a Key EQL to the value of
1435     Keyform. If none of the keys matches then an error is signalled."
1436 toy 1.74 (case-body 'ecase keyform cases t 'eql nil nil t))
1437 ram 1.1
1438     (defmacro typecase (keyform &body cases)
1439 rtoy 1.113.10.3 _N"TYPECASE Keyform {(Type Form*)}*
1440 rtoy 1.113 Evaluates the Forms in the first clause for which TYPEP of Keyform
1441     and Type is true. If a singleton key is T or Otherwise then the
1442     clause is a default clause."
1443 ram 1.1 (case-body 'typecase keyform cases nil 'typep nil nil))
1444    
1445     (defmacro ctypecase (keyform &body cases)
1446 rtoy 1.113.10.3 _N"CTYPECASE Keyform {(Type Form*)}*
1447 ram 1.1 Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
1448     is true. If no form is satisfied then a correctable error is signalled."
1449 toy 1.75 (case-body 'ctypecase keyform cases nil 'typep nil t t))
1450 ram 1.1
1451     (defmacro etypecase (keyform &body cases)
1452 rtoy 1.113.10.3 _N"ETYPECASE Keyform {(Type Form*)}*
1453 ram 1.1 Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
1454     is true. If no form is satisfied then an error is signalled."
1455 toy 1.75 (case-body 'etypecase keyform cases nil 'typep nil nil t))
1456 ram 1.1
1457    
1458     ;;;; ASSERT and CHECK-TYPE.
1459    
1460     ;;; ASSERT is written this way, to call ASSERT-ERROR, because of how closures
1461     ;;; are compiled. RESTART-CASE has forms with closures that the compiler
1462     ;;; causes to be generated at the top of any function using ASSERT, regardless
1463     ;;; of whether they are needed.
1464     ;;;
1465     (defmacro assert (test-form &optional places datum &rest arguments)
1466 rtoy 1.113.10.3 _N"Signals an error if the value of test-form is nil. Continuing from this
1467 ram 1.1 error using the CONTINUE restart will allow the user to alter the value of
1468     some locations known to SETF, starting over with test-form. Returns nil."
1469     `(loop
1470     (when ,test-form (return nil))
1471     (assert-error ',test-form ',places ,datum ,@arguments)
1472     ,@(mapcar #'(lambda (place)
1473     `(setf ,place (assert-prompt ',place ,place)))
1474     places)))
1475    
1476 ram 1.42 (defun assert-error (assertion places datum &rest arguments)
1477 ram 1.41 (let ((cond (if datum
1478     (conditions::coerce-to-condition
1479     datum arguments
1480     'simple-error 'error)
1481     (make-condition 'simple-error
1482 rtoy 1.113.10.3 :format-control _"The assertion ~S failed."
1483 ram 1.41 :format-arguments (list assertion)))))
1484     (restart-case (error cond)
1485 ram 1.1 (continue ()
1486     :report (lambda (stream) (assert-report places stream))
1487 ram 1.41 nil))))
1488 ram 1.1
1489    
1490     (defun assert-report (names stream)
1491 rtoy 1.113.10.3 (format stream _"Retry assertion")
1492 ram 1.1 (if names
1493 rtoy 1.113.10.3 (format stream _" with new value~P for ~{~S~^, ~}."
1494 ram 1.1 (length names) names)
1495     (format stream ".")))
1496    
1497     (defun assert-prompt (name value)
1498 rtoy 1.113.10.3 (cond ((y-or-n-p _"The old value of ~S is ~S.~
1499 ram 1.1 ~%Do you want to supply a new value? "
1500     name value)
1501 rtoy 1.113.10.3 (format *query-io* _"~&Type a form to be evaluated:~%")
1502 ram 1.1 (flet ((read-it () (eval (read *query-io*))))
1503     (if (symbolp name) ;help user debug lexical variables
1504     (progv (list name) (list value) (read-it))
1505     (read-it))))
1506     (t value)))
1507    
1508    
1509     ;;; CHECK-TYPE is written this way, to call CHECK-TYPE-ERROR, because of how
1510     ;;; closures are compiled. RESTART-CASE has forms with closures that the
1511     ;;; compiler causes to be generated at the top of any function using
1512     ;;; CHECK-TYPE, regardless of whether they are needed. Because it would be
1513     ;;; nice if this were cheap to use, and some things can't afford this excessive
1514     ;;; consing (e.g., READ-CHAR), we bend backwards a little.
1515     ;;;
1516    
1517     (defmacro check-type (place type &optional type-string)
1518 rtoy 1.113.10.3 _N"Signals an error of type type-error if the contents of place are not of the
1519 ram 1.1 specified type. If an error is signaled, this can only return if
1520     STORE-VALUE is invoked. It will store into place and start over."
1521     (let ((place-value (gensym)))
1522     `(loop
1523     (let ((,place-value ,place))
1524     (when (typep ,place-value ',type) (return nil))
1525     (setf ,place
1526     (check-type-error ',place ,place-value ',type ,type-string))))))
1527    
1528     (defun check-type-error (place place-value type type-string)
1529 ram 1.41 (let ((cond (if type-string
1530     (make-condition 'simple-type-error
1531 rtoy 1.104 :datum place-value :expected-type type
1532 ram 1.41 :format-control
1533 rtoy 1.113.10.3 _"The value of ~S is ~S, which is not ~A."
1534 ram 1.41 :format-arguments
1535     (list place place-value type-string))
1536     (make-condition 'simple-type-error
1537 rtoy 1.104 :datum place-value :expected-type type
1538 ram 1.41 :format-control
1539 rtoy 1.113.10.3 _"The value of ~S is ~S, which is not of type ~S."
1540 ram 1.41 :format-arguments
1541     (list place place-value type)))))
1542     (restart-case (error cond)
1543     (store-value (value)
1544     :report (lambda (stream)
1545 rtoy 1.113.10.3 (format stream _"Supply a new value of ~S."
1546 ram 1.41 place))
1547     :interactive read-evaluated-form
1548     value))))
1549 ram 1.1
1550     ;;; READ-EVALUATED-FORM is used as the interactive method for restart cases
1551     ;;; setup by the Common Lisp "casing" (e.g., CCASE and CTYPECASE) macros
1552     ;;; and by CHECK-TYPE.
1553     ;;;
1554     (defun read-evaluated-form ()
1555 rtoy 1.113.10.3 (format *query-io* _"~&Type a form to be evaluated:~%")
1556 ram 1.1 (list (eval (read *query-io*))))
1557    
1558    
1559     ;;;; With-XXX
1560 rtoy 1.112 (defmacro with-open-file ((var filespec &rest open-args) &parse-body (forms decls))
1561 rtoy 1.113.10.3 _N"The file whose name is Filespec is opened using the Open-args and
1562 rtoy 1.112 bound to the variable Var. If the call to open is unsuccessful, the
1563     forms are not evaluated. The Forms are executed, and when they
1564     terminate, normally or otherwise, the file is closed."
1565 ram 1.1 (let ((abortp (gensym)))
1566 rtoy 1.112 `(let ((,var (open ,filespec ,@open-args))
1567 ram 1.1 (,abortp t))
1568     ,@decls
1569 pw 1.47 (unwind-protect
1570 rtoy 1.112 (multiple-value-prog1
1571     (progn ,@forms)
1572     (setq ,abortp nil))
1573 pw 1.47 (when ,var
1574 ram 1.1 (close ,var :abort ,abortp))))))
1575    
1576 ram 1.5
1577 gerd 1.92 (defmacro with-open-stream ((var stream) &parse-body (forms decls))
1578 rtoy 1.113.10.3 _N"The form stream should evaluate to a stream. VAR is bound
1579 ram 1.1 to the stream and the forms are evaluated as an implicit
1580     progn. The stream is closed upon exit."
1581     (let ((abortp (gensym)))
1582     `(let ((,var ,stream)
1583     (,abortp t))
1584     ,@decls
1585     (unwind-protect
1586     (multiple-value-prog1
1587 rtoy 1.112 (progn ,@forms)
1588 ram 1.1 (setq ,abortp nil))
1589     (when ,var
1590     (close ,var :abort ,abortp))))))
1591    
1592    
1593 gerd 1.92 (defmacro with-input-from-string ((var string &key index start end)
1594     &parse-body (forms decls))
1595 rtoy 1.113.10.3 _N"Binds the Var to an input stream that returns characters from String and
1596 ram 1.1 executes the body. See manual for details."
1597 pw 1.52 ;; The once-only inhibits compiler note for unreachable code when 'end' is true.
1598     (once-only ((string string))
1599     `(let ((,var
1600     ,(cond ((null end)
1601     `(make-string-input-stream ,string ,(or start 0)))
1602     ((symbolp end)
1603     `(if ,end
1604     (make-string-input-stream ,string ,(or start 0) ,end)
1605     (make-string-input-stream ,string ,(or start 0))))
1606     (t
1607     `(make-string-input-stream ,string ,(or start 0) ,end)))))
1608     ,@decls
1609     (unwind-protect
1610 rtoy 1.106 (multiple-value-prog1
1611     (progn ,@forms)
1612     ,@(when index
1613     `((setf ,index (string-input-stream-current ,var)))))
1614     (close ,var)))))
1615 ram 1.1
1616    
1617 gerd 1.96 (defmacro with-output-to-string ((var &optional string &key element-type)
1618 gerd 1.92 &parse-body (forms decls))
1619 rtoy 1.113.10.3 _N"If STRING is specified, it must be a string with a fill pointer;
1620 ram 1.5 the output is incrementally appended to the string (as if by use of
1621     VECTOR-PUSH-EXTEND)."
1622 gerd 1.96 (declare (ignore element-type))
1623 ram 1.1 (if string
1624     `(let ((,var (make-fill-pointer-output-stream ,string)))
1625     ,@decls
1626     (unwind-protect
1627     (progn ,@forms)
1628     (close ,var)))
1629     `(let ((,var (make-string-output-stream)))
1630     ,@decls
1631     (unwind-protect
1632     (progn ,@forms)
1633     (close ,var))
1634     (get-output-stream-string ,var))))
1635    
1636    
1637     ;;;; Iteration macros:
1638    
1639 rtoy 1.109 ;; Helper for dotimes. Extract any declarations for the dotimes
1640     ;; counter and create a similar declaration for our dummy loop
1641     ;; counter. Skip over special declarations, though, because we don't
1642     ;; want to make the dummy counter special.
1643     ;;
1644     ;; Returns two values:
1645     ;; 1. Set of declarations for the dotimes loop counter that would be
1646     ;; suitable for use in the result-form of the loop,
1647     ;; 2. Declarations suitable for the dummy loop counter.
1648     (defun dotimes-extract-var-decls (var counter count decls)
1649     (let (var-decls counter-decls)
1650     (dolist (decl decls)
1651     (dolist (d (cdr decl))
1652     (when (member var (cdr d))
1653     (cond ((eq (car d) 'type)
1654     (push `(type ,(second d) ,var) var-decls)
1655     (push `(type ,(second d) ,counter) counter-decls))
1656     ((eq (car d) 'special)
1657     ;; Declare var special, but not the counter
1658     (push `(,(car d) ,var) var-decls))
1659     (t
1660     (push `(,(car d) ,var) var-decls)
1661     (push `(,(car d) ,counter) counter-decls))))))
1662     (unless counter-decls
1663     (setf counter-decls (if (numberp count)
1664     `((type (integer 0 ,count) ,counter))
1665     `((type unsigned-byte ,counter)))))
1666     (values (if var-decls
1667     `((declare ,@(nreverse var-decls)))
1668     nil)
1669     `((declare ,@(nreverse counter-decls))))))
1670    
1671    
1672 rtoy 1.108 ;;; Make sure we iterate the given number of times, independent of
1673     ;;; what the body might do to the index variable. We do this by
1674     ;;; repeatedly binding the var in the body and also in the result
1675     ;;; form. We also spuriously reference the var in case the body or
1676     ;;; result form don't reference the var either. (Mostly modeled on
1677     ;;; the dolist macro below.)
1678 ram 1.1 (defmacro dotimes ((var count &optional (result nil)) &body body)
1679 rtoy 1.108 (let ((count-var (gensym "CTR-")))
1680     (multiple-value-bind (forms decls)
1681     (parse-body body nil nil)
1682 rtoy 1.109 (multiple-value-bind (var-decls ctr-decls)
1683     (dotimes-extract-var-decls var count-var count decls)
1684     (cond ((numberp count)
1685     `(do ((,count-var 0 (1+ ,count-var)))
1686     ((>= ,count-var ,count)
1687     (let ((,var ,count-var))
1688     ,@var-decls
1689     ,var
1690     ,result))
1691     ,@ctr-decls
1692     (let ((,var ,count-var))
1693     ,@decls
1694     ,var
1695     (tagbody
1696     ,@forms))))
1697     (t (let ((v1 (gensym)))
1698     `(do ((,count-var 0 (1+ ,count-var))
1699     (,v1 ,count))
1700     ((>= ,count-var ,v1)
1701     (let ((,var ,count-var))
1702     ,@var-decls
1703     ,var
1704     ,result))
1705     ,@ctr-decls
1706     (let ((,var ,count-var))
1707     ,@decls
1708     ,var
1709     (tagbody
1710     ,@forms))))))))))
1711 ram 1.1
1712    
1713     ;;; We repeatedly bind the var instead of setting it so that we never give the
1714     ;;; var a random value such as NIL (which might conflict with a declaration).
1715 ram 1.35 ;;; If there is a result form, we introduce a gratitous binding of the variable
1716     ;;; to NIL w/o the declarations, then evaluate the result form in that
1717     ;;; environment. We spuriously reference the gratuitous variable, since we
1718     ;;; don't want to use IGNORABLE on what might be a special var.
1719 ram 1.1 ;;;
1720     (defmacro dolist ((var list &optional (result nil)) &body body)
1721 toy 1.80 (multiple-value-bind (forms decls)
1722     (parse-body body nil nil)
1723     (let ((n-list (gensym)))
1724     `(do* ((,n-list ,list (cdr ,n-list)))
1725 gerd 1.89 ((endp ,n-list)
1726     ,@(if (constantp result)
1727     `(,result)
1728     `((let ((,var nil))
1729     ,@decls
1730     ,var
1731     ,result))))
1732 toy 1.80 (let ((,var (car ,n-list)))
1733     ,@decls
1734     (tagbody
1735     ,@forms))))))
1736 ram 1.1
1737    
1738 gerd 1.92 (defmacro do (varlist endlist &parse-body (body decls))
1739 rtoy 1.113.10.3 _N"DO ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
1740 ram 1.1 Iteration construct. Each Var is initialized in parallel to the value of the
1741     specified Init form. On subsequent iterations, the Vars are assigned the
1742     value of the Step form (if any) in paralell. The Test is evaluated before
1743 dtc 1.53 each evaluation of the body Forms. When the Test is true, the Exit-Forms
1744 ram 1.1 are evaluated as a PROGN, with the result being the value of the DO. A block
1745     named NIL is established around the entire expansion, allowing RETURN to be
1746     used as an laternate exit mechanism."
1747    
1748     (do-do-body varlist endlist body decls 'let 'psetq 'do nil))
1749    
1750    
1751 gerd 1.92 (defmacro do* (varlist endlist &parse-body (body decls))
1752 rtoy 1.113.10.3 _N"DO* ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
1753 ram 1.1 Iteration construct. Each Var is initialized sequentially (like LET*) to the
1754     value of the specified Init form. On subsequent iterations, the Vars are
1755     sequentially assigned the value of the Step form (if any). The Test is
1756     evaluated before each evaluation of the body Forms. When the Test is true,
1757 dtc 1.53 the Exit-Forms are evaluated as a PROGN, with the result being the value
1758 ram 1.1 of the DO. A block named NIL is established around the entire expansion,
1759     allowing RETURN to be used as an laternate exit mechanism."
1760     (do-do-body varlist endlist body decls 'let* 'setq 'do* nil))
1761    
1762    
1763     ;;;; Miscellaneous macros:
1764    
1765     (defmacro psetq (&rest pairs)
1766 rtoy 1.113.10.3 _N"PSETQ {var value}*
1767 toy 1.84 Set the variables to the values, like SETQ, except that assignments
1768     happen in parallel, i.e. no assignments take place until all the
1769     forms have been evaluated."
1770     ;; Given the possibility of symbol-macros, we delegate to PSETF
1771     ;; which knows how to deal with them, after checking that syntax is
1772     ;; compatible with PSETQ.
1773     (do ((pair pairs (cddr pair)))
1774     ((endp pair) `(psetf ,@pairs))
1775     (unless (symbolp (car pair))
1776     (error 'simple-program-error
1777 rtoy 1.113.10.3 :format-control _"variable ~S in PSETQ is not a SYMBOL"
1778 toy 1.84 :format-arguments (list (car pair))))))
1779    
1780 pw 1.48
1781     ;;; LAMBDA -- from the ANSI spec.
1782     ;;;
1783     (defmacro lambda (&whole form &rest bvl-decls-and-body)
1784     (declare (ignore bvl-decls-and-body))
1785     `#',form)
1786    
1787 ram 1.1
1788    
1789     ;;;; With-Compilation-Unit:
1790    
1791 toy 1.85 ;;; True if we are within a WITH-COMPILATION-UNIT form, which normally causes
1792 ram 1.1 ;;; nested uses to be NOOPS.
1793     ;;;
1794     (defvar *in-compilation-unit* nil)
1795    
1796     ;;; Count of the number of compilation units dynamically enclosed by the
1797     ;;; current active WITH-COMPILATION-UNIT that were unwound out of.
1798     ;;;
1799     (defvar *aborted-compilation-units*)
1800    
1801 ram 1.21 (declaim (special c::*context-declarations*))
1802    
1803    
1804     ;;; EVALUATE-DECLARATION-CONTEXT -- Internal
1805     ;;;
1806     ;;; Recursively descend the context form, returning true if this subpart
1807     ;;; matches the specified context.
1808     ;;;
1809     (defun evaluate-declaration-context (context name parent)
1810 gerd 1.87 (multiple-value-bind (valid base)
1811     (valid-function-name-p name)
1812     (let ((package (and valid (symbolp base) (symbol-package base))))
1813     (if (atom context)
1814     (multiple-value-bind (ignore how)
1815     (if package
1816     (find-symbol (symbol-name base) package)
1817     (values nil nil))
1818     (declare (ignore ignore))
1819     (case context
1820     (:internal (eq how :internal))
1821     (:external (eq how :external))
1822     (:uninterned (and (symbolp base) (not package)))
1823     (:anonymous (not name))
1824     (:macro (eq parent 'defmacro))
1825     (:function (member parent '(defun labels flet function)))
1826     (:global (member parent '(defun defmacro function)))
1827     (:local (member parent '(labels flet)))
1828     (t
1829 rtoy 1.113.10.3 (error _"Unknown declaration context: ~S." context))))
1830 gerd 1.87 (case (first context)
1831     (:or
1832     (loop for x in (rest context)
1833     thereis (evaluate-declaration-context x name parent)))
1834     (:and
1835     (loop for x in (rest context)
1836     always (evaluate-declaration-context x name parent)))
1837     (:not
1838     (evaluate-declaration-context (second context) name parent))
1839     (:member
1840     (member name (rest context) :test #'equal))
1841     (:match
1842     (let ((name (concatenate 'string "$" (string base) "$")))
1843     (loop for x in (rest context)
1844     thereis (search (string x) name))))
1845     (:package
1846     (and package
1847     (loop for x in (rest context)
1848     thereis (eq (find-package (string x)) package))))
1849 ram 1.24 (t
1850 rtoy 1.113.10.3 (error _"Unknown declaration context: ~S." context)))))))
1851 ram 1.21
1852    
1853     ;;; PROCESS-CONTEXT-DECLARATIONS -- Internal
1854     ;;;
1855     ;;; Given a list of context declaration specs, return a new value for
1856     ;;; C::*CONTEXT-DECLARATIONS*.
1857     ;;;
1858     (defun process-context-declarations (decls)
1859     (append
1860     (mapcar
1861     #'(lambda (decl)
1862     (unless (>= (length decl) 2)
1863 rtoy 1.113.10.3 (error _"Context declaration spec should have context and at ~
1864 ram 1.21 least one DECLARE form:~% ~S" decl))
1865     #'(lambda (name parent)
1866     (when (evaluate-declaration-context (first decl) name parent)
1867     (rest decl))))
1868     decls)
1869     c::*context-declarations*))
1870    
1871    
1872 ram 1.1 ;;; With-Compilation-Unit -- Public
1873     ;;;
1874     (defmacro with-compilation-unit (options &body body)
1875 rtoy 1.113.10.3 _N"WITH-COMPILATION-UNIT ({Key Value}*) Form*
1876 ram 1.21 This form affects compilations that take place within its dynamic extent. It
1877     is intended to be wrapped around the compilation of all files in the same
1878     system. These keywords are defined:
1879     :OVERRIDE Boolean-Form
1880     One of the effects of this form is to delay undefined warnings
1881     until the end of the form, instead of giving them at the end of each
1882     compilation. If OVERRIDE is NIL (the default), then the outermost
1883     WITH-COMPILATION-UNIT form grabs the undefined warnings. Specifying
1884     OVERRIDE true causes that form to grab any enclosed warnings, even if
1885     it is enclosed by another WITH-COMPILATION-UNIT.
1886     :OPTIMIZE Decl-Form
1887     Decl-Form should evaluate to an OPTIMIZE declaration specifier. This
1888     declaration changes the `global' policy for compilations within the
1889     body.
1890     :OPTIMIZE-INTERFACE Decl-Form
1891     Like OPTIMIZE, except that it specifies the value of the CMU extension
1892     OPTIMIZE-INTERFACE policy (which controls argument type and syntax
1893     checking.)
1894     :CONTEXT-DECLARATIONS List-of-Context-Decls-Form
1895     This is a CMU extension which allows compilation to be controlled
1896     by pattern matching on the context in which a definition appears. The
1897     argument should evaluate to a list of lists of the form:
1898     (Context-Spec Declare-Form+)
1899     In the indicated context, the specified declare forms are inserted at
1900     the head of each definition. The declare forms for all contexts that
1901     match are appended together, with earlier declarations getting
1902     predecence over later ones. A simple example:
1903     :context-declarations
1904     '((:external (declare (optimize (safety 2)))))
1905     This will cause all functions that are named by external symbols to be
1906     compiled with SAFETY 2. The full syntax of context specs is:
1907     :INTERNAL, :EXTERNAL
1908     True if the symbols is internal (external) in its home package.
1909     :UNINTERNED
1910     True if the symbol has no home package.
1911     :ANONYMOUS
1912     True if the function doesn't have any interesting name (not
1913     DEFMACRO, DEFUN, LABELS or FLET).
1914     :MACRO, :FUNCTION
1915     :MACRO is a global (DEFMACRO) macro. :FUNCTION is anything else.
1916     :LOCAL, :GLOBAL
1917     :LOCAL is a LABELS or FLET. :GLOBAL is anything else.
1918     (:OR Context-Spec*)
1919     True in any specified context.
1920     (:AND Context-Spec*)
1921     True only when all specs are true.
1922     (:NOT Context-Spec)
1923     True when the spec is false.
1924     (:MEMBER Name*)
1925     True when the name is one of these names (EQUAL test.)
1926     (:MATCH Pattern*)
1927     True when any of the patterns is a substring of the name. The name
1928     is wrapped with $'s, so $FOO matches names beginning with FOO,
1929     etc."
1930     (let ((override nil)
1931     (optimize nil)
1932     (optimize-interface nil)
1933     (context-declarations nil)
1934 ram 1.1 (n-fun (gensym))
1935     (n-abort-p (gensym)))
1936     (when (oddp (length options))
1937 rtoy 1.113.10.3 (error _"Odd number of key/value pairs: ~S." options))
1938 ram 1.1 (do ((opt options (cddr opt)))
1939     ((null opt))
1940     (case (first opt)
1941 ram 1.21 (:override
1942     (setq override (second opt)))
1943     (:optimize
1944     (setq optimize (second opt)))
1945     (:optimize-interface
1946     (setq optimize-interface (second opt)))
1947     (:context-declarations
1948     (setq context-declarations (second opt)))
1949 ram 1.1 (t
1950 rtoy 1.113.10.3 (warn _"Ignoring unknown option: ~S." (first opt)))))
1951 ram 1.1
1952 ram 1.21 `(flet ((,n-fun ()
1953     (let (,@(when optimize
1954     `((c::*default-cookie*
1955     (c::process-optimize-declaration
1956     ,optimize c::*default-cookie*))))
1957     ,@(when optimize-interface
1958     `((c::*default-interface-cookie*
1959     (c::process-optimize-declaration
1960     ,optimize-interface
1961     c::*default-interface-cookie*))))
1962     ,@(when context-declarations
1963     `((c::*context-declarations*
1964     (process-context-declarations
1965     ,context-declarations)))))
1966     ,@body)))
1967     (if (or ,override (not *in-compilation-unit*))
1968 ram 1.6 (let ((c::*undefined-warnings* nil)
1969 ram 1.1 (c::*compiler-error-count* 0)
1970     (c::*compiler-warning-count* 0)
1971     (c::*compiler-note-count* 0)
1972     (*in-compilation-unit* t)
1973     (*aborted-compilation-units* 0)
1974     (,n-abort-p t))
1975 ram 1.6 (handler-bind ((c::parse-unknown-type
1976     #'(lambda (c)
1977     (c::note-undefined-reference
1978 emarsden 1.97 (kernel:parse-unknown-type-specifier c)
1979 ram 1.6 :type))))
1980     (unwind-protect
1981     (multiple-value-prog1
1982     (,n-fun)
1983     (setq ,n-abort-p nil))
1984     (c::print-summary ,n-abort-p *aborted-compilation-units*))))
1985 ram 1.1 (let ((,n-abort-p t))
1986     (unwind-protect
1987     (multiple-value-prog1
1988     (,n-fun)
1989     (setq ,n-abort-p nil))
1990     (when ,n-abort-p
1991     (incf *aborted-compilation-units*))))))))

  ViewVC Help
Powered by ViewVC 1.1.5