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

Diff of /src/code/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.6.1.2 by wlott, Mon Jun 11 01:14:32 1990 UTC revision 1.120 by rtoy, Tue May 25 20:04:33 2010 UTC
# Line 1  Line 1 
1  ;;; -*- Log: code.log; Package: Lisp -*-  ;;; -*- Log: code.log; Package: Lisp -*-
2  ;;;  ;;;
3  ;;; **********************************************************************  ;;; **********************************************************************
4  ;;; This code was written as part of the Spice Lisp project at  ;;; 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.  ;;; Carnegie Mellon University, and has been placed in the public domain.
6  ;;; If you want to use this code or any part of Spice Lisp, please contact  ;;;
7  ;;; Scott Fahlman (FAHLMAN@CMUC).  (ext:file-comment
8  ;;; **********************************************************************    "$Header$")
9  ;;;  ;;;
10  ;;; $Header$  ;;; **********************************************************************
11  ;;;  ;;;
12  ;;; This file contains the macros that are part of the standard  ;;; This file contains the macros that are part of the standard
13  ;;; Spice Lisp environment.  ;;; Spice Lisp environment.
14  ;;;  ;;;
15  ;;; Written by Scott Fahlman and Rob MacLachlan.  ;;; Written by Scott Fahlman and Rob MacLachlan.
16  ;;; Modified by Bill Chiles to adhere to  ;;; Modified by Bill Chiles to adhere to the wall.
17  ;;;  ;;;
18  (in-package "LISP")  (in-package "LISP")
19  (export '(defvar defparameter defconstant when unless loop setf  (intl:textdomain "cmucl")
20            defsetf define-setf-method psetf shiftf rotatef push pushnew pop  
21    (export '(defvar defparameter defconstant when unless setf
22              defsetf psetf shiftf rotatef push pushnew pop
23            incf decf remf case typecase with-open-file            incf decf remf case typecase with-open-file
24            with-open-stream with-input-from-string with-output-to-string            with-open-stream with-input-from-string with-output-to-string
25            locally etypecase ctypecase ecase ccase            locally etypecase ctypecase ecase ccase
26            get-setf-method get-setf-method-multiple-value            get-setf-expansion define-setf-expander
27            define-modify-macro            define-modify-macro destructuring-bind nth-value
28            otherwise)) ; Sacred to CASE and related macros.            otherwise ; Sacred to CASE and related macros.
29              define-compiler-macro))
30    
31  (in-package "EXTENSIONS")  (in-package "EXTENSIONS")
32  (export '(do-anonymous collect iterate))  (export '(do-anonymous collect iterate))
# Line 54  Line 57 
57        (let ((form (car tail)))        (let ((form (car tail)))
58          (cond ((and (stringp form) (cdr tail))          (cond ((and (stringp form) (cdr tail))
59                 (if doc-string-allowed                 (if doc-string-allowed
60                     (setq doc form)                     (setq doc form
61                             ;; Only one doc string is allowed.
62                             doc-string-allowed nil)
63                     (return (values tail (nreverse decls) doc))))                     (return (values tail (nreverse decls) doc))))
64                ((not (and (consp form) (symbolp (car form))))                ((not (and (consp form) (symbolp (car form))))
65                 (return (values tail (nreverse decls) doc)))                 (return (values tail (nreverse decls) doc)))
# Line 66  Line 71 
71    
72  ;;;; DEFMACRO:  ;;;; DEFMACRO:
73    
 #-new-compiler  
 (proclaim '(special *in-compilation-unit*))  
   
 (defparameter defmacro-error-string "Macro ~S cannot be called with ~S args.")  
   
74  ;;; Defmacro  --  Public  ;;; Defmacro  --  Public
75  ;;;  ;;;
76  ;;;    Parse the definition and make an expander function.  The actual  ;;;    Parse the definition and make an expander function.  The actual
77  ;;; definition is done by %defmacro which we expand into.  ;;; definition is done by %defmacro which we expand into.
78  ;;;  ;;;
79  (defmacro defmacro (name lambda-list &body body)  (defmacro defmacro (name lambda-list &body body)
80    (let ((whole (gensym)) (environment (gensym)))    (when lisp::*enable-package-locked-errors*
81        (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                    (error 'lisp::package-locked-error
89                           :package package
90                           :format-control (intl:gettext "defining macro ~A")
91                           :format-arguments (list name))
92                  (continue ()
93                    :report (lambda (stream)
94                              (write-string (intl:gettext "Ignore the lock and continue") stream)))
95                  (unlock-package ()
96                    :report (lambda (stream)
97                              (write-string (intl:gettext "Disable the package's definition-lock then continue") stream))
98                    (setf (ext:package-definition-lock package) nil))
99                  (unlock-all ()
100                    :report (lambda (stream)
101                              (write-string (intl:gettext "Unlock all packages, then continue") stream))
102                    (lisp::unlock-all-packages))))))))
103      (let ((whole (gensym "WHOLE-"))
104            (environment (gensym "ENV-")))
105      (multiple-value-bind      (multiple-value-bind
106          (body local-decs doc)          (body local-decs doc)
107          (parse-defmacro lambda-list whole body name          (parse-defmacro lambda-list whole body name 'defmacro
108                          :environment environment                          :environment environment)
109                          :error-string 'defmacro-error-string)        (when doc
110            (intl::note-translatable intl::*default-domain* doc))
111        (let ((def `(lambda (,whole ,environment)        (let ((def `(lambda (,whole ,environment)
112                      ,@local-decs                      ,@local-decs
113                      (block ,name                      (block ,name
114                        ,body))))                        ,body))))
115          ;;          `(progn
116          ;; ### Bootstrap hack...             (eval-when (:compile-toplevel)
117          ;; When in old compiler, call %%defmacro with #'(lambda ...) so that               (c::do-macro-compile-time ',name #',def))
118          ;; the function gets compiled.  When in old interpreter (neither in old             (eval-when (:load-toplevel :execute)
119          ;; or new compiler), just setf the macro-function so that we can have               (c::%defmacro ',name #',def ',lambda-list ,doc)))))))
         ;; interpreted macros.  
         (cond #-new-compiler  
               (system:*in-the-compiler*  
                `(c::%%defmacro ',name #',def ,doc))  
               #-new-compiler  
               ((not *in-compilation-unit*)  
                `(setf (symbol-function ',name)  
                       (cons 'macro #',def)))  
               (t  
                `(c::%defmacro ',name  
                               #+new-compiler #',def  
                               #-new-compiler ',def  
                               ',lambda-list ,doc)))))))  
   
120    
 (eval-when (compile load eval)  
121    
122  ;;; %Defmacro, %%Defmacro  --  Internal  ;;; %Defmacro, %%Defmacro  --  Internal
123  ;;;  ;;;
# Line 121  Line 131 
131  ;;; for the functional value.  ;;; for the functional value.
132  ;;;  ;;;
133  (defun c::%defmacro (name definition lambda-list doc)  (defun c::%defmacro (name definition lambda-list doc)
134    #+new-compiler    (assert (eval:interpreted-function-p definition))
135    ;; ### bootstrap hack...    (setf (eval:interpreted-function-name definition) name)
136    ;; This WHEN only necessary to make cross-compiling of this file work.    (setf (eval:interpreted-function-arglist definition) lambda-list)
   ;; Necessary because the EVAL-WHEN COMPILE goes into the bootstrap  
   ;; environment, but is read with the NEW-COMPILER feature.  
   (when (fboundp 'eval:interpreted-function-p)  
     (assert (eval:interpreted-function-p definition))  
     (setf (eval:interpreted-function-name definition)  
           (format nil "DEFMACRO ~S" name))  
     (setf (eval:interpreted-function-arglist definition) lambda-list))  
137    (c::%%defmacro name definition doc))    (c::%%defmacro name definition doc))
138  ;;;  ;;;
139  (defun c::%%defmacro (name definition doc)  (defun c::%%defmacro (name definition doc)
140    (clear-info function where-from name)    (clear-info function where-from name)
141    (setf (info function macro-function name) definition)    (setf (macro-function name) definition)
   (setf (info function kind name) :macro)  
142    (setf (documentation name 'function) doc)    (setf (documentation name 'function) doc)
143    name)    name)
144    
 ); Eval-When  
   
 ;;; ### Bootstrap hack...  
 ;;;  
 ;;; Redefine the top-level defmacro handler to do nothing special when  
 ;;; *bootstrap-defmacro* is true so that our defmacro gets called.  
 ;;;  
 #-new-compiler  
 (eval-when (compile load eval)  
   (defvar *old-pdm* #'clc::process-defmacro)  
   (defvar *bootstrap-defmacro* nil)  
   (defun clc::process-defmacro (form)  
     (ecase *bootstrap-defmacro*  
       ((t)  
        (clc::process-random (macroexpand form) nil))  
       ((nil)  
        (funcall *old-pdm* form))  
       (:both  
        (clc::process-random (macroexpand form) nil)  
        (funcall *old-pdm* form))))))  
   
 ;;; ### Bootstrap hack...  
 ;;; At load time, get defmacro from the old place and store it in the new  
 ;;; place.  
 #-new-compiler  
 (c::%%defmacro 'defmacro (macro-function 'defmacro) nil)  
   
   
 ;;; ### Bootstrap hack...  
 ;;; Install macro definitions in this file only into the new compiler's  
 ;;; environment.  
 (eval-when (compile)  
   (setq *bootstrap-defmacro* t))  
145    
146    
147  ;;; DEFTYPE is a lot like DEFMACRO.  ;;;; DEFINE-COMPILER-MACRO
148    
149  (defparameter deftype-error-string "Type ~S cannot be used with ~S args.")  (defmacro define-compiler-macro (name lambda-list &body body)
150      "Define a compiler-macro for NAME."
151      (let ((whole (gensym "WHOLE-"))
152            (environment (gensym "ENV-")))
153        (multiple-value-bind (validp block-name)
154            (valid-function-name-p name)
155          (unless validp
156            (simple-program-error (intl:gettext "~S is not a valid function name.") name))
157          (multiple-value-bind
158                (body local-decs doc)
159              (parse-defmacro lambda-list whole body name 'define-compiler-macro
160                              :environment environment)
161            (when doc
162              (intl::note-translatable intl::*default-domain* doc))
163            (let ((def `(lambda (,whole ,environment)
164                          ,@local-decs
165                          (block ,block-name
166                            ,body))))
167              `(progn
168                 (eval-when (:compile-toplevel)
169                   (c::do-compiler-macro-compile-time ',name #',def))
170                 (eval-when (:load-toplevel :execute)
171                   (c::%define-compiler-macro ',name #',def ',lambda-list ,doc))))))))
172    
173    
174    (defun c::%define-compiler-macro (name definition lambda-list doc)
175      (assert (eval:interpreted-function-p definition))
176      (setf (eval:interpreted-function-name definition)
177            (let ((*print-case* :upcase))
178              (format nil "DEFINE-COMPILER-MACRO ~S" name)))
179      (setf (eval:interpreted-function-arglist definition) lambda-list)
180      (c::%%define-compiler-macro name definition doc))
181    ;;;
182    (defun c::%%define-compiler-macro (name definition doc)
183      (setf (compiler-macro-function name) definition)
184      (setf (documentation name 'compiler-macro) doc)
185      name)
186    
 (compiler-let ((*bootstrap-defmacro* :both))  
187    
188  (defvar *bootstrap-deftype* :both)  
189    ;;;; DEFINE-SYMBOL-MACRO
190    
191    ;;; define-symbol-macro  --  Public
192    ;;;
193    (defmacro define-symbol-macro (name expansion)
194      `(eval-when (:compile-toplevel :load-toplevel :execute)
195         (%define-symbol-macro ',name ',expansion)))
196    ;;;
197    (defun %define-symbol-macro (name expansion)
198      (unless (symbolp name)
199        (error 'simple-type-error :datum name :expected-type 'symbol
200               :format-control (intl:gettext "Symbol macro name is not a symbol: ~S.")
201               :format-arguments (list name)))
202      (ecase (info variable kind name)
203        ((:macro :global nil)
204         (setf (info variable kind name) :macro)
205         (setf (info variable macro-expansion name) expansion))
206        (:special
207         (error 'simple-program-error
208                :format-control (intl:gettext "Symbol macro name already declared special: ~S.")
209                :format-arguments (list name)))
210        (:constant
211         (error 'simple-program-error
212                :format-control (intl:gettext "Symbol macro name already declared constant: ~S.")
213                :format-arguments (list name))))
214      name)
215    
216    
217    ;;; DEFTYPE is a lot like DEFMACRO.
218    
219  (defmacro deftype (name arglist &body body)  (defmacro deftype (name arglist &body body)
220    "Syntax like DEFMACRO, but defines a new type."    "Syntax like DEFMACRO, but defines a new type."
221    (unless (symbolp name)    (unless (symbolp name)
222      (error "~S -- Type name not a symbol." name))      (simple-program-error (intl:gettext "~S -- Type name not a symbol.") name))
223      (and lisp::*enable-package-locked-errors*
224    (let ((whole (gensym)))         (symbol-package name)
225           (ext:package-definition-lock (symbol-package name))
226           (restart-case
227               (error 'lisp::package-locked-error
228                      :package (symbol-package name)
229                      :format-control (intl:gettext "defining type ~A")
230                      :format-arguments (list name))
231             (continue ()
232               :report (lambda (stream)
233                         (write-string (intl:gettext "Ignore the lock and continue") stream)))
234             (unlock-package ()
235               :report (lambda (stream)
236                         (write-string (intl:gettext "Disable package's definition-lock then continue") stream))
237               (setf (ext:package-definition-lock (symbol-package name)) nil))
238             (unlock-all ()
239               :report (lambda (stream)
240                         (write-string (intl:gettext "Unlock all packages, then continue") stream))
241               (lisp::unlock-all-packages))))
242      (let ((whole (gensym "WHOLE-")))
243      (multiple-value-bind (body local-decs doc)      (multiple-value-bind (body local-decs doc)
244                           (parse-defmacro arglist whole body name                           (parse-defmacro arglist whole body name 'deftype
245                                           :default-default ''*                                           :default-default ''*)
246                                           :error-string 'deftype-error-string        (when doc
247                                           )          (intl::note-translatable intl::*default-domain* doc))
248        `(eval-when (compile load eval)        `(eval-when (:compile-toplevel :load-toplevel :execute)
249           #-new-compiler           (set-defvar-source-location ',name (c::source-location))
250           ,@(unless (or (eq *bootstrap-deftype* t)           (%deftype ',name
251                         (member :new-compiler *features*))                     #'(lambda (,whole)
252               `((setf (get ',name 'deftype-expander)                         ,@local-decs
253                       #'(lambda (,whole) ,@local-decs (block ,name ,body)))))                         (block ,name ,body))
254           ,@(when #-new-compiler *bootstrap-deftype* #+new-compiler t                     ,@(when doc `(,doc)))))))
255               `((setf (info type kind ',name) :defined)  ;;;
256                 (setf (info type expander ',name)  (defun %deftype (name expander &optional doc)
257                       #'(lambda (,whole) ,@local-decs (block ,name ,body)))))    (when (info declaration recognized name)
258           ,@(when doc      (error (intl:gettext "Deftype already names a declaration: ~S.") name))
259               `((setf (documentation ',name 'type) ,doc)))    (ecase (info type kind name)
260           ',name))))      (:primitive
261         (when *type-system-initialized*
262           (error (intl:gettext "Illegal to redefine standard type: ~S.") name)))
263        (:instance
264         (warn (intl:gettext "Redefining class ~S to be a DEFTYPE.") name)
265         (undefine-structure (layout-info (%class-layout (kernel::find-class name))))
266         (setf (class-cell-class (find-class-cell name)) nil)
267         (setf (info type compiler-layout name) nil)
268         (setf (info type kind name) :defined))
269        (:defined)
270        ((nil)
271         (setf (info type kind name) :defined)))
272    
273  ); compiler-let    (setf (info type expander name) expander)
274      (when doc
275        (setf (documentation name 'type) doc))
276      ;; ### Bootstrap hack -- we need to define types before %note-type-defined
277      ;; is defined.
278      (when (fboundp 'c::%note-type-defined)
279        (c::%note-type-defined name))
280      name)
281    
 ;;; And so is DEFINE-SETF-METHOD.  
282    
283  (defparameter defsetf-error-string "Setf expander for ~S cannot be called with ~S args.")  ;;; And so is DEFINE-SETF-EXPANDER.
284    
285  (compiler-let ((*bootstrap-defmacro* :both))  (defparameter defsetf-error-string "Setf expander for ~S cannot be called with ~S args.")
286    
287  (defmacro define-setf-method (access-fn lambda-list &body body)  (defmacro define-setf-expander (access-fn lambda-list &body body)
288    "Syntax like DEFMACRO, but creates a Setf-Method generator.  The body    "Syntax like DEFMACRO, but creates a Setf-Expansion generator.  The body
289    must be a form that returns the five magical values."    must be a form that returns the five magical values."
290    (unless (symbolp access-fn)    (unless (symbolp access-fn)
291      (error "~S -- Access-function name not a symbol in DEFINE-SETF-METHOD."      (simple-program-error (intl:gettext "~S -- Access-function name not a symbol in DEFINE-SETF-EXPANDER.")
292             access-fn))             access-fn))
293    
294    (let ((whole (gensym)) (environment (gensym)))    (let ((whole (gensym "WHOLE-"))
295            (environment (gensym "ENV-")))
296      (multiple-value-bind (body local-decs doc)      (multiple-value-bind (body local-decs doc)
297                           (parse-defmacro lambda-list whole body access-fn                           (parse-defmacro lambda-list whole body access-fn
298                                           :environment environment                                           'define-setf-expander
299                                           :error-string 'defsetf-error-string)                                           :environment environment)
300        `(eval-when (load compile eval)        (when doc
301           (setf (info setf inverse ',access-fn) nil)          (intl::note-translatable intl::*default-domain* doc))
302           (setf (info setf expander ',access-fn)        `(eval-when (:compile-toplevel :load-toplevel :execute)
303                 #'(lambda (,whole ,environment)           (%define-setf-macro
304                     ,@local-decs            ',access-fn
305                     (block ,access-fn ,body)))            #'(lambda (,whole ,environment)
306           ,@(when doc                ,@local-decs
307               `((setf (documentation ',access-fn 'setf) ,doc)))                (block ,access-fn ,body))
308           ',access-fn))))            nil
309              ',doc)))))
310    
311    (defmacro define-setf-method (&rest stuff)
312      "Obsolete, use define-setf-expander."
313      `(define-setf-expander ,@stuff))
314    
315    
316    ;;; %DEFINE-SETF-MACRO  --  Internal
317    ;;;
318    ;;;    Do stuff for defining a setf macro.
319    ;;;
320    (defun %define-setf-macro (name expander inverse doc)
321      (cond ((not (fboundp `(setf ,name))))
322            ((info function accessor-for name)
323             (warn (intl:gettext "Defining setf macro for destruct slot accessor; redefining as ~
324                    a normal function:~%  ~S")
325                   name)
326             (c::define-function-name name))
327            ((not (eq (symbol-package name) (symbol-package 'aref)))
328             (warn (intl:gettext "Defining setf macro for ~S, but ~S is fbound.")
329                   name `(setf ,name))))
330      (when (or inverse (info setf inverse name))
331        (setf (info setf inverse name) inverse))
332      (when (or expander (info setf expander name))
333        (setf (info setf expander name) expander))
334      (when doc
335        (setf (documentation name 'setf) doc))
336      name)
337    
338    
339    ;;;; Destructuring-bind
340    
341  ); compiler-let  (defmacro destructuring-bind (lambda-list arg-list &rest body)
342      "Bind the variables in LAMBDA-LIST to the contents of ARG-LIST."
343      (let* ((arg-list-name (gensym "ARG-LIST-")))
344        (multiple-value-bind
345            (body local-decls)
346            (parse-defmacro lambda-list arg-list-name body nil 'destructuring-bind
347                            :annonymousp t :doc-string-allowed nil)
348          `(let ((,arg-list-name ,arg-list))
349             ,@local-decls
350             ,body))))
351    
352    
353  ;;;; Defun, Defvar, Defparameter, Defconstant:  ;;;; Defun, Defvar, Defparameter, Defconstant:
# Line 248  Line 357 
357  ;;;    Very similar to Defmacro, but simpler.  We don't have to parse the  ;;;    Very similar to Defmacro, but simpler.  We don't have to parse the
358  ;;; lambda-list.  ;;; lambda-list.
359  ;;;  ;;;
360  (defmacro defun (name lambda-list &body (body decls doc) &whole source)  (defmacro defun (&whole source name lambda-list &parse-body (body decls doc))
361    (let ((def `(lambda ,lambda-list    (multiple-value-bind (valid block-name)
362                  ,@decls        (valid-function-name-p name)
363                  (block ,(if (and (consp name) (eq (car name) 'setf))      (declare (ignore valid))
364                              (cadr name)      (when doc
365                              name)        (intl::note-translatable intl::*default-domain* doc))
366                    ,@body))))      (let ((def `(lambda ,lambda-list
367      `(c::%defun ',name #',def ,doc ',source)))                    ,@decls
368                      (block ,block-name ,@body))))
369          `(c::%defun ',name #',def ,doc ',source))))
370    
371    
372  ;;; %Defun, %%Defun  --  Internal  ;;; %Defun, %%Defun  --  Internal
# Line 263  Line 374 
374  ;;;    Similar to %Defmacro, ...  ;;;    Similar to %Defmacro, ...
375  ;;;  ;;;
376  (defun c::%%defun (name def doc &optional inline-expansion)  (defun c::%%defun (name def doc &optional inline-expansion)
377      (c::define-function-name name)
378    (setf (fdefinition name) def)    (setf (fdefinition name) def)
379    (when doc    (when doc
380      (if (and (consp name) (eq (first name) 'setf))      (if (and (consp name) (eq (first name) 'setf))
381          (setf (documentation (second name) 'setf) doc)          (setf (documentation (second name) 'setf) doc)
382          (setf (documentation name 'function) doc)))          (setf (documentation name 'function) doc)))
383      (when (eq (info function where-from name) :assumed)
384    (unless (eq (info function kind name) :function)      (setf (info function where-from name) :defined)
385      (setf (info function kind name) :function))      (when (info function assumed-type name)
386          (setf (info function assumed-type name) nil)))
   (when (info function accessor-for name)  
     (setf (info function accessor-for name) nil))  
   
387    (when (or inline-expansion    (when (or inline-expansion
388              (info function inline-expansion name))              (info function inline-expansion name))
389      (setf (info function inline-expansion name) inline-expansion))      (setf (info function inline-expansion name) inline-expansion))
390    name)    name)
391  ;;;  
392  (defun c::%defun (name def doc source)  (defun c::%defun (name def doc source)
393    (declare (ignore source))    (declare (ignore source))
   #+new-compiler  
394    (assert (eval:interpreted-function-p def))    (assert (eval:interpreted-function-p def))
   #+new-compiler  
395    (setf (eval:interpreted-function-name def) name)    (setf (eval:interpreted-function-name def) name)
396    (c::%%defun name def doc))    (let ((inline-expansion nil))
397        (when (memq (info function inlinep name) '(:inline :maybe-inline))
398          (multiple-value-bind (lambda-expression closure-p)
399              (function-lambda-expression def)
400            (unless closure-p
401              (setq inline-expansion lambda-expression))))
402        (c::%%defun name def doc inline-expansion)))
403    
404    (defun set-defvar-textdomain (name domain)
405      (setf (c::info variable textdomain name) domain))
406    
407  ;;; DEFCONSTANT  --  Public  ;;; DEFCONSTANT  --  Public
408  ;;;  ;;;
# Line 296  Line 411 
411    value is constant and may be compiled into code.  If the variable already has    value is constant and may be compiled into code.  If the variable already has
412    a value, and this is not equal to the init, an error is signalled.  The third    a value, and this is not equal to the init, an error is signalled.  The third
413    argument is an optional documentation string for the variable."    argument is an optional documentation string for the variable."
414    `(c::%defconstant ',var ,val ',doc))    (when doc
415        (intl::note-translatable intl::*default-domain* doc))
416      `(progn
417         (eval-when (:compile-toplevel)
418           (c::do-defconstant-compile-time ',var ,val ',doc))
419         (eval-when (:load-toplevel :execute)
420           (set-defvar-textdomain ',var ,intl::*default-domain*)
421           (c::%%defconstant ',var ,val ',doc (c::source-location)))))
422    
423    (defun set-defvar-source-location (name source-location)
424      (setf (info :source-location :defvar name) source-location))
425    
426  ;;; %Defconstant, %%Defconstant  --  Internal  ;;; %Defconstant, %%Defconstant  --  Internal
427  ;;;  ;;;
# Line 305  Line 430 
430  ;;; redefined.  ;;; redefined.
431  ;;;  ;;;
432  (defun c::%defconstant (name value doc)  (defun c::%defconstant (name value doc)
433    (c::%%defconstant name value doc))    (c::%%defconstant name value doc nil))
434  ;;;  ;;;
435  (defun c::%%defconstant (name value doc)  (defun c::%%defconstant (name value doc source-location)
436    (when doc    (when doc
437      (setf (documentation name 'variable) doc))      (setf (documentation name 'variable) doc))
438    (when (boundp name)    (when (boundp name)
439      (unless (equalp (symbol-value name) value)      (unless (equalp (symbol-value name) value)
440        (cerror "Go ahead and change the value."        (cerror (intl:gettext "Go ahead and change the value.")
441                "Constant ~S being redefined." name)))                (intl:gettext "Constant ~S being redefined.") name)))
442    (setf (symbol-value name) value)    (setf (symbol-value name) value)
443    (setf (info variable kind name) :constant)    (setf (info variable kind name) :constant)
444    (clear-info variable constant-value name)    (clear-info variable constant-value name)
445      (set-defvar-source-location name source-location)
446    name)    name)
447    
   
448  (defmacro defvar (var &optional (val nil valp) (doc nil docp))  (defmacro defvar (var &optional (val nil valp) (doc nil docp))
449    "For defining global variables at top level.  Declares the variable    "For defining global variables at top level.  Declares the variable
450    SPECIAL and, optionally, initializes it.  If the variable already has a    SPECIAL and, optionally, initializes it.  If the variable already has a
451    value, the old value is not clobbered.  The third argument is an optional    value, the old value is not clobbered.  The third argument is an optional
452    documentation string for the variable."    documentation string for the variable."
453      (when docp
454        (intl::note-translatable intl::*default-domain* doc))
455    `(progn    `(progn
456      (proclaim '(special ,var))      (declaim (special ,var))
457       ,@(when valp       ,@(when valp
458           `((unless (boundp ',var)           `((unless (boundp ',var)
459               (setq ,var ,val))))               (setq ,var ,val))))
460      ,@(when docp      ,@(when docp
461          `((setf (documentation ',var 'variable) ',doc)))          `((setf (documentation ',var 'variable) ',doc)
462              (eval-when (:load-toplevel :execute)
463                (set-defvar-textdomain ',var ,intl::*default-domain*))))
464        (set-defvar-source-location ',var (c::source-location))
465      ',var))      ',var))
466    
467  (defmacro defparameter (var val &optional (doc nil docp))  (defmacro defparameter (var val &optional (doc nil docp))
# Line 339  Line 469 
469    but that may be changed without causing an error.  Declares the    but that may be changed without causing an error.  Declares the
470    variable special and sets its value to VAL.  The third argument is    variable special and sets its value to VAL.  The third argument is
471    an optional documentation string for the parameter."    an optional documentation string for the parameter."
472      (when docp
473        (intl::note-translatable intl::*default-domain* doc))
474    `(progn    `(progn
475      (proclaim '(special ,var))      (declaim (special ,var))
476      (setq ,var ,val)      (setq ,var ,val)
477      ,@(when docp      ,@(when docp
478          `((setf (documentation ',var 'variable) ',doc)))          `((setf (documentation ',var 'variable) ',doc)
479              (eval-when (:load-toplevel :execute)
480                (set-defvar-textdomain ',var ,intl::*default-domain*))))
481        (set-defvar-source-location ',var (c::source-location))
482      ',var))      ',var))
483    
484    
# Line 364  Line 499 
499  (defmacro return (&optional (value nil))  (defmacro return (&optional (value nil))
500    `(return-from nil ,value))    `(return-from nil ,value))
501    
502  (defmacro prog (varlist &body (body decls))  (defmacro prog (varlist &parse-body (body decls))
503    `(block nil    `(block nil
504       (let ,varlist       (let ,varlist
505         ,@decls         ,@decls
506         (tagbody ,@body))))         (tagbody ,@body))))
507    
508  (defmacro prog* (varlist &body (body decls))  (defmacro prog* (varlist &parse-body (body decls))
509    `(block nil    `(block nil
510       (let* ,varlist       (let* ,varlist
511         ,@decls         ,@decls
# Line 423  Line 558 
558        nil        nil
559        (let ((clause (first clauses)))        (let ((clause (first clauses)))
560          (when (atom clause)          (when (atom clause)
561            (error "Cond clause is not a list: ~S." clause))            (error (intl:gettext "Cond clause is not a list: ~S.") clause))
562          (let ((test (first clause))          (let ((test (first clause))
563                (forms (rest clause)))                (forms (rest clause)))
564            (if (endp forms)            (if (endp forms)
# Line 446  Line 581 
581  ;;;  ;;;
582  (defmacro multiple-value-setq (varlist value-form)  (defmacro multiple-value-setq (varlist value-form)
583    (unless (and (listp varlist) (every #'symbolp varlist))    (unless (and (listp varlist) (every #'symbolp varlist))
584      (error "Varlist is not a list of symbols: ~S." varlist))      (simple-program-error (intl:gettext "Varlist is not a list of symbols: ~S.") varlist))
585    (let ((temps (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) varlist)))    (if varlist
586      `(multiple-value-bind ,temps ,value-form        `(values (setf (values ,@varlist) ,value-form))
587         ,@(mapcar #'(lambda (var temp)        `(values ,value-form)))
588                       `(setq ,var ,temp))  
                  varlist temps)  
        ,(car temps))))  
589  ;;;  ;;;
590  (defmacro multiple-value-bind (varlist value-form &body body)  (defmacro multiple-value-bind (varlist value-form &body body)
591    (unless (and (listp varlist) (every #'symbolp varlist))    (unless (and (listp varlist) (every #'symbolp varlist))
592      (error "Varlist is not a list of symbols: ~S." varlist))      (simple-program-error  (intl:gettext "Varlist is not a list of symbols: ~S.") varlist))
593    (if (= (length varlist) 1)    (if (= (length varlist) 1)
594        `(let ((,(car varlist) ,value-form))        `(let ((,(car varlist) ,value-form))
595           ,@body)           ,@body)
596        (let ((ignore (gensym)))        (let ((ignore (gensym)))
597          `(multiple-value-call #'(lambda (&optional ,@varlist &rest ,ignore)          `(multiple-value-call #'(lambda (&optional ,@(mapcar #'list varlist) &rest ,ignore)
598                                    (declare (ignore ,ignore))                                    (declare (ignore ,ignore))
599                                    ,@body)                                    ,@body)
600             ,value-form))))             ,value-form))))
# Line 469  Line 602 
602  (defmacro multiple-value-list (value-form)  (defmacro multiple-value-list (value-form)
603    `(multiple-value-call #'list ,value-form))    `(multiple-value-call #'list ,value-form))
604    
605    
606    (defmacro nth-value (n form)
607      "Evaluates FORM and returns the Nth value (zero based).  This involves no
608      consing when N is a trivial constant integer."
609      (if (integerp n)
610          (let ((dummy-list nil)
611                (keeper (gensym "KEEPER-")))
612            ;; We build DUMMY-LIST, a list of variables to bind to useless
613            ;; values, then we explicitly IGNORE those bindings and return
614            ;; KEEPER, the only thing we're really interested in right now.
615            (dotimes (i n)
616              (push (gensym "IGNORE-") dummy-list))
617            `(multiple-value-bind (,@dummy-list ,keeper)
618                                  ,form
619               (declare (ignore ,@dummy-list))
620               ,keeper))
621          (once-only ((n n))
622            `(case (the (values fixnum &rest t) ,n)
623               (0 (nth-value 0 ,form))
624               (1 (nth-value 1 ,form))
625               (2 (nth-value 2 ,form))
626               (T (nth (the (values fixnum &rest t) ,n)
627                            (multiple-value-list ,form)))))))
628    
629    
630  ;;;; SETF and friends.  ;;;; SETF and friends.
631    
# Line 480  Line 637 
637  ;;; The inverse for a generalized-variable reference function is stored in  ;;; The inverse for a generalized-variable reference function is stored in
638  ;;; one of two ways:  ;;; one of two ways:
639  ;;;  ;;;
640  ;;; A SETF-INVERSE property corresponds to the short form of DEFSETF.  It is  ;;; A SETF inverse property corresponds to the short form of DEFSETF.  It is
641  ;;; the name of a function takes the same args as the reference form, plus a  ;;; the name of a function takes the same args as the reference form, plus a
642  ;;; new-value arg at the end.  ;;; new-value arg at the end.
643  ;;;  ;;;
644  ;;; A SETF-METHOD-EXPANDER property is created by the long form of DEFSETF or  ;;; A SETF method expander is created by the long form of DEFSETF or
645  ;;; by DEFINE-SETF-METHOD.  It is a function that is called on the reference  ;;; by DEFINE-SETF-EXPANDER.  It is a function that is called on the reference
646  ;;; form and that produces five values: a list of temporary variables, a list  ;;; form and that produces five values: a list of temporary variables, a list
647  ;;; of value forms, a list of the single store-value form, a storing function,  ;;; of value forms, a list of the single store-value form, a storing function,
648  ;;; and an accessing function.  ;;; and an accessing function.
649    
650  (eval-when (compile load eval)  (defun get-setf-expansion (form &optional environment)
   
 ;;; ### bootstrap hack...  
 ;;; Rename get-setf-method so that we don't blow away setf in the bootstrap  
 ;;; lisp.  All references in this file are to the renamed function, and should  
 ;;; eventually be renamed back.  
 ;;;  
 #+new-compiler  
 (defun get-setf-method (form &optional environment)  
   (foo-get-setf-method form environment))  
 ;;;  
 (defun foo-get-setf-method (form &optional environment)  
651    "Returns five values needed by the SETF machinery: a list of temporary    "Returns five values needed by the SETF machinery: a list of temporary
652    variables, a list of values with which to fill them, the temporary for the     variables, a list of values with which to fill them, a list of temporaries
653    new value in a list, the setting function, and the accessing function."     for the new values, the setting function, and the accessing function."
654    (let (temp)    (let (temp)
655      (cond ((symbolp form)      (cond ((symbolp form)
656             (let ((new-var (gensym)))             (multiple-value-bind
657               (values nil nil (list new-var) `(setq ,form ,new-var) form)))                 (expansion expanded)
658            ((atom form)                 (macroexpand-1 form environment)
659             (error "~S illegal atomic form for GET-SETF-METHOD." form))               (if expanded
660                     (get-setf-expansion expansion environment)
661                     (let ((new-var (gensym)))
662                       (values nil nil (list new-var)
663                               `(setq ,form ,new-var) form)))))
664            ;;            ;;
665            ;; ### Bootstrap hack...            ;; Local functions inhibit global setf methods...
666            ;; Ignore any DEFSETF info for structure accessors.            ((and environment
667            ((info function accessor-for (car form))                  (let ((name (car form)))
668             (get-setf-method-inverse form `(funcall #'(setf ,(car form)))))                    (dolist (x (c::lexenv-functions environment) nil)
669                        (when (and (eq (car x) name)
670                                   (not (c::defined-function-p (cdr x))))
671                          (return t)))))
672               (expand-or-get-setf-inverse form environment))
673            ((setq temp (info setf inverse (car form)))            ((setq temp (info setf inverse (car form)))
674             (get-setf-method-inverse form `(,temp)))             (get-setf-method-inverse form `(,temp) nil))
675            ((setq temp (info setf expander (car form)))            ((setq temp (info setf expander (car form)))
676             (funcall temp form environment))             (funcall temp form environment))
677            (t            (t
678             (multiple-value-bind (res win)             (expand-or-get-setf-inverse form environment)))))
679                                  (macroexpand-1 form environment)  
680               (if win  (defun get-setf-method-multiple-value (form &optional env)
681                   (foo-get-setf-method res environment)    "Obsolete: use GET-SETF-EXPANSION."
682                   (get-setf-method-inverse    (get-setf-expansion form env))
683                    form  
684                    `(funcall #'(setf ,(car form))))))))))  ;;;
685    ;;; If a macro, expand one level and try again.  If not, go for the
686    ;;; SETF function.
687    (defun expand-or-get-setf-inverse (form environment)
688      (multiple-value-bind
689          (expansion expanded)
690          (macroexpand-1 form environment)
691        (if expanded
692            (get-setf-expansion expansion environment)
693            (get-setf-method-inverse form `(funcall #'(setf ,(car form)))
694                                     t))))
695    
696  (defun get-setf-method-inverse (form inverse)  
697    (defun get-setf-method-inverse (form inverse setf-function)
698    (let ((new-var (gensym))    (let ((new-var (gensym))
699          (vars nil)          (vars nil)
700          (vals nil))          (vals nil))
# Line 538  Line 703 
703        (push x vals))        (push x vals))
704      (setq vals (nreverse vals))      (setq vals (nreverse vals))
705      (values vars vals (list new-var)      (values vars vals (list new-var)
706              `(,@inverse ,@vars ,new-var)              (if setf-function
707                    `(,@inverse ,new-var ,@vars)
708                    `(,@inverse ,@vars ,new-var))
709              `(,(car form) ,@vars))))              `(,(car form) ,@vars))))
710    
711    
712  (defun get-setf-method-multiple-value (form &optional environment)  (defun get-setf-method (form &optional environment)
713    "Like Get-Setf-Method, but may return multiple new-value variables."    "Obsolete: use GET-SETF-EXPANSION and handle multiple store values."
714    (get-setf-method form environment))    (multiple-value-bind
715          (temps value-forms store-vars store-form access-form)
716  (defun defsetter (fn rest env)        (get-setf-expansion form environment)
717    (let* ((arglist (car rest))      (when (cdr store-vars)
718           (new-var (car (cadr rest)))        (error (intl:gettext "GET-SETF-METHOD used for a form with multiple store ~
719           (%arg-count 0)                variables:~%  ~S") form))
720           (%min-args 0)      (values temps value-forms store-vars store-form access-form)))
          (%restp nil)  
          (%let-list nil)  
          (%keyword-tests nil))  
     (declare (special %arg-count %min-args %restp %let-list %keyword-tests))  
     (multiple-value-bind (body local-decs doc)  
                          (parse-body (cddr rest) env)  
       ;; Analyze the defmacro argument list.  
       (analyze1 arglist '(cdr %access-arglist) fn '%access-arglist)  
       ;; Now build the body of the transform.  
       (values  
        `(lambda (%access-arglist ,new-var)  
           ,@(when (null arglist)  
               '((declare (ignore %access-arglist))))  
           (let* ,(nreverse %let-list)  
             ,@ local-decs  
             ,@ %keyword-tests  
             ,@ body))  
        doc))))  
721    
 ) ; End of Eval-When.  
722    
723    (defun defsetter (fn rest)
724      (let ((arglist (car rest))
725            (arglist-var (gensym "ARGS-"))
726            (new-var (car (cadr rest))))
727        (multiple-value-bind
728            (body local-decs doc)
729            (parse-defmacro arglist arglist-var (cddr rest) fn 'defsetf)
730          (when doc
731            (intl::note-translatable intl::*default-domain* doc))
732          (values
733           `(lambda (,arglist-var ,new-var)
734              ,@local-decs
735              ,body)
736           doc))))
737    
 (compiler-let ((*bootstrap-defmacro* :both))  
738    
739  (defmacro defsetf (access-fn &rest rest &environment env)  (defmacro defsetf (access-fn &rest rest)
740    "Associates a SETF update function or macro with the specified access    "Associates a SETF update function or macro with the specified access
741    function or macro.  The format is complex.  See the manual for    function or macro.  The format is complex.  See the manual for
742    details."    details."
743    (cond ((not (listp (car rest)))    (cond ((not (listp (car rest)))
744           `(eval-when (load compile eval)           `(eval-when (load compile eval)
745              (setf (info setf inverse ',access-fn) ',(car rest))              (%define-setf-macro ',access-fn nil ',(car rest)
746              ;;                                  ,(when (and (car rest) (stringp (cadr rest)))
747              ;; ### Bootstrap hack...                                     `',(cadr rest)))))
748              ;; In bootstrap env, also install inverse in old place so that we          ((and (cdr rest) (listp (cadr rest)))
749              ;; can still compile defstructs.           (destructuring-bind
750              #-new-compiler               (lambda-list (&rest store-variables) &body body)
751              (setf (get ',access-fn 'setf-inverse) ',(car rest))               rest
752              (setf (info setf expander ',access-fn) nil)             (let ((arglist-var (gensym "ARGS-"))
753              ,@(if (and (car rest) (stringp (cadr rest)))                   (access-form-var (gensym "ACCESS-FORM-"))
754                    `((eval-when (load eval)                   (env-var (gensym "ENVIRONMENT-")))
755                        (%put ',access-fn '%setf-documentation ,(cadr rest)))))               (multiple-value-bind
756              ',access-fn))                   (body local-decs doc)
757          ((and (listp (car rest)) (cdr rest) (listp (cadr rest)))                   (parse-defmacro `(,lambda-list ,@store-variables)
758           (if (not (= (length (cadr rest)) 1))                                   arglist-var body access-fn 'defsetf
759               (cerror "Ignore the extra items in the list."                                   :annonymousp t)
760                       "Only one new-value variable allowed in DEFSETF."))                 (when doc
761           (multiple-value-bind (setting-form-generator doc)                   (intl::note-translatable intl::*default-domain* doc))
762                                (defsetter access-fn rest env)                 `(eval-when (load compile eval)
763             `(eval-when (load compile eval)                    (%define-setf-macro
764                (setf (info setf inverse ',access-fn) nil)                     ',access-fn
765                (setf (info setf expander ',access-fn)                     #'(lambda (,access-form-var ,env-var)
766                      #'(lambda (access-form environment)                         (declare (ignore ,env-var))
767                          (declare (ignore environment))                         (%defsetf ,access-form-var ,(length store-variables)
768                          (do* ((args (cdr access-form) (cdr args))                                   #'(lambda (,arglist-var)
769                                (dummies nil (cons (gensym) dummies))                                       ,@local-decs
770                                (newval-var (gensym))                                       (block ,access-fn
771                                (new-access-form nil))                                         ,body))))
772                               ((atom args)                     nil
773                                (setq new-access-form                     ',doc))))))
774                                      (cons (car access-form) dummies))          (t
775                                (values           (error (intl:gettext "Ill-formed DEFSETF for ~S.") access-fn))))
                                dummies  
                                (cdr access-form)  
                                (list newval-var)  
                                (funcall (function ,setting-form-generator)  
                                         new-access-form newval-var)  
                                new-access-form)))))  
               ,@(if doc  
                     `((eval-when (load eval)  
                         (%put ',access-fn '%setf-documentation ',doc)))  
                     `((eval-when (load eval)             ;SKH 4/17/84  
                         (remprop ',access-fn '%setf-documentation))))  
               ',access-fn)))  
         (t (error "Ill-formed DEFSETF for ~S." access-fn))))  
   
 ); Compiler-Let  
776    
777    (defun %defsetf (orig-access-form num-store-vars expander)
778      (collect ((subforms) (subform-vars) (subform-exprs) (store-vars))
779        (dolist (subform (cdr orig-access-form))
780          (if (constantp subform)
781              (subforms subform)
782              (let ((var (gensym)))
783                (subforms var)
784                (subform-vars var)
785                (subform-exprs subform))))
786        (dotimes (i num-store-vars)
787          (store-vars (gensym)))
788        (values (subform-vars)
789                (subform-exprs)
790                (store-vars)
791                (funcall expander (cons (subforms) (store-vars)))
792                `(,(car orig-access-form) ,@(subforms)))))
793    
794    
795    ;;; SETF  --  Public
796    ;;;
797    ;;;    Except for atoms, we always call GET-SETF-METHOD, since it has some
798    ;;; non-trivial semantics.  But when there is a setf inverse, and G-S-M uses
799    ;;; it, then we return a call to the inverse, rather than returning a hairy let
800    ;;; form.  This is probably important mainly as a convenince in allowing the
801    ;;; use of setf inverses without the full interpreter.
802    ;;;
803  (defmacro setf (&rest args &environment env)  (defmacro setf (&rest args &environment env)
804    "Takes pairs of arguments like SETQ.  The first is a place and the second    "Takes pairs of arguments like SETQ.  The first is a place and the second
805    is the value that is supposed to go into that place.  Returns the last    is the value that is supposed to go into that place.  Returns the last
806    value.  The place argument may be any of the access forms for which SETF    value.  The place argument may be any of the access forms for which SETF
807    knows a corresponding setting form."    knows a corresponding setting form."
808    (let ((temp (length args)))    (let ((nargs (length args)))
809      (cond ((= temp 2)      (cond
810             (cond ((atom (car args))       ((= nargs 2)
811                    `(setq ,(car args) ,(cadr args)))        (let ((place (first args))
812                   ((info function accessor-for (caar args))              (value-form (second args)))
813                    `(funcall #'(setf ,(caar args)) ,@(cdar args) ,(cadr args)))          (if (atom place)
814                   ((setq temp (info setf inverse (caar args)))              `(setq ,place ,value-form)
815                    `(,temp ,@(cdar args) ,(cadr args)))              (multiple-value-bind (dummies vals newval setter getter)
816                   (t (multiple-value-bind (dummies vals newval setter getter)                                   (get-setf-expansion place env)
817                                           (foo-get-setf-method (car args) env)                (declare (ignore getter))
818                        (declare (ignore getter))                (let ((inverse (info setf inverse (car place))))
819                        (do* ((d dummies (cdr d))                  (if (and inverse (eq inverse (car setter)))
820                              (v vals (cdr v))                      `(,inverse ,@(cdr place) ,value-form)
821                              (let-list nil))                      `(let* (,@(mapcar #'list dummies vals))
822                             ((null d)                         (multiple-value-bind ,newval ,value-form
823                              (setq let-list                           ,setter))))))))
824                                    (nreverse (cons (list (car newval)       ((oddp nargs)
825                                                          (cadr args))        (error (intl:gettext "Odd number of args to SETF.")))
826                                                    let-list)))       (t
827                              `(let* ,let-list ,setter))        (do ((a args (cddr a)) (l nil))
828                          (setq let-list            ((null a) `(progn ,@(nreverse l)))
829                                (cons (list (car d) (car v)) let-list)))))))          (setq l (cons (list 'setf (car a) (cadr a)) l)))))))
           ((oddp temp)  
            (error "Odd number of args to SETF."))  
           (t (do ((a args (cddr a)) (l nil))  
                  ((null a) `(progn ,@(nreverse l)))  
                (setq l (cons (list 'setf (car a) (cadr a)) l)))))))  
   
830    
831  (defmacro psetf (&rest args &environment env)  (defmacro psetf (&rest args &environment env)
832    "This is to SETF as PSETQ is to SETQ.  Args are alternating place    "This is to SETF as PSETQ is to SETQ.  Args are alternating place
833    expressions and values to go into those places.  All of the subforms and    expressions and values to go into those places.  All of the subforms and
834    values are determined, left to right, and only then are the locations    values are determined, left to right, and only then are the locations
835    updated.  Returns NIL."    updated.  Returns NIL."
836    (do ((a args (cddr a))    (collect ((let*-bindings) (mv-bindings) (setters))
837         (let-list nil)      (do ((a args (cddr a)))
838         (setf-list nil))          ((endp a))
839        ((atom a)        (if (endp (cdr a))
840         `(let* ,(nreverse let-list) ,@(nreverse setf-list) nil))            (simple-program-error (intl:gettext "Odd number of args to PSETF.")))
841      (if (atom (cdr a))        (multiple-value-bind
842          (error "Odd number of args to PSETF."))            (dummies vals newval setter getter)
843      (multiple-value-bind (dummies vals newval setter getter)            (get-setf-expansion (car a) env)
844        (foo-get-setf-method (car a) env)          (declare (ignore getter))
845        (declare (ignore getter))          (let*-bindings (mapcar #'list dummies vals))
846        (do* ((d dummies (cdr d))          (mv-bindings (list newval (cadr a)))
847              (v vals (cdr v)))          (setters setter)))
848             ((null d))      (labels ((thunk (let*-bindings mv-bindings)
849          (push (list (car d) (car v)) let-list))                 (if let*-bindings
850        (push (list (car newval) (cadr a)) let-list)                     `(let* ,(car let*-bindings)
851        (push setter setf-list))))                        (multiple-value-bind ,@(car mv-bindings)
852                            ,(thunk (cdr let*-bindings) (cdr mv-bindings))))
853                       `(progn ,@(setters) nil))))
854          (thunk (let*-bindings) (mv-bindings)))))
855    
856  (defmacro shiftf (&rest args &environment env)  (defmacro shiftf (&rest args &environment env)
857    "One or more SETF-style place expressions, followed by a single    "One or more SETF-style place expressions, followed by a single
858    value expression.  Evaluates all of the expressions in turn, then     value expression.  Evaluates all of the expressions in turn, then
859    assigns the value of each expression to the place on its left,     assigns the value of each expression to the place on its left,
860    returning the value of the leftmost."     returning the value of the leftmost."
861    (if (< (length args) 2)    (when args
862        (error "Too few argument forms to a SHIFTF."))      (collect ((let*-bindings) (mv-bindings) (setters) (getters))
863    (let ((leftmost (gensym)))        ;; The last arg isn't necessarily a place, so we have to handle
864      (do ((a args (cdr a))        ;; that separately.
865           (let-list nil)        (dolist (arg (butlast args))
866           (setf-list nil)          (multiple-value-bind
867           (next-var leftmost))                (temps subforms store-vars setter getter)
868          ((atom (cdr a))              (get-setf-expansion arg env)
869           (push (list next-var (car a)) let-list)            (loop
870           `(let* ,(nreverse let-list) ,@(nreverse setf-list) ,leftmost))                for temp in temps
871        (multiple-value-bind (dummies vals newval setter getter)                for subform in subforms
872          (foo-get-setf-method (car a) env)                do (let*-bindings `(,temp ,subform)))
873          (do* ((d dummies (cdr d))            (mv-bindings store-vars)
874                (v vals (cdr v)))            (setters setter)
875               ((null d))            (getters getter)))
876            (push (list (car d) (car v)) let-list))        ;; Handle the last arg specially here.  Just put something to
877          (push (list next-var getter) let-list)        ;; force the setter so the setter for the previous var gets set,
878          (push setter setf-list)        ;; and the getter is just the last arg itself.
879          (setq next-var (car newval))))))        (setters nil)
880          (getters (car (last args)))
881    
882          (labels ((thunk (mv-bindings getters)
883                     (if mv-bindings
884                         `((multiple-value-bind
885                                 ,(car mv-bindings)
886                               ,(car getters)
887                             ,@(thunk (cdr mv-bindings) (cdr getters))))
888                         `(,@(butlast (setters))))))
889            `(let* ,(let*-bindings)
890              (multiple-value-bind ,(car (mv-bindings))
891                  ,(car (getters))
892                ,@(thunk (mv-bindings) (cdr (getters)))
893                (values ,@(car (mv-bindings)))))))))
894    
895  (defmacro rotatef (&rest args &environment env)  (defmacro rotatef (&rest args &environment env)
896    "Takes any number of SETF-style place expressions.  Evaluates all of the    "Takes any number of SETF-style place expressions.  Evaluates all of the
897    expressions in turn, then assigns to each place the value of the form to     expressions in turn, then assigns to each place the value of the form to
898    its right.  The rightmost form gets the value of the leftmost.  Returns NIL."     its right.  The rightmost form gets the value of the leftmost.
899    (cond ((null args) nil)     Returns NIL."
900          ((null (cdr args)) `(progn ,(car args) nil))    (when args
901          (t (do ((a args (cdr a))      (collect ((let*-bindings) (mv-bindings) (setters) (getters))
902                  (let-list nil)        (dolist (arg args)
903                  (setf-list nil)          (multiple-value-bind
904                  (next-var nil)              (temps subforms store-vars setter getter)
905                  (fix-me nil))              (get-setf-expansion arg env)
906                 ((atom a)            (loop
907                    (rplaca fix-me next-var)              for temp in temps
908                    `(let* ,(nreverse let-list) ,@(nreverse setf-list) nil))              for subform in subforms
909                 (multiple-value-bind (dummies vals newval setter getter)              do (let*-bindings `(,temp ,subform)))
910                   (foo-get-setf-method (car a) env)            (mv-bindings store-vars)
911                   (do ((d dummies (cdr d))            (setters setter)
912                        (v vals (cdr v)))            (getters getter)))
913                       ((null d))        (setters nil)
914                     (push (list (car d) (car v)) let-list))        (getters (car (getters)))
915                   (push (list next-var getter) let-list)        (labels ((thunk (mv-bindings getters)
916                   ;; We don't know the newval variable for the last form yet,                   (if mv-bindings
917                   ;; so fake it for the first getter and fix it at the end.                       `((multiple-value-bind
918                   (unless fix-me (setq fix-me (car let-list)))                             ,(car mv-bindings)
919                   (push setter setf-list)                             ,(car getters)
920                   (setq next-var (car newval)))))))                           ,@(thunk (cdr mv-bindings) (cdr getters))))
921                         (setters))))
922            `(let* ,(let*-bindings)
923               ,@(thunk (mv-bindings) (cdr (getters))))))))
924    
925    
 (compiler-let ((*bootstrap-defmacro* :both))  
   
926  (defmacro define-modify-macro (name lambda-list function &optional doc-string)  (defmacro define-modify-macro (name lambda-list function &optional doc-string)
927    "Creates a new read-modify-write macro like PUSH or INCF."    "Creates a new read-modify-write macro like PUSH or INCF."
928    (let ((other-args nil)    (let ((other-args nil)
929          (rest-arg nil)          (rest-arg nil)
930          (env (gensym))          (env (gensym "ENV-"))
931          (reference (gensym)))          (reference (gensym "PLACE-")))
932    
933      ;; Parse out the variable names and rest arg from the lambda list.      ;; Parse out the variable names and rest arg from the lambda list.
934      (do ((ll lambda-list (cdr ll))      (do ((ll lambda-list (cdr ll))
# Line 758  Line 939 
939              ((eq arg '&rest)              ((eq arg '&rest)
940               (if (symbolp (cadr ll))               (if (symbolp (cadr ll))
941                   (setq rest-arg (cadr ll))                   (setq rest-arg (cadr ll))
942                   (error "Non-symbol &rest arg in definition of ~S." name))                   (error (intl:gettext "Non-symbol &rest arg in definition of ~S.") name))
943               (if (null (cddr ll))               (if (null (cddr ll))
944                   (return nil)                   (return nil)
945                   (error "Illegal stuff after &rest arg in Define-Modify-Macro.")))                   (error (intl:gettext "Illegal stuff after &rest arg in Define-Modify-Macro."))))
946              ((memq arg '(&key &allow-other-keys &aux))              ((memq arg '(&key &allow-other-keys &aux))
947               (error "~S not allowed in Define-Modify-Macro lambda list." arg))               (error (intl:gettext "~S not allowed in Define-Modify-Macro lambda list.") arg))
948              ((symbolp arg)              ((symbolp arg)
949               (push arg other-args))               (push arg other-args))
950              ((and (listp arg) (symbolp (car arg)))              ((and (listp arg) (symbolp (car arg)))
951               (push (car arg) other-args))               (push (car arg) other-args))
952              (t (error "Illegal stuff in lambda list of Define-Modify-Macro."))))              (t (error (intl:gettext "Illegal stuff in lambda list of Define-Modify-Macro.")))))
953      (setq other-args (nreverse other-args))      (setq other-args (nreverse other-args))
954      `(defmacro ,name (,reference ,@lambda-list &environment ,env)      `(defmacro ,name (,reference ,@lambda-list &environment ,env)
955         ,doc-string         ,doc-string
956         (multiple-value-bind (dummies vals newval setter getter)         (multiple-value-bind (dummies vals newval setter getter)
957           (foo-get-setf-method ,reference ,env)           (get-setf-method ,reference ,env)
958           (do ((d dummies (cdr d))           (do ((d dummies (cdr d))
959                (v vals (cdr v))                (v vals (cdr v))
960                (let-list nil (cons (list (car d) (car v)) let-list)))                (let-list nil (cons (list (car d) (car v)) let-list)))
# Line 787  Line 968 
968                `(let* ,(nreverse let-list)                `(let* ,(nreverse let-list)
969                   ,setter)))))))                   ,setter)))))))
970    
 ); Compiler-Let  
   
   
971  (defmacro push (obj place &environment env)  (defmacro push (obj place &environment env)
972    "Takes an object and a location holding a list.  Conses the object onto    "Takes an object and a location holding a list.  Conses the object onto
973    the list, returning the modified list."    the list, returning the modified list.  OBJ is evaluated before PLACE."
974    (if (symbolp place)  
975      ;; This special case for place being a symbol isn't strictly needed.
976      ;; It's so we can do push (and pushnew) with a kernel.core.
977      (if (and (symbolp place)
978               (eq place (macroexpand place env)))
979        `(setq ,place (cons ,obj ,place))        `(setq ,place (cons ,obj ,place))
980        (multiple-value-bind (dummies vals newval setter getter)        (multiple-value-bind (dummies vals newval setter getter)
981                             (foo-get-setf-method place env)            (get-setf-expansion place env)
982          (do* ((d dummies (cdr d))          (cond
983                (v vals (cdr v))            ((cdr newval)
984                (let-list nil))             ;; Handle multiple values
985               ((null d)             (let ((g (mapcar #'(lambda (x)
986                (push (list (car newval) `(cons ,obj ,getter))                                  (declare (ignore x))
987                      let-list)                                  (gensym))
988                `(let* ,(nreverse let-list)                              (rest obj))))
989                   ,setter))               `(multiple-value-bind ,g
990            (push (list (car d) (car v)) let-list)))))                    ,obj
991                    (let* (,@(mapcar #'list dummies vals))
992                      (multiple-value-bind ,newval
993                          (values ,@(mapcar #'(lambda (a b)
994                                                 (list 'cons a b))
995                                             g (rest getter)))
996                        ,setter)))))
997              (t
998               ;; A single value
999               (let ((g (gensym)))
1000                 `(let* ((,g ,obj)
1001                         ,@(mapcar #'list dummies vals)
1002                         (,@newval (cons ,g ,getter)))
1003                   ,setter)))))))
1004    
1005  (defmacro pushnew (obj place &rest keys &environment env)  (defmacro pushnew (obj place &rest keys &environment env)
1006    "Takes an object and a location holding a list.  If the object is already    "Takes an object and a location holding a list.  If the object is already
1007    in the list, does nothing.  Else, conses the object onto the list.  Returns    in the list, does nothing.  Else, conses the object onto the list.  Returns
1008    NIL.  If there is a :TEST keyword, this is used for the comparison."    NIL.  If there is a :TEST keyword, this is used for the comparison."
1009    (if (symbolp place)    (if (and (symbolp place)
1010               (eq place (macroexpand place env)))
1011        `(setq ,place (adjoin ,obj ,place ,@keys))        `(setq ,place (adjoin ,obj ,place ,@keys))
1012        (multiple-value-bind (dummies vals newval setter getter)        (multiple-value-bind (vars vals stores setter getter)
1013                             (foo-get-setf-method place env)            (get-setf-expansion place env)
1014          (do* ((d dummies (cdr d))          (cond
1015                (v vals (cdr v))            ((cdr stores)
1016                (let-list nil))             ;; Multiple values
1017               ((null d)             (let ((g (mapcar #'(lambda (x)
1018                (push (list (car newval) `(adjoin ,obj ,getter ,@keys))                                  (declare (ignore x))
1019                      let-list)                                  (gensym))
1020                `(let* ,(nreverse let-list)                              (rest obj))))
1021                   ,setter))               `(multiple-value-bind ,g
1022            (push (list (car d) (car v)) let-list)))))                    ,obj
1023                    (let* (,@(mapcar #'list vars vals))
1024                      (multiple-value-bind ,stores
1025                          (values ,@(mapcar #'(lambda (a b)
1026                                                `(adjoin ,a ,b ,@keys))
1027                                            g (rest getter)))
1028                      ,setter)))))
1029              (t
1030               ;; Single value
1031               (let ((g (gensym)))
1032                 `(let* ((,g ,obj)
1033                         ,@(mapcar #'list vars vals)
1034                         (,@stores (adjoin ,g ,getter ,@keys)))
1035                    ,setter)))))))
1036    
1037  (defmacro pop (place &environment env)  (defmacro pop (place &environment env)
1038    "The argument is a location holding a list.  Pops one item off the front    "The argument is a location holding a list.  Pops one item off the front
1039    of the list and returns it."    of the list and returns it."
1040    (if (symbolp place)    (if (and (symbolp place)
1041        `(prog1 (car ,place) (setq ,place (cdr ,place)))             (eq place (macroexpand place env)))
1042          `(prog1 (car ,place)
1043                  (setq ,place (cdr ,place)))
1044        (multiple-value-bind (dummies vals newval setter getter)        (multiple-value-bind (dummies vals newval setter getter)
1045                             (foo-get-setf-method place env)            (get-setf-method place env)
1046          (do* ((d dummies (cdr d))          (do* ((d dummies (cdr d))
1047                (v vals (cdr v))                (v vals (cdr v))
1048                (let-list nil))                (let-list nil))
1049               ((null d)               ((null d)
1050                (push (list (car newval) getter) let-list)                (push (list (car newval) getter) let-list)
1051                `(let* ,(nreverse let-list)                `(let* ,(nreverse let-list)
1052                   (prog1 (car ,(car newval))                  (prog1 (car ,(car newval))
1053                          (setq ,(car newval) (cdr ,(car newval)))                    (setq ,(car newval) (cdr ,(car newval)))
1054                          ,setter)))                    ,setter)))
1055            (push (list (car d) (car v)) let-list)))))            (push (list (car d) (car v)) let-list)))))
1056    
1057    
1058  (define-modify-macro incf (&optional (delta 1)) +  ;;; we can't use DEFINE-MODIFY-MACRO because of ANSI 5.1.3
1059    "The first argument is some location holding a number.  This number is  (defmacro incf (place &optional (delta 1) &environment env)
1060    incremented by the second argument, DELTA, which defaults to 1.")    "The first argument is some location holding a number. This number is
1061      incremented by the second argument, DELTA, which defaults to 1."
   
 (define-modify-macro decf (&optional (delta 1)) -  
   "The first argument is some location holding a number.  This number is  
   decremented by the second argument, DELTA, which defaults to 1.")  
 #|  
 (defmacro putf (place indicator value &environment env)  
   "Place may be any place expression acceptable to SETF, and is expected  
   to hold a property list or ().  This list is destructively altered so  
   that (GETF place indicator) will find the specified newvalue.  Returns  
   the new value."  
1062    (multiple-value-bind (dummies vals newval setter getter)    (multiple-value-bind (dummies vals newval setter getter)
1063                         (foo-get-setf-method place env)        (get-setf-method place env)
1064      (do* ((d dummies (cdr d))      (let ((d (gensym)))
1065            (v vals (cdr v))        `(let* (,@(mapcar #'list dummies vals)
1066            (let-list nil)                (,d ,delta)
1067            (ind-temp (gensym))                (,(car newval) (+ ,getter ,d)))
1068            (val-temp (gensym)))           ,setter))))
1069           ((null d)  
1070            (push (list (car newval) getter) let-list)  (defmacro decf (place &optional (delta 1) &environment env)
1071            (push (list ind-temp indicator) let-list)    "The first argument is some location holding a number. This number is
1072            (push (list val-temp value) let-list)    decremented by the second argument, DELTA, which defaults to 1."
1073            `(let* ,(nreverse let-list)    (multiple-value-bind (dummies vals newval setter getter)
1074               (setq ,(car newval)        (get-setf-method place env)
1075                     (%primitive putf ,(car newval) ,ind-temp ,val-temp))      (let ((d (gensym)))
1076               ,setter        `(let* (,@(mapcar #'list dummies vals)
1077               ,val-temp))                (,d ,delta)
1078        (push (list (car d) (car v)) let-list))))                (,(car newval) (- ,getter ,d)))
1079  |#           ,setter))))
   
1080    
1081  (defmacro remf (place indicator &environment env)  (defmacro remf (place indicator &environment env)
1082    "Place may be any place expression acceptable to SETF, and is expected    "Place may be any place expression acceptable to SETF, and is expected
# Line 886  Line 1084 
1084    remove the property specified by the indicator.  Returns T if such a    remove the property specified by the indicator.  Returns T if such a
1085    property was present, NIL if not."    property was present, NIL if not."
1086    (multiple-value-bind (dummies vals newval setter getter)    (multiple-value-bind (dummies vals newval setter getter)
1087                         (foo-get-setf-method place env)                         (get-setf-method place env)
1088      (do* ((d dummies (cdr d))      (do* ((d dummies (cdr d))
1089            (v vals (cdr v))            (v vals (cdr v))
1090            (let-list nil)            (let-list nil)
# Line 894  Line 1092 
1092            (local1 (gensym))            (local1 (gensym))
1093            (local2 (gensym)))            (local2 (gensym)))
1094           ((null d)           ((null d)
1095            (push (list (car newval) getter) let-list)            ;; See ANSI 5.1.3 for why we do out-of-order evaluation
1096            (push (list ind-temp indicator) let-list)            (push (list ind-temp indicator) let-list)
1097              (push (list (car newval) getter) let-list)
1098            `(let* ,(nreverse let-list)            `(let* ,(nreverse let-list)
1099               (do ((,local1 ,(car newval) (cddr ,local1))               (do ((,local1 ,(car newval) (cddr ,local1))
1100                    (,local2 nil ,local1))                    (,local2 nil ,local1))
1101                   ((atom ,local1) nil)                   ((atom ,local1) nil)
1102                 (cond ((atom (cdr ,local1))                 (cond ((atom (cdr ,local1))
1103                        (error "Odd-length property list in REMF."))                        (error (intl:gettext "Odd-length property list in REMF.")))
1104                       ((eq (car ,local1) ,ind-temp)                       ((eq (car ,local1) ,ind-temp)
1105                        (cond (,local2                        (cond (,local2
1106                               (rplacd (cdr ,local2) (cddr ,local1))                               (rplacd (cdr ,local2) (cddr ,local1))
# Line 965  Line 1164 
1164  (defsetf bit %bitset)  (defsetf bit %bitset)
1165  (defsetf schar %scharset)  (defsetf schar %scharset)
1166  (defsetf sbit %sbitset)  (defsetf sbit %sbitset)
1167    (defsetf %array-dimension %set-array-dimension)
1168    (defsetf %raw-bits %set-raw-bits)
1169  (defsetf symbol-value set)  (defsetf symbol-value set)
1170  (defsetf symbol-function %sp-set-definition)  (defsetf symbol-function fset)
1171  (defsetf symbol-plist %sp-set-plist)  (defsetf symbol-plist %set-symbol-plist)
 (defsetf documentation %set-documentation)  
1172  (defsetf nth %setnth)  (defsetf nth %setnth)
1173  (defsetf fill-pointer %set-fill-pointer)  (defsetf fill-pointer %set-fill-pointer)
1174  (defsetf search-list %set-search-list)  (defsetf search-list %set-search-list)
1175    
1176  (defsetf sap-ref-8 %set-sap-ref-8)  (defsetf sap-ref-8 %set-sap-ref-8)
1177  (defsetf signed-sap-ref-8 %set-sap-ref-8)  (defsetf signed-sap-ref-8 %set-signed-sap-ref-8)
1178  (defsetf sap-ref-16 %set-sap-ref-16)  (defsetf sap-ref-16 %set-sap-ref-16)
1179  (defsetf signed-sap-ref-16 %set-sap-ref-16)  (defsetf signed-sap-ref-16 %set-signed-sap-ref-16)
1180  (defsetf sap-ref-32 %set-sap-ref-32)  (defsetf sap-ref-32 %set-sap-ref-32)
1181  (defsetf signed-sap-ref-32 %set-sap-ref-32)  (defsetf signed-sap-ref-32 %set-signed-sap-ref-32)
1182    (defsetf sap-ref-64 %set-sap-ref-64)
1183    (defsetf signed-sap-ref-64 %set-signed-sap-ref-64)
1184  (defsetf sap-ref-sap %set-sap-ref-sap)  (defsetf sap-ref-sap %set-sap-ref-sap)
1185    (defsetf sap-ref-single %set-sap-ref-single)
1186    (defsetf sap-ref-double %set-sap-ref-double)
1187    #+(or x86 long-float)
1188    (defsetf sap-ref-long %set-sap-ref-long)
1189    
1190  (define-setf-method getf (place prop &optional default &environment env)  (define-setf-expander getf (place prop &optional default &environment env)
1191    (multiple-value-bind (temps values stores set get)    (multiple-value-bind (temps values stores set get)
1192                         (foo-get-setf-method place env)                         (get-setf-method place env)
1193      (let ((newval (gensym))      (let ((newval (gensym))
1194            (ptemp (gensym))            (ptemp (gensym))
1195            (def-temp (gensym)))            (def-temp (if default (gensym))))
1196        (values `(,@temps ,(car stores) ,ptemp ,@(if default `(,def-temp)))        (values `(,@temps ,ptemp ,@(if default `(,def-temp)))
1197                `(,@values ,get ,prop ,@(if default `(,default)))                `(,@values ,prop ,@(if default `(,default)))
1198                `(,newval)                `(,newval)
1199                `(progn (setq ,(car stores)                `(let ((,(car stores) (%putf ,get ,ptemp ,newval)))
1200                              (%primitive putf ,(car stores) ,ptemp ,newval))                   ,set
1201                        ,set                   ,newval)
1202                        ,newval)                `(getf ,get ,ptemp ,@(if default `(,def-temp)))))))
1203                `(getf ,(car stores) ,ptemp ,@(if default `(,def-temp)))))))  
1204    (define-setf-expander get (symbol prop &optional default)
 (define-setf-method get (symbol prop &optional default)  
   "Get turns into %put. Don't put in the default unless it really is supplied and  
   non-nil, so that we can transform into the get instruction whenever possible."  
1205    (let ((symbol-temp (gensym))    (let ((symbol-temp (gensym))
1206          (prop-temp (gensym))          (prop-temp (gensym))
1207          (def-temp (gensym))          (def-temp (gensym))
# Line 1009  Line 1212 
1212              `(%put ,symbol-temp ,prop-temp ,newval)              `(%put ,symbol-temp ,prop-temp ,newval)
1213              `(get ,symbol-temp ,prop-temp ,@(if default `(,def-temp))))))              `(get ,symbol-temp ,prop-temp ,@(if default `(,def-temp))))))
1214    
1215  (define-setf-method gethash (key hashtable &optional default)  (define-setf-expander gethash (key hashtable &optional default)
1216    (let ((key-temp (gensym))    (let ((key-temp (gensym))
1217          (hashtable-temp (gensym))          (hashtable-temp (gensym))
1218          (default-temp (gensym))          (default-temp (gensym))
# Line 1026  Line 1229 
1229            ,v))            ,v))
1230    
1231    
1232  ;;; Evil hack invented by the gnomes of Vassar Street.  The function  ;;; Evil hack invented by the gnomes of Vassar Street (though not as evil as
1233  ;;; arg must be constant.  Get a setf method for this function, pretending  ;;; it used to be.)  The function arg must be constant, and is converted to an
1234  ;;; that the final (list) arg to apply is just a normal arg.  If the  ;;; APPLY of ther SETF function, which ought to exist.
1235  ;;; setting and access forms produced in this way reference this arg at  ;;;
1236  ;;; the end, then just splice the APPLY back onto the front and the right  (define-setf-expander apply (function &rest args)
1237  ;;; thing happens.    (unless (and (listp function)
1238                   (= (list-length function) 2)
1239  (define-setf-method apply (function &rest args &environment env)                 (eq (first function) 'function)
1240    (if (and (listp function)                 (symbolp (second function)))
1241             (= (list-length function) 2)      (error (intl:gettext "Setf of Apply is only defined for function args like #'symbol.")))
1242             (eq (first function) 'function)    (let ((function (second function))
1243             (symbolp (second function)))          (new-var (gensym))
1244        (setq function (second function))          (vars nil))
1245        (error      (dolist (x args)
1246         "Setf of Apply is only defined for function args of form #'symbol."))        (declare (ignore x))
1247    (multiple-value-bind (dummies vals newval setter getter)        (push (gensym) vars))
1248                         (foo-get-setf-method (cons function args) env)      (values vars args (list new-var)
1249      ;; Special case aref and svref.              `(apply #'(setf ,function) ,new-var ,@vars)
1250      (cond ((or (eq function 'aref) (eq function 'svref))              `(apply #',function ,@vars))))
            (let ((nargs (subseq setter 0 (1- (length setter))))  
                  (fcn (if (eq function 'aref) 'lisp::%apply-aset 'lisp::%apply-svset)))  
              (values dummies vals newval  
                      `(apply (function ,fcn) ,(car newval) ,@(cdr nargs))  
                      `(apply (function ,function) ,@(cdr getter)))))  
           ;; Make sure the place is one that we can handle.  
           (T (unless (and (eq (car (last args)) (car (last vals)))  
                           (eq (car (last getter)) (car (last dummies)))  
                           (eq (car (last setter)) (car (last dummies))))  
                (error "Apply of ~S not understood as a location for Setf."  
                       function))  
              (values dummies vals newval  
                      `(apply (function ,(car setter)) ,@(cdr setter))  
                      `(apply (function ,(car getter)) ,@(cdr getter)))))))  
1251    
1252    
1253  (define-setf-method ldb (bytespec place &environment env)  ;;; Special-case a BYTE bytespec so that the compiler can recognize it.
1254    ;;;
1255    (define-setf-expander ldb (bytespec place &environment env)
1256    "The first argument is a byte specifier.  The second is any place form    "The first argument is a byte specifier.  The second is any place form
1257    acceptable to SETF.  Replaces the specified byte of the number in this    acceptable to SETF.  Replaces the specified byte of the number in this
1258    place with bits from the low-order end of the new value."    place with bits from the low-order end of the new value."
1259    (multiple-value-bind (dummies vals newval setter getter)    (multiple-value-bind (dummies vals newval setter getter)
1260                         (foo-get-setf-method place env)                         (get-setf-method place env)
1261      (let ((btemp (gensym))      (if (and (consp bytespec) (eq (car bytespec) 'byte))
1262            (gnuval (gensym)))          (let ((n-size (gensym))
1263        (values (cons btemp dummies)                (n-pos (gensym))
1264                (cons bytespec vals)                (n-new (gensym)))
1265                (list gnuval)            (values (list* n-size n-pos dummies)
1266                `(let ((,(car newval) (dpb ,gnuval ,btemp ,getter)))                    (list* (second bytespec) (third bytespec) vals)
1267                   ,setter                    (list n-new)
1268                   ,gnuval)                    `(let ((,(car newval) (dpb ,n-new (byte ,n-size ,n-pos)
1269                `(ldb ,btemp ,getter)))))                                               ,getter)))
1270                         ,setter
1271                         ,n-new)
1272                      `(ldb (byte ,n-size ,n-pos) ,getter)))
1273            (let ((btemp (gensym))
1274                  (gnuval (gensym)))
1275              (values (cons btemp dummies)
1276                      (cons bytespec vals)
1277                      (list gnuval)
1278                      `(let ((,(car newval) (dpb ,gnuval ,btemp ,getter)))
1279                         ,setter
1280                         ,gnuval)
1281                      `(ldb ,btemp ,getter))))))
1282    
1283    
1284  (define-setf-method mask-field (bytespec place &environment env)  (define-setf-expander mask-field (bytespec place &environment env)
1285    "The first argument is a byte specifier.  The second is any place form    "The first argument is a byte specifier.  The second is any place form
1286    acceptable to SETF.  Replaces the specified byte of the number in this place    acceptable to SETF.  Replaces the specified byte of the number in this place
1287    with bits from the corresponding position in the new value."    with bits from the corresponding position in the new value."
1288    (multiple-value-bind (dummies vals newval setter getter)    (multiple-value-bind (dummies vals newval setter getter)
1289                         (foo-get-setf-method place env)                         (get-setf-method place env)
1290      (let ((btemp (gensym))      (let ((btemp (gensym))
1291            (gnuval (gensym)))            (gnuval (gensym)))
1292        (values (cons btemp dummies)        (values (cons btemp dummies)
# Line 1095  Line 1298 
1298                `(mask-field ,btemp ,getter)))))                `(mask-field ,btemp ,getter)))))
1299    
1300    
1301  (define-setf-method the (type place &environment env)  (define-setf-expander the (type place &environment env)
1302    (multiple-value-bind (dummies vals newval setter getter)    (multiple-value-bind (dummies vals newval setter getter)
1303                         (foo-get-setf-method place env)                         (get-setf-method place env)
1304        (values dummies        (values dummies
1305                vals                vals
1306                newval                newval
1307                (subst `(the ,type ,(car newval)) (car newval) setter)                (subst `(the ,type ,(car newval)) (car newval) setter)
1308                `(the ,type ,getter))))                `(the ,type ,getter))))
1309    
1310    (define-setf-expander values (&rest places &environment env)
1311      (collect ((setters) (getters))
1312        (let ((all-dummies '())
1313              (all-vals '())
1314              (newvals '()))
1315          (dolist (place places)
1316            (multiple-value-bind (dummies vals newval setter getter)
1317                (get-setf-expansion place env)
1318              ;; ANSI CL 5.1.2.3 explains that extra places are set to
1319              ;; nil.
1320              (setf all-dummies (append all-dummies dummies (cdr newval)))
1321              (setf all-vals (append all-vals vals
1322                                     (mapcar (constantly nil) (cdr newval))))
1323              (setf newvals (append newvals (list (car newval))))
1324              (setters setter)
1325              (getters getter)))
1326          (values all-dummies all-vals newvals
1327                  `(values ,@(setters)) `(values ,@(getters))))))
1328    
1329    
1330  ;;;; CASE, TYPECASE, & Friends.  ;;;; CASE, TYPECASE, & Friends.
1331    
1332  (eval-when (compile load eval)  (eval-when (:compile-toplevel :load-toplevel :execute)
1333    
1334  ;;; CASE-BODY returns code for all the standard "case" macros.  Name is the  ;;; CASE-BODY returns code for all the standard "case" macros.  Name is the
1335  ;;; macro name, and keyform is the thing to case on.  Multi-p indicates whether  ;;; macro name, and keyform is the thing to case on.  Multi-p indicates whether
# Line 1121  Line 1342 
1342  ;;; to omit errorp, and the ERROR form generated is executed within a  ;;; to omit errorp, and the ERROR form generated is executed within a
1343  ;;; RESTART-CASE allowing keyform to be set and retested.  ;;; RESTART-CASE allowing keyform to be set and retested.
1344  ;;;  ;;;
1345  (defun case-body (name keyform cases multi-p test errorp proceedp)  ;;; If ALLOW-OTHERWISE, then we allow T and OTHERWISE clauses and also
1346    ;;; generate an ERROR form.  (This is for CCASE and ECASE which allow
1347    ;;; using T and OTHERWISE as regular keys.)
1348    ;;;
1349    (defun case-body (name keyform cases multi-p test errorp proceedp &optional allow-otherwise)
1350    (let ((keyform-value (gensym))    (let ((keyform-value (gensym))
1351          (clauses ())          (clauses ())
1352          (keys ()))          (keys ()))
1353      (dolist (case cases)      (do* ((case-list cases (cdr case-list))
1354              (case (first case-list) (first case-list)))
1355             ((null case-list))
1356        (cond ((atom case)        (cond ((atom case)
1357               (error "~S -- Bad clause in ~S." case name))               (error (intl:gettext "~S -- Bad clause in ~S.") case name))
1358              ((memq (car case) '(t otherwise))              ((and (not allow-otherwise)
1359               (if errorp                    (memq (car case) '(t otherwise)))
1360                   (error "No default clause allowed in ~S: ~S" name case)               (cond ((null (cdr case-list))
1361                   (push `(t nil ,@(rest case)) clauses)))                      ;; The CLHS says OTHERWISE clause is an OTHERWISE clause
1362                        ;; only if it's the last case.  Otherwise, it's just a
1363                        ;; normal clause.
1364                        (if errorp
1365                            (error (intl:gettext "No default clause allowed in ~S: ~S") name case)
1366                            (push `(t nil ,@(rest case)) clauses)))
1367                       ((and (eq name 'case))
1368                        (error (intl:gettext "T and OTHERWISE may not be used as key designators for ~A") name))
1369                       ((eq (first case) t)
1370                        ;; The key T is normal clause, because it's not
1371                        ;; the last clause.
1372                        (push (first case) keys)
1373                        (push `((,test ,keyform-value
1374                                ',(first case)) nil ,@(rest case)) clauses))))
1375              ((and multi-p (listp (first case)))              ((and multi-p (listp (first case)))
1376               (setf keys (append (first case) keys))               (setf keys (append (first case) keys))
1377               (push `((or ,@(mapcar #'(lambda (key)               (push `((or ,@(mapcar #'(lambda (key)
# Line 1140  Line 1380 
1380                       nil ,@(rest case))                       nil ,@(rest case))
1381                     clauses))                     clauses))
1382              (t              (t
1383                 (when (and allow-otherwise
1384                            (memq (car case) '(t otherwise)))
1385                   (warn (intl:gettext "Bad style to use T or OTHERWISE in ECASE or CCASE")))
1386               (push (first case) keys)               (push (first case) keys)
1387               (push `((,test ,keyform-value               (push `((,test ,keyform-value
1388                              ',(first case)) nil ,@(rest case)) clauses))))                              ',(first case)) nil ,@(rest case)) clauses))))
1389      (case-body-aux name keyform keyform-value clauses keys errorp proceedp      (case-body-aux name keyform keyform-value clauses keys errorp proceedp
1390                       allow-otherwise
1391                     `(,(if multi-p 'member 'or) ,@keys))))                     `(,(if multi-p 'member 'or) ,@keys))))
1392    
1393  ;;; CASE-BODY-AUX provides the expansion once CASE-BODY has groveled all the  ;;; CASE-BODY-AUX provides the expansion once CASE-BODY has groveled all the
# Line 1154  Line 1398 
1398  ;;; any function using the case macros, regardless of whether they are needed.  ;;; any function using the case macros, regardless of whether they are needed.
1399  ;;;  ;;;
1400  (defun case-body-aux (name keyform keyform-value clauses keys  (defun case-body-aux (name keyform keyform-value clauses keys
1401                        errorp proceedp expected-type)                        errorp proceedp allow-otherwise expected-type)
1402    (if proceedp    (if proceedp
1403        (let ((block (gensym))        (let ((block (gensym))
1404              (again (gensym)))              (again (gensym)))
# Line 1173  Line 1417 
1417                                     ',expected-type ',keys)))                                     ',expected-type ',keys)))
1418                        (go ,again))))))))                        (go ,again))))))))
1419        `(let ((,keyform-value ,keyform))        `(let ((,keyform-value ,keyform))
1420             ,keyform-value ; prevent warnings when key not used eg (case key (t))
1421           (cond           (cond
1422            ,@(nreverse clauses)            ,@(nreverse clauses)
1423            ,@(if errorp            ,@(if (or errorp allow-otherwise)
1424                  `((t (error 'conditions::case-failure                  `((t (error 'conditions::case-failure
1425                              :name ',name                              :name ',name
1426                              :datum ,keyform-value                              :datum ,keyform-value
# Line 1193  Line 1438 
1438               :possibilities keys)               :possibilities keys)
1439      (store-value (value)      (store-value (value)
1440        :report (lambda (stream)        :report (lambda (stream)
1441                  (format stream "Supply a new value for ~S." keyform))                  (format stream (intl:gettext "Supply a new value for ~S.") keyform))
1442        :interactive read-evaluated-form        :interactive read-evaluated-form
1443        value)))        value)))
1444    
1445    
   
1446  (defmacro case (keyform &body cases)  (defmacro case (keyform &body cases)
1447    "CASE Keyform {({(Key*) | Key} Form*)}*    "CASE Keyform {({(Key*) | Key} Form*)}*
1448    Evaluates the Forms in the first clause with a Key EQL to the value of    Evaluates the Forms in the first clause with a Key EQL to the value
1449    Keyform.  If a singleton key is T then the clause is a default clause."    of Keyform.  If a singleton key is T or Otherwise then the clause is
1450      a default clause."
1451    (case-body 'case keyform cases t 'eql nil nil))    (case-body 'case keyform cases t 'eql nil nil))
1452    
1453  (defmacro ccase (keyform &body cases)  (defmacro ccase (keyform &body cases)
# Line 1210  Line 1455 
1455    Evaluates the Forms in the first clause with a Key EQL to the value of    Evaluates the Forms in the first clause with a Key EQL to the value of
1456    Keyform.  If none of the keys matches then a correctable error is    Keyform.  If none of the keys matches then a correctable error is
1457    signalled."    signalled."
1458    (case-body 'ccase keyform cases t 'eql t t))    (case-body 'ccase keyform cases t 'eql nil t t))
1459    
1460  (defmacro ecase (keyform &body cases)  (defmacro ecase (keyform &body cases)
1461    "ECASE Keyform {({(Key*) | Key} Form*)}*    "ECASE Keyform {({(Key*) | Key} Form*)}*
1462    Evaluates the Forms in the first clause with a Key EQL to the value of    Evaluates the Forms in the first clause with a Key EQL to the value of
1463    Keyform.  If none of the keys matches then an error is signalled."    Keyform.  If none of the keys matches then an error is signalled."
1464    (case-body 'ecase keyform cases t 'eql t nil))    (case-body 'ecase keyform cases t 'eql nil nil t))
1465    
1466  (defmacro typecase (keyform &body cases)  (defmacro typecase (keyform &body cases)
1467    "TYPECASE Keyform {(Type Form*)}*    "TYPECASE Keyform {(Type Form*)}*
1468    Evaluates the Forms in the first clause for which TYPEP of Keyform and Type    Evaluates the Forms in the first clause for which TYPEP of Keyform
1469    is true."    and Type is true.  If a singleton key is T or Otherwise then the
1470      clause is a default clause."
1471    (case-body 'typecase keyform cases nil 'typep nil nil))    (case-body 'typecase keyform cases nil 'typep nil nil))
1472    
1473  (defmacro ctypecase (keyform &body cases)  (defmacro ctypecase (keyform &body cases)
1474    "CTYPECASE Keyform {(Type Form*)}*    "CTYPECASE Keyform {(Type Form*)}*
1475    Evaluates the Forms in the first clause for which TYPEP of Keyform and Type    Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
1476    is true.  If no form is satisfied then a correctable error is signalled."    is true.  If no form is satisfied then a correctable error is signalled."
1477    (case-body 'ctypecase keyform cases nil 'typep t t))    (case-body 'ctypecase keyform cases nil 'typep nil t t))
1478    
1479  (defmacro etypecase (keyform &body cases)  (defmacro etypecase (keyform &body cases)
1480    "ETYPECASE Keyform {(Type Form*)}*    "ETYPECASE Keyform {(Type Form*)}*
1481    Evaluates the Forms in the first clause for which TYPEP of Keyform and Type    Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
1482    is true.  If no form is satisfied then an error is signalled."    is true.  If no form is satisfied then an error is signalled."
1483    (case-body 'etypecase keyform cases nil 'typep t nil))    (case-body 'etypecase keyform cases nil 'typep nil nil t))
1484    
1485    
1486  ;;;; ASSERT and CHECK-TYPE.  ;;;; ASSERT and CHECK-TYPE.
# Line 1255  Line 1501 
1501                     `(setf ,place (assert-prompt ',place ,place)))                     `(setf ,place (assert-prompt ',place ,place)))
1502                 places)))                 places)))
1503    
1504  (defun assert-error (test-form places datum &rest arguments)  (defun assert-error (assertion places datum &rest arguments)
1505    (restart-case (if datum    (let ((cond (if datum
1506                      (apply #'error datum arguments)                    (conditions::coerce-to-condition
1507                      (simple-assertion-failure test-form))                     datum arguments
1508                       'simple-error 'error)
1509                      (make-condition 'simple-error
1510                                      :format-control (intl:gettext "The assertion ~S failed.")
1511                                      :format-arguments (list assertion)))))
1512      (restart-case (error cond)
1513      (continue ()      (continue ()
1514        :report (lambda (stream) (assert-report places stream))        :report (lambda (stream) (assert-report places stream))
1515        nil)))        nil))))
1516    
 (defun simple-assertion-failure (assertion)  
   (error 'simple-type-error  
          :datum assertion  
          :expected-type nil ;this needs some work in next revision. -kmp  
          :format-string "The assertion ~S failed."  
          :format-arguments (list assertion)))  
1517    
1518  (defun assert-report (names stream)  (defun assert-report (names stream)
1519    (format stream "Retry assertion")    (format stream (intl:gettext "Retry assertion"))
1520    (if names    (if names
1521        (format stream " with new value~P for ~{~S~^, ~}."        (format stream (intl:ngettext " with new value for ~{~S~^, ~}."
1522                (length names) names)                                      " with new values for ~{~S~^, ~}."
1523                                        (length names))
1524                  names)
1525        (format stream ".")))        (format stream ".")))
1526    
1527  (defun assert-prompt (name value)  (defun assert-prompt (name value)
1528    (cond ((y-or-n-p "The old value of ~S is ~S.~    (cond ((y-or-n-p (intl:gettext "The old value of ~S is ~S.~
1529                    ~%Do you want to supply a new value? "                    ~%Do you want to supply a new value? ")
1530                     name value)                     name value)
1531           (format *query-io* "~&Type a form to be evaluated:~%")           (format *query-io* (intl:gettext "~&Type a form to be evaluated:~%"))
1532           (flet ((read-it () (eval (read *query-io*))))           (flet ((read-it () (eval (read *query-io*))))
1533             (if (symbolp name) ;help user debug lexical variables             (if (symbolp name) ;help user debug lexical variables
1534                 (progv (list name) (list value) (read-it))                 (progv (list name) (list value) (read-it))
# Line 1309  Line 1556 
1556                 (check-type-error ',place ,place-value ',type ,type-string))))))                 (check-type-error ',place ,place-value ',type ,type-string))))))
1557    
1558  (defun check-type-error (place place-value type type-string)  (defun check-type-error (place place-value type type-string)
1559    (restart-case (if type-string    (let ((cond (if type-string
1560                      (error 'simple-type-error                    (make-condition 'simple-type-error
1561                             :datum place :expected-type type                                    :datum place-value :expected-type type
1562                             :format-string                                    :format-control
1563                             "The value of ~S is ~S, which is not ~A."                                    (intl:gettext "The value of ~S is ~S, which is not ~A.")
1564                             :format-arguments                                    :format-arguments
1565                             (list place place-value type-string))                                    (list place place-value type-string))
1566                      (error 'simple-type-error                    (make-condition 'simple-type-error
1567                             :datum place :expected-type type                                    :datum place-value :expected-type type
1568                             :format-string                                    :format-control
1569                             "The value of ~S is ~S, which is not of type ~S."                                    (intl:gettext "The value of ~S is ~S, which is not of type ~S.")
1570                             :format-arguments                                    :format-arguments
1571                             (list place place-value type)))                                    (list place place-value type)))))
1572      (store-value (value)      (restart-case (error cond)
1573        :report (lambda (stream)        (store-value (value)
1574                  (format stream "Supply a new value of ~S."          :report (lambda (stream)
1575                          place))                    (format stream (intl:gettext "Supply a new value of ~S.")
1576        :interactive read-evaluated-form                            place))
1577        value)))          :interactive read-evaluated-form
1578            value))))
1579    
1580  ;;; READ-EVALUATED-FORM is used as the interactive method for restart cases  ;;; READ-EVALUATED-FORM is used as the interactive method for restart cases
1581  ;;; setup by the Common Lisp "casing" (e.g., CCASE and CTYPECASE) macros  ;;; setup by the Common Lisp "casing" (e.g., CCASE and CTYPECASE) macros
1582  ;;; and by CHECK-TYPE.  ;;; and by CHECK-TYPE.
1583  ;;;  ;;;
1584  (defun read-evaluated-form ()  (defun read-evaluated-form ()
1585    (format *query-io* "~&Type a form to be evaluated:~%")    (format *query-io* (intl:gettext "~&Type a form to be evaluated:~%"))
1586    (list (eval (read *query-io*))))    (list (eval (read *query-io*))))
1587    
1588    
1589  ;;;; With-XXX  ;;;; With-XXX
1590    (defmacro with-open-file ((var filespec &rest open-args) &parse-body (forms decls))
1591  (defmacro with-open-file ((var &rest open-args) &body (forms decls))    "The file whose name is Filespec is opened using the Open-args and
1592    "Bindspec is of the form (Stream File-Name . Options).  The file whose    bound to the variable Var. If the call to open is unsuccessful, the
1593     name is File-Name is opened using the Options and bound to the variable    forms are not evaluated.  The Forms are executed, and when they
1594     Stream.  If the call to open is unsuccessful, the forms are not    terminate, normally or otherwise, the file is closed."
    evaluated.  The Forms are executed, and when they terminate, normally or  
    otherwise, the file is closed."  
1595    (let ((abortp (gensym)))    (let ((abortp (gensym)))
1596      `(let ((,var (open ,@open-args))      `(let ((,var (open ,filespec ,@open-args))
1597             (,abortp t))             (,abortp t))
1598         ,@decls         ,@decls
1599         (when ,var         (unwind-protect
1600           (unwind-protect              (multiple-value-prog1
1601               (multiple-value-prog1                  (progn ,@forms)
1602                   (progn ,@forms)                (setq ,abortp nil))
1603                 (setq ,abortp nil))           (when ,var
1604             (close ,var :abort ,abortp))))))             (close ,var :abort ,abortp))))))
1605    
1606    
1607    (defmacro with-open-stream ((var stream) &parse-body (forms decls))
 (defmacro with-open-stream ((var stream) &body (forms decls))  
1608    "The form stream should evaluate to a stream.  VAR is bound    "The form stream should evaluate to a stream.  VAR is bound
1609     to the stream and the forms are evaluated as an implicit     to the stream and the forms are evaluated as an implicit
1610     progn.  The stream is closed upon exit."     progn.  The stream is closed upon exit."
# Line 1369  Line 1614 
1614         ,@decls         ,@decls
1615         (unwind-protect         (unwind-protect
1616           (multiple-value-prog1           (multiple-value-prog1
1617            (progn ,@forms)              (progn ,@forms)
1618            (setq ,abortp nil))            (setq ,abortp nil))
1619           (when ,var           (when ,var
1620             (close ,var :abort ,abortp))))))             (close ,var :abort ,abortp))))))
1621    
1622    
1623  (defmacro with-input-from-string ((var string &key index start end) &body (forms decls))  (defmacro with-input-from-string ((var string &key index start end)
1624                                      &parse-body (forms decls))
1625    "Binds the Var to an input stream that returns characters from String and    "Binds the Var to an input stream that returns characters from String and
1626    executes the body.  See manual for details."    executes the body.  See manual for details."
1627    `(let ((,var    ;; The once-only inhibits compiler note for unreachable code when 'end' is true.
1628            ,(if end    (once-only ((string string))
1629                 `(make-string-input-stream ,string ,(or start 0) ,end)      `(let ((,var
1630                 `(make-string-input-stream ,string ,(or start 0)))))              ,(cond ((null end)
1631       ,@decls                      `(make-string-input-stream ,string ,(or start 0)))
1632       (unwind-protect                     ((symbolp end)
1633         (progn ,@forms)                      `(if ,end
1634         (close ,var)                           (make-string-input-stream ,string ,(or start 0) ,end)
1635         ,@(if index `((setf ,index (string-input-stream-current ,var)))))))                           (make-string-input-stream ,string ,(or start 0))))
1636                       (t
1637                        `(make-string-input-stream ,string ,(or start 0) ,end)))))
1638           ,@decls
1639           (unwind-protect
1640                (multiple-value-prog1
1641                    (progn ,@forms)
1642                  ,@(when index
1643                       `((setf ,index (string-input-stream-current ,var)))))
1644             (close ,var)))))
1645    
1646    
1647  (defmacro with-output-to-string ((var &optional string) &body (forms decls))  (defmacro with-output-to-string ((var &optional string &key element-type)
1648    "If *string* is specified, it must be a string with a fill pointer;                                   &parse-body (forms decls))
1649      "If STRING is specified, it must be a string with a fill pointer;
1650     the output is incrementally appended to the string (as if by use of     the output is incrementally appended to the string (as if by use of
1651     VECTOR-PUSH-EXTEND)."     VECTOR-PUSH-EXTEND)."
1652      (declare (ignore element-type))
1653    (if string    (if string
1654        `(let ((,var (make-fill-pointer-output-stream ,string)))        `(let ((,var (make-fill-pointer-output-stream ,string)))
1655           ,@decls           ,@decls
# Line 1409  Line 1666 
1666    
1667  ;;;; Iteration macros:  ;;;; Iteration macros:
1668    
1669  (defmacro loop (&rest body)  ;; Helper for dotimes.  Extract any declarations for the dotimes
1670    "Executes the body repeatedly until the form is exited by a Throw or  ;; counter and create a similar declaration for our dummy loop
1671    Return.  The body is surrounded by an implicit block with name NIL."  ;; counter.  Skip over special declarations, though, because we don't
1672    (let ((tag (gensym)))  ;; want to make the dummy counter special.
1673      `(block nil (tagbody ,tag ,@body (go ,tag)))))  ;;
1674    ;; Returns two values:
1675    ;; 1.  Set of declarations for the dotimes loop counter that would be
1676    ;;     suitable for use in the result-form of the loop,
1677    ;; 2.  Declarations suitable for the dummy loop counter.
1678    (defun dotimes-extract-var-decls (var counter count decls)
1679      (let (var-decls counter-decls)
1680        (dolist (decl decls)
1681          (dolist (d (cdr decl))
1682            (when (member var (cdr d))
1683              (cond ((eq (car d) 'type)
1684                     (push `(type ,(second d) ,var) var-decls)
1685                     (push `(type ,(second d) ,counter) counter-decls))
1686                    ((eq (car d) 'special)
1687                     ;; Declare var special, but not the counter
1688                     (push `(,(car d) ,var) var-decls))
1689                    (t
1690                     (push `(,(car d) ,var) var-decls)
1691                     (push `(,(car d) ,counter) counter-decls))))))
1692        (unless counter-decls
1693          (setf counter-decls (if (numberp count)
1694                                  `((type (integer 0 ,count) ,counter))
1695                                  `((type unsigned-byte ,counter)))))
1696        (values (if var-decls
1697                    `((declare ,@(nreverse var-decls)))
1698                    nil)
1699                `((declare ,@(nreverse counter-decls))))))
1700    
1701    
1702    ;;; Make sure we iterate the given number of times, independent of
1703    ;;; what the body might do to the index variable.  We do this by
1704    ;;; repeatedly binding the var in the body and also in the result
1705    ;;; form.  We also spuriously reference the var in case the body or
1706    ;;; result form don't reference the var either.  (Mostly modeled on
1707    ;;; the dolist macro below.)
1708  (defmacro dotimes ((var count &optional (result nil)) &body body)  (defmacro dotimes ((var count &optional (result nil)) &body body)
1709    (cond ((numberp count)    (let ((count-var (gensym "CTR-")))
1710           `(do ((,var 0 (1+ ,var)))      (multiple-value-bind (forms decls)
1711                ((>= ,var ,count) ,result)          (parse-body body nil nil)
1712              ,@body))        (multiple-value-bind (var-decls ctr-decls)
1713          (t (let ((v1 (gensym)))            (dotimes-extract-var-decls var count-var count decls)
1714               `(do ((,var 0 (1+ ,var)) (,v1 ,count))          (cond ((numberp count)
1715                    ((>= ,var ,v1) ,result)                 `(do ((,count-var 0 (1+ ,count-var)))
1716                  ,@body)))))                      ((>= ,count-var ,count)
1717                         (let ((,var ,count-var))
1718                           ,@var-decls
1719                           ,var
1720                           ,result))
1721                      ,@ctr-decls
1722                      (let ((,var ,count-var))
1723                        ,@decls
1724                        ,var
1725                        (tagbody
1726                           ,@forms))))
1727                  (t (let ((v1 (gensym)))
1728                       `(do ((,count-var 0 (1+ ,count-var))
1729                             (,v1 ,count))
1730                            ((>= ,count-var ,v1)
1731                             (let ((,var ,count-var))
1732                               ,@var-decls
1733                               ,var
1734                               ,result))
1735                          ,@ctr-decls
1736                          (let ((,var ,count-var))
1737                            ,@decls
1738                            ,var
1739                            (tagbody
1740                               ,@forms))))))))))
1741    
1742    
1743  ;;; We repeatedly bind the var instead of setting it so that we never give the  ;;; We repeatedly bind the var instead of setting it so that we never give the
1744  ;;; var a random value such as NIL (which might conflict with a declaration).  ;;; var a random value such as NIL (which might conflict with a declaration).
1745  ;;; ### Might not be legal...  ;;; If there is a result form, we introduce a gratitous binding of the variable
1746    ;;; to NIL w/o the declarations, then evaluate the result form in that
1747    ;;; environment.  We spuriously reference the gratuitous variable, since we
1748    ;;; don't want to use IGNORABLE on what might be a special var.
1749  ;;;  ;;;
1750  (defmacro dolist ((var list &optional (result nil)) &body body)  (defmacro dolist ((var list &optional (result nil)) &body body)
1751    (let ((n-list (gensym)))    (multiple-value-bind (forms decls)
1752      `(do ((,n-list ,list (cdr ,n-list)))        (parse-body body nil nil)
1753           ((endp ,n-list)      (let ((n-list (gensym)))
1754            (let ((,var nil))        `(do* ((,n-list ,list (cdr ,n-list)))
1755              (declare (ignorable ,var))              ((endp ,n-list)
1756              ,result))               ,@(if (constantp result)
1757         (let ((,var (car ,n-list)))                     `(,result)
1758           ,@body))))                     `((let ((,var nil))
1759                           ,@decls
1760                           ,var
1761                           ,result))))
1762            (let ((,var (car ,n-list)))
1763              ,@decls
1764              (tagbody
1765                 ,@forms))))))
1766    
1767    
1768  (defmacro do (varlist endlist &body (body decls))  (defmacro do (varlist endlist &parse-body (body decls))
1769    "DO ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*    "DO ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
1770    Iteration construct.  Each Var is initialized in parallel to the value of the    Iteration construct.  Each Var is initialized in parallel to the value of the
1771    specified Init form.  On subsequent iterations, the Vars are assigned the    specified Init form.  On subsequent iterations, the Vars are assigned the
1772    value of the Step form (if any) in paralell.  The Test is evaluated before    value of the Step form (if any) in paralell.  The Test is evaluated before
1773    each evaluation of the body Forms.  When the Test is true, the the Exit-Forms    each evaluation of the body Forms.  When the Test is true, the Exit-Forms
1774    are evaluated as a PROGN, with the result being the value of the DO.  A block    are evaluated as a PROGN, with the result being the value of the DO.  A block
1775    named NIL is established around the entire expansion, allowing RETURN to be    named NIL is established around the entire expansion, allowing RETURN to be
1776    used as an laternate exit mechanism."    used as an laternate exit mechanism."
# Line 1455  Line 1778 
1778    (do-do-body varlist endlist body decls 'let 'psetq 'do nil))    (do-do-body varlist endlist body decls 'let 'psetq 'do nil))
1779    
1780    
1781  (defmacro do* (varlist endlist &body (body decls))  (defmacro do* (varlist endlist &parse-body (body decls))
1782    "DO* ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*    "DO* ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
1783    Iteration construct.  Each Var is initialized sequentially (like LET*) to the    Iteration construct.  Each Var is initialized sequentially (like LET*) to the
1784    value of the specified Init form.  On subsequent iterations, the Vars are    value of the specified Init form.  On subsequent iterations, the Vars are
1785    sequentially assigned the value of the Step form (if any).  The Test is    sequentially assigned the value of the Step form (if any).  The Test is
1786    evaluated before each evaluation of the body Forms.  When the Test is true,    evaluated before each evaluation of the body Forms.  When the Test is true,
1787    the the Exit-Forms are evaluated as a PROGN, with the result being the value    the Exit-Forms are evaluated as a PROGN, with the result being the value
1788    of the DO.  A block named NIL is established around the entire expansion,    of the DO.  A block named NIL is established around the entire expansion,
1789    allowing RETURN to be used as an laternate exit mechanism."    allowing RETURN to be used as an laternate exit mechanism."
1790    (do-do-body varlist endlist body decls 'let* 'setq 'do* nil))    (do-do-body varlist endlist body decls 'let* 'setq 'do* nil))
# Line 1469  Line 1792 
1792    
1793  ;;;; Miscellaneous macros:  ;;;; Miscellaneous macros:
1794    
 (defmacro locally (&rest forms)  
   "A form providing a container for locally-scoped variables."  
   `(let () ,@forms))  
   
1795  (defmacro psetq (&rest pairs)  (defmacro psetq (&rest pairs)
1796    (do ((lets nil)    "PSETQ {var value}*
1797         (setqs nil)     Set the variables to the values, like SETQ, except that assignments
1798         (pairs pairs (cddr pairs)))     happen in parallel, i.e. no assignments take place until all the
1799        ((atom (cdr pairs))     forms have been evaluated."
1800         `(let ,(nreverse lets) (setq ,@(nreverse setqs))))    ;; Given the possibility of symbol-macros, we delegate to PSETF
1801      (let ((gen (gensym)))    ;; which knows how to deal with them, after checking that syntax is
1802        (push `(,gen ,(cadr pairs)) lets)    ;; compatible with PSETQ.
1803        (push (car pairs) setqs)    (do ((pair pairs (cddr pair)))
1804        (push gen setqs))))        ((endp pair) `(psetf ,@pairs))
1805        (unless (symbolp (car pair))
1806          (error 'simple-program-error
1807                 :format-control (intl:gettext "variable ~S in PSETQ is not a SYMBOL")
1808                 :format-arguments (list (car pair))))))
1809    
1810    
1811    ;;; LAMBDA -- from the ANSI spec.
1812    ;;;
1813    (defmacro lambda (&whole form &rest bvl-decls-and-body)
1814      (declare (ignore bvl-decls-and-body))
1815      `#',form)
1816    
 ;;; ### Bootstrap hack...  
 ;;; Restore defmacro processing to normal.  
 ;;;  
 (eval-when (compile)  
   (setq *bootstrap-defmacro* nil))  
1817    
1818    
1819  ;;;; With-Compilation-Unit:  ;;;; With-Compilation-Unit:
1820    
1821  ;;; True if we are within a With-Compilation-Unit form, which normally causes  ;;; True if we are within a WITH-COMPILATION-UNIT form, which normally causes
1822  ;;; nested uses to be NOOPS.  ;;; nested uses to be NOOPS.
1823  ;;;  ;;;
1824  (defvar *in-compilation-unit* nil)  (defvar *in-compilation-unit* nil)
# Line 1503  Line 1828 
1828  ;;;  ;;;
1829  (defvar *aborted-compilation-units*)  (defvar *aborted-compilation-units*)
1830    
1831  (compiler-let ((*bootstrap-defmacro* :both))  (declaim (special c::*context-declarations*))
1832    
1833  ;;; With-Compilation-Unit  --  Public  
1834    ;;; EVALUATE-DECLARATION-CONTEXT  --  Internal
1835    ;;;
1836    ;;;    Recursively descend the context form, returning true if this subpart
1837    ;;; matches the specified context.
1838  ;;;  ;;;
1839    (defun evaluate-declaration-context (context name parent)
1840      (multiple-value-bind (valid base)
1841          (valid-function-name-p name)
1842        (let ((package (and valid (symbolp base) (symbol-package base))))
1843          (if (atom context)
1844              (multiple-value-bind (ignore how)
1845                  (if package
1846                      (find-symbol (symbol-name base) package)
1847                      (values nil nil))
1848                (declare (ignore ignore))
1849                (case context
1850                  (:internal (eq how :internal))
1851                  (:external (eq how :external))
1852                  (:uninterned (and (symbolp base) (not package)))
1853                  (:anonymous (not name))
1854                  (:macro (eq parent 'defmacro))
1855                  (:function (member parent '(defun labels flet function)))
1856                  (:global (member parent '(defun defmacro function)))
1857                  (:local (member parent '(labels flet)))
1858                  (t
1859                   (error (intl:gettext "Unknown declaration context: ~S.") context))))
1860              (case (first context)
1861                (:or
1862                 (loop for x in (rest context)
1863                       thereis (evaluate-declaration-context x name parent)))
1864                (:and
1865                 (loop for x in (rest context)
1866                       always (evaluate-declaration-context x name parent)))
1867                (:not
1868                 (evaluate-declaration-context (second context) name parent))
1869                (:member
1870                 (member name (rest context) :test #'equal))
1871                (:match
1872                 (let ((name (concatenate 'string "$" (string base) "$")))
1873                   (loop for x in (rest context)
1874                         thereis (search (string x) name))))
1875                (:package
1876                 (and package
1877                      (loop for x in (rest context)
1878                            thereis (eq (find-package (string x)) package))))
1879                (t
1880                 (error (intl:gettext "Unknown declaration context: ~S.") context)))))))
1881    
1882    
1883    ;;; PROCESS-CONTEXT-DECLARATIONS  --  Internal
1884    ;;;
1885    ;;;    Given a list of context declaration specs, return a new value for
1886    ;;; C::*CONTEXT-DECLARATIONS*.
1887    ;;;
1888    (defun process-context-declarations (decls)
1889      (append
1890       (mapcar
1891        #'(lambda (decl)
1892            (unless (>= (length decl) 2)
1893              (error (intl:gettext "Context declaration spec should have context and at ~
1894              least one DECLARE form:~%  ~S") decl))
1895            #'(lambda (name parent)
1896                (when (evaluate-declaration-context (first decl) name parent)
1897                  (rest decl))))
1898        decls)
1899       c::*context-declarations*))
1900    
1901    
1902    ;;; With-Compilation-Unit  --  Public
1903  ;;;  ;;;
1904  (defmacro with-compilation-unit (options &body body)  (defmacro with-compilation-unit (options &body body)
1905    (let ((force nil)    "WITH-COMPILATION-UNIT ({Key Value}*) Form*
1906      This form affects compilations that take place within its dynamic extent.  It
1907      is intended to be wrapped around the compilation of all files in the same
1908      system.  These keywords are defined:
1909        :OVERRIDE Boolean-Form
1910            One of the effects of this form is to delay undefined warnings
1911            until the end of the form, instead of giving them at the end of each
1912            compilation.  If OVERRIDE is NIL (the default), then the outermost
1913            WITH-COMPILATION-UNIT form grabs the undefined warnings.  Specifying
1914            OVERRIDE true causes that form to grab any enclosed warnings, even if
1915            it is enclosed by another WITH-COMPILATION-UNIT.
1916        :OPTIMIZE Decl-Form
1917            Decl-Form should evaluate to an OPTIMIZE declaration specifier.  This
1918            declaration changes the `global' policy for compilations within the
1919            body.
1920        :OPTIMIZE-INTERFACE Decl-Form
1921            Like OPTIMIZE, except that it specifies the value of the CMU extension
1922            OPTIMIZE-INTERFACE policy (which controls argument type and syntax
1923            checking.)
1924        :CONTEXT-DECLARATIONS List-of-Context-Decls-Form
1925            This is a CMU extension which allows compilation to be controlled
1926            by pattern matching on the context in which a definition appears.  The
1927            argument should evaluate to a list of lists of the form:
1928                (Context-Spec Declare-Form+)
1929            In the indicated context, the specified declare forms are inserted at
1930            the head of each definition.  The declare forms for all contexts that
1931            match are appended together, with earlier declarations getting
1932            predecence over later ones.  A simple example:
1933                :context-declarations
1934                '((:external (declare (optimize (safety 2)))))
1935            This will cause all functions that are named by external symbols to be
1936            compiled with SAFETY 2.  The full syntax of context specs is:
1937            :INTERNAL, :EXTERNAL
1938                True if the symbols is internal (external) in its home package.
1939            :UNINTERNED
1940                True if the symbol has no home package.
1941            :ANONYMOUS
1942                True if the function doesn't have any interesting name (not
1943                DEFMACRO, DEFUN, LABELS or FLET).
1944            :MACRO, :FUNCTION
1945                :MACRO is a global (DEFMACRO) macro.  :FUNCTION is anything else.
1946            :LOCAL, :GLOBAL
1947                :LOCAL is a LABELS or FLET.  :GLOBAL is anything else.
1948            (:OR Context-Spec*)
1949                True in any specified context.
1950            (:AND Context-Spec*)
1951                True only when all specs are true.
1952            (:NOT Context-Spec)
1953                True when the spec is false.
1954            (:MEMBER Name*)
1955                True when the name is one of these names (EQUAL test.)
1956            (:MATCH Pattern*)
1957                True when any of the patterns is a substring of the name.  The name
1958                is wrapped with $'s, so $FOO matches names beginning with FOO,
1959                etc."
1960      (let ((override nil)
1961            (optimize nil)
1962            (optimize-interface nil)
1963            (context-declarations nil)
1964          (n-fun (gensym))          (n-fun (gensym))
1965          (n-abort-p (gensym)))          (n-abort-p (gensym)))
1966      (when (oddp (length options))      (when (oddp (length options))
1967        (error "Odd number of key/value pairs: ~S." options))        (error (intl:gettext "Odd number of key/value pairs: ~S.") options))
1968      (do ((opt options (cddr opt)))      (do ((opt options (cddr opt)))
1969          ((null opt))          ((null opt))
1970        (case (first opt)        (case (first opt)
1971          (:force          (:override
1972           (setq force (second opt)))           (setq override (second opt)))
1973            (:optimize
1974             (setq optimize (second opt)))
1975            (:optimize-interface
1976             (setq optimize-interface (second opt)))
1977            (:context-declarations
1978             (setq context-declarations (second opt)))
1979          (t          (t
1980           (warn "Ignoring unknown option: ~S." (first opt)))))           (warn (intl:gettext "Ignoring unknown option: ~S.") (first opt)))))
1981    
1982      `(flet ((,n-fun () ,@body))      `(flet ((,n-fun ()
1983         (if (or ,force (not *in-compilation-unit*))                (let (,@(when optimize
1984                            `((c::*default-cookie*
1985                               (c::process-optimize-declaration
1986                                ,optimize c::*default-cookie*))))
1987                        ,@(when optimize-interface
1988                            `((c::*default-interface-cookie*
1989                               (c::process-optimize-declaration
1990                                ,optimize-interface
1991                                c::*default-interface-cookie*))))
1992                        ,@(when context-declarations
1993                            `((c::*context-declarations*
1994                               (process-context-declarations
1995                                ,context-declarations)))))
1996                    ,@body)))
1997           (if (or ,override (not *in-compilation-unit*))
1998             (let ((c::*undefined-warnings* nil)             (let ((c::*undefined-warnings* nil)
1999                   (c::*compiler-error-count* 0)                   (c::*compiler-error-count* 0)
2000                   (c::*compiler-warning-count* 0)                   (c::*compiler-warning-count* 0)
# Line 1534  Line 2005 
2005               (handler-bind ((c::parse-unknown-type               (handler-bind ((c::parse-unknown-type
2006                               #'(lambda (c)                               #'(lambda (c)
2007                                   (c::note-undefined-reference                                   (c::note-undefined-reference
2008                                    (c::parse-unknown-type-specifier c)                                    (kernel:parse-unknown-type-specifier c)
2009                                    :type))))                                    :type))))
2010                 (unwind-protect                 (unwind-protect
2011                     (multiple-value-prog1                     (multiple-value-prog1
# Line 1548  Line 2019 
2019                     (setq ,n-abort-p nil))                     (setq ,n-abort-p nil))
2020                 (when ,n-abort-p                 (when ,n-abort-p
2021                   (incf *aborted-compilation-units*))))))))                   (incf *aborted-compilation-units*))))))))
 ); Compiler-Let  

Legend:
Removed from v.1.6.1.2  
changed lines
  Added in v.1.120

  ViewVC Help
Powered by ViewVC 1.1.5