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

  ViewVC Help
Powered by ViewVC 1.1.5